text: /*
   * Copyright (c) 1994-2018, NVIDIA CORPORATION.  All rights reserved.
   *
   * Licensed under the Apache License, Version 2.0 (the "License");
   * you may not use this file except in compliance with the License.
   * You may obtain a copy of the License at
   *
   *     http://www.apache.org/licenses/LICENSE-2.0
   *
   * Unless required by applicable law or agreed to in writing, software
   * distributed under the License is distributed on an "AS IS" BASIS,
   * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   * See the License for the specific language governing permissions and
   * limitations under the License.
   *
   */
  
  /** \file
   *  \brief Utility routines used by semantic analyzer.
   *
   *  Fortran front-end utility routines used by Semantic Analyzer to process
   *  functions, subroutines, predeclareds, statement functions, etc.
   */
  
  #include "gbldefs.h"
  #include "global.h"
  #include "error.h"
  #include "symtab.h"
  #include "symutl.h"
  #include "dtypeutl.h"
  #include "semant.h"
  #include "scan.h"
  #include "semstk.h"
  #include "pd.h"
  #include "machar.h"
  #include "ast.h"
  #include "rte.h"
  #include "rtlRtns.h"
  
  static LOGICAL get_keyword_args(ITEM *, int, char *, int, int);
  static int get_fval_array(int);
  static LOGICAL cmpat_arr_arg(int, int);
  static void dump_stfunc(int);
  
  /*---------------------------------------------------------------------*/
  
  /*
      routines to define statement functions and reference statement
      functions
  */
  
  /*  define structures needed for statement function processing: */
  
  /** \brief Information about statement function arguments. */
  typedef struct _arginfo {
    int dtype;             /**< data type of dummy argument  */
    int formal;            /**< dummy's ast */
    int actual;            /**< ast of argument to replace corresponding dummy */
    int save;              /**< save/restore field */
    unsigned refd : 1;     /**< if set, formal is referenced */
    struct _arginfo *next; /**< next argument info record */
  } ARGINFO;
  
  /** \brief Statement function used in the right-hand side. */
  typedef struct _sfuse {
    int node;            /**< unique id ast to be replaced when invoked */
    struct _sfdsc *dsc;  /**< its statement function descriptor */
    ARGINFO *args;       /**< arguments to the statement function */
    struct _sfuse *next; /**< next statement function used */
  } SFUSE;
  
  /** \brief Statement function descriptor. */
  typedef struct _sfdsc {
    int dtype;     /**< dtype of the statement function */
    int rhs;       /**< ast of right hand side */
    ARGINFO *args; /**< ptr to list of arginfo records */
    SFUSE *l_use;  /**< list of statement functions used in rhs */
  } SFDSC;
  
  /** \brief List of statement functions used in a definition.
   *
   *  Keep track of the statement functions used in a definition and the
   *  arguments to those statement functions which need to be evaluated
   *  and saved in a temporary. The order of the list is in 'evaluation' order.
   */
  static SFUSE *l_sfuse = NULL;
  static SFUSE *end_sfuse = NULL; /**< End of list -- always add here */
  
  static void asn_sfuse(SFUSE *);
  
  static void _non_private(int, int *);
  static ITEM *stfunc_argl;
  
  static int pass_position = 0;
  static int pass_object_dummy = 0;
  
  /** \brief Set position of type-bound procedure passed object location. */
  void
  set_pass_objects(int pos, int pod)
  {
    pass_position = pos;
    pass_object_dummy = pod;
  }
  
  /** \brief Perform error checking and create statement function descriptor
   *         for statement function definition.
   */
  int
  define_stfunc(int sptr, ITEM *argl, SST *estk)
  {
    int expr;
    int arg, dtype;
    ITEM *itemp;
    ARGINFO *arginfo, *lastarg;
    SFDSC *sfdsc;
    SST *stkptr;
    int ast;
    int argt;
    int i;
    static int last_stfunc; /* last ST_FUNC created */
    SFUSE *sfuse;
  
    expr = mkexpr(estk);
    ast = SST_ASTG(estk);
    stfunc_argl = argl;
  
    ast_visit(1, 1);                             /* marks ast#1 visited */
    ast_traverse(ast, NULL, _non_private, NULL); /* vist each ast in the rhs */
  
    /* traverse the args to any statement functions ref'd in this one */
    for (sfuse = l_sfuse; sfuse; sfuse = sfuse->next)
      for (arginfo = sfuse->args; arginfo; arginfo = arginfo->next)
        ast_traverse(arginfo->actual, NULL, NULL, NULL);
  
    /*  allocate and initialize statement function descriptor  */
  
    /* NOTE: 9/17/97, area 8 is used for stmt functions -- need to keep
     * just in case the defs appear in a containing subprogram.
     */
    sfdsc = (SFDSC *)getitem(8, sizeof(SFDSC));
    sfdsc->args = NULL;
  
    /*  scan list of dummy arguments and process each argument; all arguments
     *  have been validated by semant.
     */
    lastarg = NULL;
    for (itemp = argl; itemp != ITEM_END; itemp = itemp->next) {
      int old, new;
      stkptr = itemp->t.stkp;
      arg = SST_SYMG(stkptr);
      if (ARGINFOG(arg)) { /* duplicate dummy */
        error(42, 3, gbl.lineno, SYMNAME(arg), CNULL);
        ast_unvisit();
        return 0;
      }
      dtype = DTYPEG(arg);
      /*
       * allocate and initialize an arginfo record for this dummy,
       * and link it into end of argument list
       */
      arginfo = (ARGINFO *)getitem(8, sizeof(ARGINFO));
      old = SST_ASTG(itemp->t.stkp);
      /*
       * replace the ast of the formal argument with a unique ast; can't
       * share asts of any formals with any nested statement functions.
       */
      new = new_node(A_ID);
      A_SPTRP(new, arg);
      A_DTYPEP(new, dtype);
      ast_replace(old, new);
      arginfo->formal = new;
      arginfo->dtype = dtype;
      arginfo->next = NULL;
      arginfo->refd = A_VISITG(old) != 0;
      if (lastarg == NULL) /* this is first argument */
        sfdsc->args = arginfo;
      else
        lastarg->next = arginfo;
      lastarg = arginfo;
      ARGINFOP(arg, put_getitem_p(arginfo));
    }
    /*
     * rewrite the rhs of the statement function and the actual argument
     * asts of any statement functions ref'd in this one; this replaces
     * the original asts of the formal arguments with their new asts.
     */
    ast = ast_rewrite(ast);
    for (sfuse = l_sfuse; sfuse; sfuse = sfuse->next)
      for (arginfo = sfuse->args; arginfo; arginfo = arginfo->next)
        arginfo->actual = ast_rewrite(arginfo->actual);
  
    ast_unvisit();
  
    sfdsc->rhs = ast;
    sfdsc->l_use = l_sfuse; /* list of statement functions used */
    end_sfuse = l_sfuse = NULL;
  
    /*  set ARGINFO fields of dummies back to 0  */
  
    for (itemp = argl; itemp != ITEM_END; itemp = itemp->next)
      ARGINFOP(SST_SYMG(itemp->t.stkp), 0);
  
    SFDSCP(sptr, put_getitem_p(sfdsc));
    STYPEP(sptr, ST_STFUNC);
    SFASTP(sptr, ast);
    sfdsc->dtype = DTYPEG(sptr);
    if (gbl.stfuncs == NOSYM)
      gbl.stfuncs = sptr;
    else
      SYMLKP(last_stfunc, sptr);
    last_stfunc = sptr;
  
    if (DBGBIT(3, 16))
      dump_stfunc(sptr);
  
    return ast;
  }
  
  /** \brief AST visitor function
   *
   *  This is passed to ast_traverse() to add variables with add_non_private.
   */
  static void
  _non_private(int ast, int *dummy)
  {
    int sptr;
    if (!flg.smp)
      return;
    if (A_TYPEG(ast) != A_ID)
      return;
    sptr = A_SPTRG(ast);
    if (ST_ISVAR(STYPEG(sptr))) {
      /*
       * Make sure that sptr is not the dummy arg to the statement function.
       */
      ITEM *itemp;
      for (itemp = stfunc_argl; itemp != ITEM_END; itemp = itemp->next) {
        SST *stkptr;
        int arg;
        stkptr = itemp->t.stkp;
        arg = SST_SYMG(stkptr);
        if (arg == sptr)
          break;
      }
      if (itemp == ITEM_END)
        add_non_private(sptr);
    }
  }
  
  /*---------------------------------------------------------------------*/
  
  /** \brief Write out statement function descriptor to debug file. */
  static void
  dump_stfunc(int sptr)
  {
    SFDSC *sfdsc;
    ARGINFO *arginfo;
    SFUSE *sfuse;
  
    sfdsc = (SFDSC *)get_getitem_p(SFDSCG(sptr));
    fprintf(gbl.dbgfil, "\nSTATEMENT FUNCTION DEFN: %s, sfdsc: %p, dtype: %d\n",
            SYMNAME(sptr), (void *)sfdsc, sfdsc->dtype);
  
    for (arginfo = sfdsc->args; arginfo; arginfo = arginfo->next) {
      fprintf(gbl.dbgfil, "    arg: %p   ast: %d   dtype: %d   refd: %d\n",
              (void *)arginfo, arginfo->formal, arginfo->dtype, arginfo->refd);
      dump_one_ast(arginfo->formal);
    }
    fprintf(gbl.dbgfil, "\nRHS:");
    dump_ast_tree(sfdsc->rhs);
    fprintf(gbl.dbgfil, "\n");
    fprintf(gbl.dbgfil, "sfuse:\n");
    for (sfuse = sfdsc->l_use; sfuse; sfuse = sfuse->next) {
      fprintf(gbl.dbgfil, "<sfdsc %p, exprs: %p>\n", (void *)sfuse->dsc,
              (void *)sfuse->args);
      for (arginfo = sfuse->args; arginfo; arginfo = arginfo->next) {
        fprintf(gbl.dbgfil, "    arginfo: %p  actual: %d   dtype: %d\n",
                (void *)arginfo, arginfo->actual, arginfo->dtype);
        dump_one_ast(arginfo->actual);
      }
    }
    fprintf(gbl.dbgfil, "\n");
  }
  
  /*---------------------------------------------------------------------*/
  
  int
  ref_stfunc(SST *stktop, ITEM *args)
  {
    int sptr;
    int dtype;
    ITEM *itemp;
    SFDSC *sfdsc;
    ARGINFO *arginfo;
    SFUSE *sfuse;
    ARGINFO *ai;
    int ast;
    int i;
    int tmp;
    int new;
    int asn;
  
    sptr = SST_SYMG(stktop);
    if (DBGBIT(3, 16))
      fprintf(gbl.dbgfil, "\nInvoking statement function %s\n", SYMNAME(sptr));
    dtype = DTYPEG(sptr);
    sfdsc = (SFDSC *)get_getitem_p(SFDSCG(sptr));
    if (sem.in_stfunc) {
      /* NOTE: 9/17/97, area 8 is used for stmt functions -- need to keep
       * just in case the defs appear in a containing subprogram.
       */
      sfuse = (SFUSE *)getitem(8, sizeof(SFUSE));
      sfuse->dsc = sfdsc;
      sfuse->args = NULL;
      /*
       * create a unique id AST whose sptr is the statement function
       * which is referenced; this id will be replaced by the statement
       * function's right-hand side (after argument substitution).
       */
      sfuse->node = new_node(A_ID);
      A_SPTRP(sfuse->node, sptr);
      A_DTYPEP(sfuse->node, dtype);
      /*
       * add this statement function to the 'global' statement function
       * use; when the definition ultimately occurs, the pointer to the
       * list will be stored in the descriptor of the statement which
       * is defined.
       */
      if (end_sfuse == NULL)
        end_sfuse = l_sfuse = sfuse;
      else
        end_sfuse->next = sfuse;
      end_sfuse = sfuse;
      sfuse->next = NULL;
      if (DBGBIT(3, 16))
        fprintf(gbl.dbgfil, "%s in statement fcn def, use %p, node %d\n",
                SYMNAME(sptr), (void *)sfuse, sfuse->node);
    }
    /*
     * scan thru actual argument list, and list of dummy arg info
     * records in parallel to check type and create asts for actual args
     */
    for (itemp = args, arginfo = sfdsc->args;
         itemp != ITEM_END && arginfo != NULL;
         itemp = itemp->next, arginfo = arginfo->next) {
      if (SST_IDG(itemp->t.stkp) == S_KEYWORD) {
        error(79, 3, gbl.lineno, scn.id.name + SST_CVALG(itemp->t.stkp), CNULL);
        itemp->t.stkp = SST_E3G(itemp->t.stkp);
        arginfo->refd = 0;
      } else if (SST_IDG(itemp->t.stkp) == S_TRIPLE ||
                 SST_IDG(itemp->t.stkp) == S_STAR) {
        error(155, 3, gbl.lineno,
              "An argument to this statement function looks "
              "like an array section subscript",
              CNULL);
        continue;
      }
  
      if (arginfo->refd)
        (void)chktyp(itemp->t.stkp, arginfo->dtype, TRUE);
      else /* although arg isn't refd, ensure ast for the actual exists */
        (void)mkexpr(itemp->t.stkp);
      ast = SST_ASTG(itemp->t.stkp);
      arginfo->actual = ast;
    }
  
    /*  check that number of arguments is correct  */
  
    if (itemp != ITEM_END || arginfo != NULL)
      error(85, 3, gbl.lineno, SYMNAME(sptr), CNULL);
    /*
     * If in a statement function definition, create a list of actual
     * arguments passed to the statement function.
     */
    if (sem.in_stfunc) {
      for (arginfo = sfdsc->args; arginfo != NULL; arginfo = arginfo->next) {
        ai = (ARGINFO *)getitem(8, sizeof(ARGINFO));
        ai->next = sfuse->args;
        sfuse->args = ai;
        ai->actual = arginfo->actual;
        ai->formal = arginfo->formal;
        ai->dtype = arginfo->dtype;
        ai->refd = arginfo->refd;
        if (DBGBIT(3, 16)) {
          fprintf(gbl.dbgfil, "expr to be substituted, ast %d, arginfo %p\n",
                  ai->actual, (void *)ai);
          fprintf(gbl.dbgfil, "formal(%d):\n", ai->formal);
          dbg_print_ast(ai->formal, gbl.dbgfil);
          fprintf(gbl.dbgfil, "actual(%d):\n", ai->actual);
          dbg_print_ast(ai->actual, gbl.dbgfil);
        }
      }
      ast = sfuse->node;
      goto return_it;
    }
    /*
     * replace uses of the dummy arguments with the actual arguments.
     */
    ast_visit(1, 1);
    for (arginfo = sfdsc->args; arginfo != NULL; arginfo = arginfo->next) {
      if (!arginfo->refd) {
        if (DBGBIT(3, 16)) {
          fprintf(gbl.dbgfil, "\n   skipping unref'd arg");
          dump_ast_tree(arginfo->formal);
        }
        continue;
      }
      ast = arginfo->actual;
      if (A_CALLFGG(ast) || A_TYPEG(ast) == A_CONV) {
        /*
         * evaluate and assign  the argument to a temporary if:
         * 1.  argument contains a function call - ensure the
         *     the function is evaluated just once, or
         * 2.  the argument is converted to another type - need to
         *     preserve the type.
         */
        tmp = get_temp(arginfo->dtype);
        if (DBGBIT(3, 16))
          fprintf(gbl.dbgfil, "\n   create temp.1 %s\n", SYMNAME(tmp));
        new = mk_id(tmp);
        asn = mk_assn_stmt(new, ast, arginfo->dtype);
        (void)add_stmt(asn);
        arginfo->actual = new;
      }
      ast_replace(arginfo->formal, arginfo->actual);
      if (DBGBIT(3, 16)) {
        fprintf(gbl.dbgfil, "\n   replace %d:\n", arginfo->formal);
        dbg_print_ast(arginfo->formal, gbl.dbgfil);
        fprintf(gbl.dbgfil, "   with %d:\n", arginfo->actual);
        /*dump_ast_tree(arginfo->actual);*/
        dbg_print_ast(arginfo->actual, gbl.dbgfil);
      }
    }
  
    /* evaluate any statement functions which appeared in the definition
     * of the statement function.
     */
    asn_sfuse(sfdsc->l_use);
  
    ast = ast_rewrite(sfdsc->rhs);
    ast_unvisit();
    if (DBGBIT(3, 16)) {
      fprintf(gbl.dbgfil, "\n   statement function result %d\n", ast);
      /*dump_ast_tree(ast);*/
      dbg_print_ast(ast, gbl.dbgfil);
      fprintf(gbl.dbgfil, "\n");
    }
    if (!sem.in_stfunc && A_TYPEG(ast) == A_CONV) {
      /* TBD:  replace with an expression to convert the type.
       * For now, just
       * assign the result to a temporary if the result is converted
       * to another type - need to preserve the type.
       */
      tmp = get_temp(dtype);
      if (DBGBIT(3, 16))
        fprintf(gbl.dbgfil, "\n   create temp.2 %s\n", SYMNAME(tmp));
      new = mk_id(tmp);
      asn = mk_assn_stmt(new, ast, dtype);
      (void)add_stmt(asn);
      ast = new;
    }
    if (gbl.internal > 1) {
      ast_visit(1, 1); /* marks ast#1 visited */
      ast_traverse(ast, NULL, set_internref_stfunc,
                   NULL); /* vist each ast in the rhs */
      ast_unvisit();
    }
  
  return_it:
    SST_ASTP(stktop, ast);
    SST_SHAPEP(stktop, 0);
    SST_DTYPEP(stktop, dtype);
    SST_IDP(stktop, S_EXPR);
  
    return 1;
  }
  
  static void
  asn_sfuse(SFUSE *l_use)
  {
    SFUSE *sfuse;
    ARGINFO *expr;
    int ast;
    int tmp;
    int asn;
    int new;
  
    if (DBGBIT(3, 16))
      fprintf(gbl.dbgfil, "asn_sfuse entered\n");
    for (sfuse = l_use; sfuse != NULL; sfuse = sfuse->next) {
      if (DBGBIT(3, 16))
        fprintf(gbl.dbgfil, "\n    asn_sfuse, begin sfuse %p, node %d\n",
                (void *)sfuse, sfuse->node);
  
      /* substitute the actual arguments for the corresponding formals */
  
      for (expr = sfuse->args; expr != NULL; expr = expr->next) {
        expr->save = A_REPLG(expr->formal);
        if (!expr->refd) {
          if (DBGBIT(3, 16)) {
            fprintf(gbl.dbgfil, "\n   asn_sfuse: skipping unref'd arg");
            dump_ast_tree(expr->formal);
          }
          continue;
        }
        ast = ast_rewrite(expr->actual);
        if (A_CALLFGG(ast) || A_TYPEG(ast) == A_CONV) {
          tmp = get_temp(expr->dtype);
          new = mk_id(tmp);
          asn = mk_assn_stmt(new, ast, expr->dtype);
          (void)add_stmt(asn);
          ast = new;
        }
        ast_replace(expr->formal, ast);
        if (DBGBIT(3, 16)) {
          fprintf(gbl.dbgfil, "    asn_sfuse, replace formal %d\n", expr->formal);
          dbg_print_ast(expr->formal, gbl.dbgfil);
          fprintf(gbl.dbgfil, "    asn_sfuse, with %d\n", ast);
          dbg_print_ast(ast, gbl.dbgfil);
        }
      }
      /*
       * evaluate any statement functions which were invoked in this
       * statement function.
       */
      asn_sfuse(sfuse->dsc->l_use);
      /*
       * replace the statement function with the evaluation of its
       * right-hand side.
       */
      ast = ast_rewrite(sfuse->dsc->rhs);
      if (DBGBIT(3, 16)) {
        fprintf(gbl.dbgfil, "    asn_sfuse, rewrite %d:\n", sfuse->dsc->rhs);
        dbg_print_ast(sfuse->dsc->rhs, gbl.dbgfil);
        fprintf(gbl.dbgfil, "    asn_sfuse, as %d:\n", ast);
        dbg_print_ast(ast, gbl.dbgfil);
      }
      if (A_CALLFGG(ast) || A_TYPEG(ast) == A_CONV) {
        tmp = get_temp(sfuse->dsc->dtype);
        if (DBGBIT(3, 16))
          fprintf(gbl.dbgfil, "    asn_sfuse, create temp %s\n", SYMNAME(tmp));
        new = mk_id(tmp);
        asn = mk_assn_stmt(new, ast, sfuse->dsc->dtype);
        (void)add_stmt(asn);
        ast = new;
      }
      ast_replace(sfuse->node, ast);
      if (DBGBIT(3, 16))
        fprintf(gbl.dbgfil, "    asn_sfuse, end sfuse %p, node %d\n",
                (void *)sfuse, A_REPLG(sfuse->node));
      /*
       * cleanup in this order: zero out the REPL fields of the right-hand
       * side and restore the state of the formals to the statement function.
       */
      ast_clear_repl(sfuse->dsc->rhs);
      for (expr = sfuse->args; expr != NULL; expr = expr->next)
        A_REPLP(expr->formal, expr->save);
    }
    if (DBGBIT(3, 16))
      fprintf(gbl.dbgfil, "asn_sfuse returned\n");
  }
  
  /*---------------------------------------------------------------------*/
  
  /** \brief Check and write ILMs for a subprogram argument.
   *  \param stkptr a stack entry representing a subprogram argument
   *  \param dtype  used to pass out data type of argument
   *  \return       sptr for alternate return label
   */
  int
  mkarg(SST *stkptr, int *dtype)
  {
    int sptr, cp, sp2, ast;
    int dt;
  
  again:
    switch (SST_IDG(stkptr)) {
    case S_STFUNC: /* delayed var ref */
      SST_IDP(stkptr, S_IDENT);
      (void)mkvarref(stkptr, SST_ENDG(stkptr));
      goto again;
  
    case S_DERIVED:
      if (SST_DBEGG(stkptr)) {
        (void)mkvarref(stkptr, SST_DBEGG(stkptr));
        return 1;
      }
      sptr = SST_SYMG(stkptr);
      mkident(stkptr);
      SST_SYMP(stkptr, sptr);
      goto add_sym_arg;
  
    case S_CONST:
      SST_CVLENP(stkptr, 0);
      if (SST_DTYPEG(stkptr) == DT_HOLL) {
        SST_DTYPEP(stkptr, DT_INT);
        SST_IDP(stkptr, S_EXPR);
      } else {
        if (SST_DTYPEG(stkptr) == DT_WORD)
          SST_DTYPEP(stkptr, DT_INT);
        mkexpr(stkptr);
      }
      *dtype = SST_DTYPEG(stkptr);
      return 1;
  
    case S_ACONST:
      /* resolve it */
      if (!SST_ACLG(stkptr)) { /* zero-sized array */
        int sdtype;
        sptr = sym_get_array("zs", "array", SST_DTYPEG(stkptr), 1);
        sdtype = DTYPEG(sptr);
        ADD_LWBD(sdtype, 0) = ADD_LWAST(sdtype, 0) = astb.bnd.one;
        ADD_UPBD(sdtype, 0) = ADD_UPAST(sdtype, 0) = astb.bnd.zero;
        ADD_EXTNTAST(sdtype, 0) =
            mk_extent(ADD_LWAST(sdtype, 0), ADD_UPAST(sdtype, 0), 0);
      } else {
        sptr = init_sptr_w_acl(0, SST_ACLG(stkptr));
      }
      mkident(stkptr);
      SST_SYMP(stkptr, sptr);
      goto add_const_sym_arg;
  
    case S_IDENT:
      /* resolve it */
      sptr = SST_SYMG(stkptr);
      switch (STYPEG(sptr)) {
      case ST_PD:
        sp2 = sptr;
        if (!EXPSTG(sptr)) {
          sptr = newsym(sptr);
          STYPEP(sptr, ST_VAR);
          sem_set_storage_class(sptr);
          goto add_sym_arg;
        }
        goto common_intrinsic;
      case ST_ENTRY:
        if (gbl.rutype == RU_SUBR && (flg.recursive || RECURG(sptr)))
          ;
        else if (gbl.rutype != RU_FUNC)
          error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
        else if (!RESULTG(sptr))
          sptr = ref_entry(sptr);
        /* if RESULTG is set, the reference to the function name
         * must mean the function itself; if not, the function name
         * must mean the function result variable */
        goto add_sym_arg;
      case ST_UNKNOWN:
      case ST_IDENT:
        STYPEP(sptr, ST_VAR);
      /* fall through to ... */
      case ST_VAR:
      case ST_ARRAY:
        if (DTY(DTYPEG(sptr)) != TY_ARRAY || DDTG(DTYPEG(sptr)) == DT_DEFERCHAR ||
            DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR) {
          /* test for scalar pointer */
          if ((ALLOCATTRG(sptr) || POINTERG(sptr)) && SDSCG(sptr) == 0 &&
              !F90POINTERG(sptr)) {
            if (SCG(sptr) == SC_NONE)
              SCP(sptr, SC_BASED);
            get_static_descriptor(sptr);
            get_all_descriptors(sptr);
          }
        }
        goto add_sym_arg;
      case ST_USERGENERIC:
        if (GSAMEG(sptr)) {
          /* use the specific of the same name */
          sptr = GSAMEG(sptr);
          goto add_sym_arg;
        }
        /* can't pass the generic name as an argument */
        error(73, 3, gbl.lineno, SYMNAME(sptr), CNULL);
        SST_DTYPEP(stkptr, *dtype = DT_INT);
        return 1;
      case ST_GENERIC:
        /* Generic used as an actual argument.  Use specific of same name.
         * If none, then assume its a variable unless generic is frozen.
         */
        sp2 = select_gsame(sptr); /* intrinsic of same name */
        if (sp2 == 0 || !EXPSTG(sptr)) {
          sptr = newsym(sptr);
          STYPEP(sptr, ST_VAR);
          sem_set_storage_class(sptr);
          goto add_sym_arg;
        }
        sp2 = intrinsic_as_arg(sptr);
        if (sp2 == 0) {
          /* may not be passed as argument */
          error(73, 3, gbl.lineno, SYMNAME(sptr), CNULL);
          SST_DTYPEP(stkptr, *dtype = DT_INT);
          return 1;
        }
        if (STYPEG(sp2) == ST_PROC)
          sptr = sp2;
        else if (sp2 != GSAMEG(sptr)) {
          DTYPEP(sp2, INTTYPG(sp2));
          sptr = sp2;
        } else
          DTYPEP(sptr, INTTYPG(sp2));
        goto add_sym_arg;
      case ST_INTRIN:
        sp2 = sptr;
        if (!EXPSTG(sptr)) {
          sptr = newsym(sptr);
          STYPEP(sptr, ST_VAR);
          sem_set_storage_class(sptr);
          goto add_sym_arg;
        }
      common_intrinsic:
        sp2 = intrinsic_as_arg(sptr);
        if (sp2 == 0) {
          /* may not be passed as argument */
          error(73, 3, gbl.lineno, SYMNAME(sptr), CNULL);
          SST_DTYPEP(stkptr, *dtype = DT_INT);
          return 1;
        }
        if (STYPEG(sp2) != ST_PROC)
          DTYPEP(sp2, INTTYPG(sp2));
        sptr = sp2;
        goto add_sym_arg;
      case ST_PROC:
        sp2 = SCOPEG(sptr);
        if (STYPEG(sp2) == ST_ALIAS)
          sp2 = SYMLKG(sp2);
        if (ELEMENTALG(sptr)) {
          error(464, 3, gbl.lineno, SYMNAME(sptr), CNULL);
          SST_DTYPEP(stkptr, *dtype = DTYPEG(sptr));
          return 1;
        }
        TYPDP(sptr, 1); /* force it to appear in an EXTERNAL stmt */
        goto add_sym_arg;
      case ST_STFUNC:
      case ST_STRUCT:
      case ST_TYPEDEF:
        goto add_sym_arg;
  
      default:
        error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
        SST_DTYPEP(stkptr, *dtype = DTYPEG(sptr));
        SST_ASTP(stkptr, mk_id(sptr));
        SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
        return 3;
      }
  
    case S_LVALUE:
      *dtype = SST_DTYPEG(stkptr);
      ARGP(SST_LSYMG(stkptr), 1);
      ast = SST_ASTG(stkptr);
      if (ast && A_TYPEG(ast) == A_MEM) {
        /* this is a derived-type member reference, see if the
         * member needs a static descriptor */
        sptr = find_pointer_variable(ast);
        if (DTY(DTYPEG(sptr)) != TY_ARRAY) {
          if (POINTERG(sptr) && SDSCG(sptr) == 0 && !F90POINTERG(sptr)) {
            if (STYPEG(sptr) != ST_MEMBER && SCG(sptr) == SC_NONE)
              SCP(sptr, SC_BASED);
            get_static_descriptor(sptr);
            get_all_descriptors(sptr);
          }
        }
      }
      sptr = SST_LSYMG(stkptr);
      SST_CVLENP(stkptr, 0);
      dt = DDTG(DTYPEG(sptr)); /* element dtype record */
      if ((DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR) && ADJLENG(sptr)) {
        SST_CVLENP(stkptr, size_ast(sptr, dt));
      }
      return 1;
  
    case S_EXPR:
    case S_LOGEXPR:
      *dtype = SST_DTYPEG(stkptr);
      if (flg.endian) {
        switch (DTY(SST_DTYPEG(stkptr))) {
        case TY_BINT:
        case TY_BLOG:
        case TY_SINT:
        case TY_SLOG:
          return tempify(stkptr);
        default:
          break;
        }
      }
      return 1;
  
    case S_REF:
      *dtype = SST_DTYPEG(stkptr);
      return 1;
  
    case S_VAL:
      *dtype = SST_DTYPEG(stkptr);
      return 1;
  
    case S_LABEL:
      *dtype = 0;
      return -SST_SYMG(stkptr);
  
    case S_SCONST:
      if (!SST_ACLG(stkptr)) {
        sptr = getcctmp_sc('d', sem.dtemps++, ST_VAR, SST_DTYPEG(stkptr), sem.sc);
      } else {
        sptr = init_derived_w_acl(0, SST_ACLG(stkptr));
      }
      mkident(stkptr);
      SST_SYMP(stkptr, sptr);
      goto add_const_sym_arg;
  
    case S_KEYWORD:
      return mkarg(SST_E3G(stkptr), dtype);
  
    case S_STAR:
    case S_TRIPLE:
      error(
          155, 3, gbl.lineno,
          "An argument to this subprogram looks like an array section subscript",
          CNULL);
      /* change to constant zero, see if we can avoid further errors */
      SST_DTYPEP(stkptr, *dtype = DT_INT);
      SST_ASTP(stkptr, astb.i0);
      SST_SHAPEP(stkptr, 0);
      SST_IDP(stkptr, S_CONST);
      return 3;
  
    default:
      interr("mkarg: arg has bad stkid", SST_IDG(stkptr), 3);
      return 3;
    }
  
  add_sym_arg:
    sptr = ref_object(sptr);
  add_const_sym_arg:
    ARGP(sptr, 1);
    SST_DTYPEP(stkptr, *dtype = DTYPEG(sptr));
    SST_ASTP(stkptr, mk_id(sptr));
    SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
    SST_CVLENP(stkptr, 0);
    dt = DDTG(DTYPEG(sptr)); /* element dtype record */
    if ((DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR) && ADJLENG(sptr)) {
      SST_CVLENP(stkptr, size_ast(sptr, dt));
    }
    return 1;
  }
  
  #if defined(TARGET_WIN_X86) && defined(PGFTN)
  /*
   * convert to upper case
   */
  static void
  upcase_name(char *name)
  {
    char *p;
    int ch;
    for (p = name; ch = *p; ++p)
      if (ch >= 'a' && ch <= 'z')
        *p = ch + ('A' - 'a');
  }
  #endif
  
  int
  intrinsic_as_arg(int intr)
  {
    int sp2;
    int cp;
    FtnRtlEnum rtlRtn;
  
    sp2 = intr;
    switch (STYPEG(intr)) {
    case ST_GENERIC:
      sp2 = select_gsame(intr);
      if (sp2 == 0)
        return 0;
    case ST_PD:
    case ST_INTRIN:
      cp = PNMPTRG(sp2);
      if (cp == 0 || stb.n_base[cp] == '-')
        return 0;
      if (stb.n_base[cp] != '*' || stb.n_base[++cp] != '\0') {
        int dt;
  
        dt = INTTYPG(sp2);
  
        switch (INTASTG(sp2)) {
        case I_INDEX:
        case I_KINDEX:
        case I_NINDEX:
          if (XBIT(58, 0x40)) { /* input is f90 */
  #ifdef CREFP
            if (WINNT_CREF) {
              rtlRtn = WINNT_NOMIXEDSTRLEN ? RTE_indexx_cr_nma : RTE_indexx_cra;
            } else
  #endif
            {
              rtlRtn = RTE_indexxa;
            }
          } else if (XBIT(124, 0x10)) { /* -i8 for f77 */
            sp2 = intast_sym[I_KINDEX];
            dt = DT_INT8;
            rtlRtn = RTE_lenDsc;
          } else {
            rtlRtn = RTE_indexDsc;
          }
          break;
        case I_LEN:
        case I_ILEN:
        case I_KLEN:
          if (XBIT(58, 0x40)) { /* input is f90 */
  #ifdef CREFP
            if (WINNT_CREF) {
              rtlRtn = WINNT_NOMIXEDSTRLEN ? RTE_lenx_cr_nma : RTE_lenx_cra;
            } else
  #endif
            {
              rtlRtn = RTE_lenxa;
            }
          } else if (XBIT(124, 0x10)) { /* -i8 for f77 */
            sp2 = intast_sym[I_KLEN];
            dt = DT_INT8;
            rtlRtn = RTE_lenDsc;
            break;
          } else {
            rtlRtn = RTE_lenDsc;
          }
          break;
        }
        sp2 = sym_mkfunc(mkRteRtnNm(rtlRtn), dt);
        TYPDP(sp2, 1); /* force it to appear in an EXTERNAL stmt */
        if (WINNT_CALL)
          MSCALLP(sp2, 1);
  #ifdef CREFP
        if (WINNT_CREF) {
          CREFP(sp2, 1);
          CCSYMP(sp2, 1);
        }
  #endif
        break;
      }
      if (XBIT(124, 0x10)) { /* -i8 */
        switch (INTASTG(sp2)) {
        case I_IABS:
          sp2 = intast_sym[I_KIABS];
          break;
        case I_IDIM:
          sp2 = intast_sym[I_KIDIM];
          break;
        case I_MOD:
          sp2 = intast_sym[I_KMOD];
          break;
        case I_NINT:
          sp2 = intast_sym[I_KNINT];
          break;
        case I_IDNINT:
          sp2 = intast_sym[I_KIDNNT];
          break;
        case I_ISIGN:
          sp2 = intast_sym[I_KISIGN];
          break;
        /*
         * For the following, the integer specifics have been changed
         * to their corresponding integer*8 versions; however, the
         * function names are still refer to the integer forms.
         * Need to returning the sptr of the integer*8 intrinsic
         * so that the function name is correctly constructed.
         */
        case I_KIABS:
          sp2 = intast_sym[I_KIABS];
          break;
        case I_KIDIM:
          sp2 = intast_sym[I_KIDIM];
          break;
        case I_KIDNNT:
          sp2 = intast_sym[I_KIDNNT];
          break;
        case I_KISIGN:
          sp2 = intast_sym[I_KISIGN];
          break;
        default:
          break;
        }
      }
      if (XBIT(124, 0x8)) { /* -r8 */
        switch (INTASTG(sp2)) {
        case I_ALOG:
          sp2 = intast_sym[I_DLOG];
          break;
        case I_ALOG10:
          sp2 = intast_sym[I_DLOG10];
          break;
        case I_CABS:
          sp2 = intast_sym[I_CDABS];
          break;
        case I_AMOD:
          sp2 = intast_sym[I_DMOD];
          break;
        case I_ABS:
          sp2 = intast_sym[I_DABS];
          break;
        case I_SIGN:
          sp2 = intast_sym[I_DSIGN];
          break;
        case I_DIM:
          sp2 = intast_sym[I_DDIM];
          break;
        case I_SQRT:
          sp2 = intast_sym[I_DSQRT];
          break;
        case I_EXP:
          sp2 = intast_sym[I_DEXP];
          break;
        case I_SIN:
          sp2 = intast_sym[I_DSIN];
          break;
        case I_COS:
          sp2 = intast_sym[I_DCOS];
          break;
        case I_TAN:
          sp2 = intast_sym[I_DTAN];
          break;
        case I_AINT:
          sp2 = intast_sym[I_DINT];
          break;
        case I_ANINT:
          sp2 = intast_sym[I_DNINT];
          break;
        case I_ASIN:
          sp2 = intast_sym[I_DASIN];
          break;
        case I_ACOS:
          sp2 = intast_sym[I_DACOS];
          break;
        case I_ATAN:
          sp2 = intast_sym[I_DATAN];
          break;
        case I_SINH:
          sp2 = intast_sym[I_DSINH];
          break;
        case I_COSH:
          sp2 = intast_sym[I_DCOSH];
          break;
        case I_TANH:
          sp2 = intast_sym[I_DTANH];
          break;
        case I_ATAN2:
          sp2 = intast_sym[I_DATAN2];
          break;
        case I_SIND:
          sp2 = intast_sym[I_DSIND];
          break;
        case I_COSD:
          sp2 = intast_sym[I_DCOSD];
          break;
        case I_TAND:
          sp2 = intast_sym[I_DTAND];
          break;
        case I_AIMAG:
          sp2 = intast_sym[I_DIMAG];
          break;
        case I_ASIND:
          sp2 = intast_sym[I_DASIND];
          break;
        case I_ACOSD:
          sp2 = intast_sym[I_DACOSD];
          break;
        case I_ATAND:
          sp2 = intast_sym[I_DATAND];
          break;
        case I_ATAN2D:
          sp2 = intast_sym[I_DATAN2D];
          break;
        case I_CSQRT:
          sp2 = intast_sym[I_CDSQRT];
          break;
        case I_CLOG:
          sp2 = intast_sym[I_CDLOG];
          break;
        case I_CEXP:
          sp2 = intast_sym[I_CDEXP];
          break;
        case I_CSIN:
          sp2 = intast_sym[I_CDSIN];
          break;
        case I_CCOS:
          sp2 = intast_sym[I_CDCOS];
          break;
        case I_CONJG:
          sp2 = intast_sym[I_DCONJG];
          break;
        /*
         * For the following, the real/complex specifics have been changed
         * to their corresponding double real/complex versions; however, the
         * function names are still refer to the real/complex forms.
         * Need to returning the sptr of the 'double real/complex' intrinsic
         * so that the function name is correctly constructed.
         */
        case I_DLOG:
          sp2 = intast_sym[I_DLOG];
          break;
        case I_DLOG10:
          sp2 = intast_sym[I_DLOG10];
          break;
        case I_CDABS:
          sp2 = intast_sym[I_CDABS];
          break;
        case I_DMOD:
          sp2 = intast_sym[I_DMOD];
          break;
        case I_CDSQRT:
          sp2 = intast_sym[I_CDSQRT];
          break;
        case I_CDLOG:
          sp2 = intast_sym[I_CDLOG];
          break;
        case I_CDEXP:
          sp2 = intast_sym[I_CDEXP];
          break;
        case I_CDSIN:
          sp2 = intast_sym[I_CDSIN];
          break;
        case I_CDCOS:
          sp2 = intast_sym[I_CDCOS];
          break;
        }
      }
      break;
    default:;
    }
    if (SYMNAME(sp2)[0] != '.')
      TYPDP(sp2, 1); /* force it to appear in an INTRINSIC statement */
    return sp2;
  }
  
  /** \brief Performing checking on an argument to determine if it needs to be
   *         "protected".
   *  \param stkptr a stack entry representing a subprogram argument
   *  \param dtype  used to pass out data type of argument
   *  \return       sptr for alternate return label
   *
   *  When an argument needs to be protected, its value may be have to be stored
   *  in a temp and then the temp's address becomes the actual argument.  This
   *  occurs when a parenthesized expression is an actual argument.  NOTE that
   *  the logic in chkarg relies on an argument being `<expression>`; a flag
   *  (SST_PARENG/P) in the semantic stack is used and is only defined for
   *  `<expression>`; the flag is cleared when `<expression> ::= ...` occurs and
   *  is set when `<primary> ::= ( <expression> )` occurs.
   */
  int
  chkarg(SST *stkptr, int *dtype)
  {
    int argtyp;
    int sptr, sp2;
  
    if (SST_PARENG(stkptr)) {
      switch (SST_IDG(stkptr)) {
      case S_CONST:
        argtyp = SST_DTYPEG(stkptr);
        if (argtyp == DT_HOLL || argtyp == DT_WORD || argtyp == DT_DWORD)
          argtyp = DT_INT;
        break;
  
      case S_ACONST:
        /* just let mkarg() deal with it */
        goto call_mkarg;
  
      case S_IDENT:
        /* resolve it */
        sptr = SST_SYMG(stkptr);
        switch (STYPEG(sptr)) {
        case ST_ENTRY:
          if (gbl.rutype != RU_FUNC)
            goto call_mkarg;
          sptr = ref_entry(sptr);
          goto store_var;
        case ST_UNKNOWN:
        case ST_IDENT:
          STYPEP(sptr, ST_VAR);
        /* fall through to ... */
        case ST_VAR:
        store_var:
          argtyp = DTYPEG(sptr);
          if (!DT_ISSCALAR(argtyp)) {
            /* could issue error message */
            goto call_mkarg;
          }
          if (argtyp == DT_ASSCHAR || argtyp == DT_ASSNCHAR) {
            /* could issue error message */
            goto call_mkarg;
          }
          break;
        case ST_USERGENERIC:
          if (GSAMEG(sptr)) {
            sptr = GSAMEG(sptr);
            goto call_mkarg;
          }
          /* make a scalar symbol here */
          sptr = newsym(sptr);
          STYPEP(sptr, ST_VAR);
          sem_set_storage_class(sptr);
          goto store_var;
        case ST_GENERIC:
          /* Generic used as an actual argument.  Use specific of same
           * name. If none, then assume its a variable unless generic is
           * frozen.
           */
          sp2 = select_gsame(sptr); /* intrinsic of same name */
          if (sp2 == 0 || !EXPSTG(sptr)) {
            sptr = newsym(sptr);
            STYPEP(sptr, ST_VAR);
            sem_set_storage_class(sptr);
            goto store_var;
          }
          goto common_intrinsic;
        /* fall through to ... */
        case ST_INTRIN:
        case ST_PD:
          sp2 = sptr;
          if (!EXPSTG(sptr)) {
            sptr = newsym(sptr);
            STYPEP(sptr, ST_VAR);
            sem_set_storage_class(sptr);
            goto store_var;
          }
        common_intrinsic:
        /* fall thorugh to ... */
        case ST_PROC:
        case ST_STFUNC:
        case ST_STRUCT:
        case ST_ARRAY:
          goto call_mkarg;
  
        default:
          goto call_mkarg;
        }
        break;
  
      case S_LVALUE:
        argtyp = SST_DTYPEG(stkptr);
        if (!DT_ISSCALAR(argtyp)) {
          /* perhaps, we could issue an error message */
          goto call_mkarg;
        }
        if (DTY(argtyp) == TY_CHAR || DTY(argtyp) == TY_NCHAR) {
          /* we can't do much about char lvalues; if a substring, we
           * don't pass up the new length.  This will lead to an incorrect
           * length for the temporary.  Also, the same is true if it's a
           * subscripted passed length char array.
           * EVENTUALLY, will probably allocate a temp, and use the
           * temp's address.
           */
          goto call_mkarg;
        }
        break;
      default:
        goto call_mkarg;
      }
      /*
       *  must parenthesize the argument.
       */
      *dtype = argtyp;
      (void)mkexpr(stkptr);
      /* always generate parens */
      SST_ASTP(stkptr, mk_paren((int)SST_ASTG(stkptr), argtyp));
      return 1;
    }
    if (SST_IDG(stkptr) == S_EXPR) {
      /* need to protect a scalar expression whose ast is a reference;
       * an example is if the expression was 'id + 0', which is reduced
       * to just 'id'
       */
      int ast;
      ast = SST_ASTG(stkptr);
      if (DT_ISSCALAR(A_DTYPEG(ast)) && A_ISLVAL(A_TYPEG(ast)) &&
          (A_TYPEG(ast) != A_ID || !POINTERG(A_SPTRG(ast)))) {
        ast = mk_paren(ast, (int)A_DTYPEG(ast));
        SST_ASTP(stkptr, ast);
        ;
        return 1;
      }
    }
  
  call_mkarg:
    return (mkarg(stkptr, dtype));
  }
  
  /** \brief Allocate a temporary, assign it the value, and return the temp's
   *         base.
   */
  int
  tempify(SST *stkptr)
  {
    int argtyp;
    SST tmpsst;
    int tmpsym;
  
    argtyp = SST_DTYPEG(stkptr);
    tmpsym = get_temp(argtyp);
    mkident(&tmpsst);
    SST_SYMP(&tmpsst, tmpsym);
    SST_LSYMP(&tmpsst, tmpsym);
    SST_DTYPEP(&tmpsst, argtyp);
    SST_SHAPEP(&tmpsst, 0);
    (void)add_stmt(assign(&tmpsst, stkptr));
    mkexpr(&tmpsst);
    *stkptr = tmpsst;
    return 1;
  }
  
  /*---------------------------------------------------------------------*/
  
  /* A function entry is referenced where the intent is to reference the
   * "local" variable (a ccsym created for the result).  Since entries may
   * have different types, a "local" variable which is compatible for the
   * data type is found; if not, one is created.
   */
  int
  ref_entry(int ent)
  {
    int fval;
    int dtype;
    int sptr;
  
    fval = FVALG(ent);
    if (fval) {
      if (DCLDG(ent) && !DCLDG(fval))
        DTYPEP(fval, DTYPEG(ent)); /* watch out for type after function/entry */
    } else {
      dtype = DTYPEG(ent);
      if (DTY(dtype) == TY_ARRAY) {
        fval = get_fval_array(ent);
      } else {
        fval = insert_sym(ent);
        pop_sym(fval);
        if (POINTERG(ent)) {
          HCCSYMP(fval, 1);
        }
        SCP(fval, SC_DUMMY); /* so optimizer doesn't delete */
        DCLDP(fval, 1);      /* so 'undeclared' messages don't occur */
        if (dtype == DT_NONE) {
          /* an error message has been issued; just set dtype */
          dtype = DT_INT;
        }
        DTYPEP(fval, dtype);
        {
          STYPEP(fval, ST_VAR);
        }
        if (POINTERG(ent)) {
          POINTERP(fval, 1);
          F90POINTERP(fval, F90POINTERG(ent));
          if (!F90POINTERG(fval)) {
            get_static_descriptor(fval);
            get_all_descriptors(fval);
          }
          INTENTP(fval, INTENT_OUT);
        }
        ADJLENP(fval, ADJLENG(ent));
        ASSUMLENP(fval, ASSUMLENG(ent));
      }
      FVALP(ent, fval);
      if (STYPEG(ent) != ST_ENTRY) {
        /* prevent astout from processing */
        IGNOREP(fval, 1);
      }
    }
    if (sem.parallel || sem.task || sem.target || sem.teams
        || sem.orph
    ) {
      /* if in a parallel region, need to first determine if a private copy
       * was declared for the entry's variable in the parallel directive.
       * Then need to check the current scope for a default clause.
       */
      char *name;
      int new;
      if (ent == gbl.currsub) {
        name = SYMNAME(fval);
        new = getsymbol(name);
      } else {
        new = fval;
      }
      new = sem_check_scope(new, ent);
      if (new != ent)
        fval = new;
    }
    return fval;
  }
  
  /*---------------------------------------------------------------------*/
  
  /** \brief Given a generic intrinsic, select the corresponding specific of the
   *         same name.
   *
   *  Normally, the selection is performed by just accessing the GSAME field of
   *  the generic.  When an option to override the meaning of INTEGER (-noi4) is
   *  selected, some analysis must be done to select the specific intrinsic
   *  whose argument type matches the type implied by the option.
   */
  int
  select_gsame(int gnr)
  {
    int spec;
  
    if ((spec = GSAMEG(gnr)) == 0)
      return 0;
    if (ARGTYPG(spec) == DT_INT) {
      if (!flg.i4)
        spec = GSINTG(gnr);
      else if (XBIT(124, 0x10))
        spec = GINT8G(gnr);
    } else if (XBIT(124, 0x8)) {
      if (ARGTYPG(spec) == DT_REAL)
        spec = GDBLEG(gnr);
      else if (ARGTYPG(spec) == DT_CMPLX)
        spec = GDCMPLXG(gnr);
    }
    return spec;
  }
  
  /*---------------------------------------------------------------------*/
  
  static int
  get_fval_array(int ent)
  {
    int sptr;
    int dtype;
    ADSC *ad;
  
    if (FVALG(ent)) {
      sptr = insert_sym(FVALG(ent));
    } else {
      sptr = insert_sym(ent);
    }
    pop_sym(sptr);
    dtype = DTYPEG(ent);
    HCCSYMP(sptr, 1);
    DCLDP(sptr, 1);
    SCOPEP(sptr, stb.curr_scope);
    DTYPEP(sptr, dtype);
    ADJLENP(sptr, ADJLENG(ent));
    ASSUMLENP(sptr, ASSUMLENG(ent));
  
    SCP(sptr, SC_DUMMY);
    INTENTP(sptr, INTENT_OUT);
    if (!POINTERG(ent)) {
      ad = AD_DPTR(dtype);
      if (AD_ADJARR(ad)) {
        ADJARRP(sptr, 1);
        ADJARRP(ent, 1);
      } else if (AD_DEFER(ad)) {
        ASSUMSHPP(sptr, 1);
        if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
          SDSCS1P(sptr, 1);
        ASSUMSHPP(ent, 1);
      } else if (AD_ASSUMSZ(ad)) {
        ASUMSZP(sptr, 1);
        ASUMSZP(ent, 1);
        SEQP(sptr, 1);
      }
    }
  
    else {
      STYPEP(sptr, ST_ARRAY);
      if (POINTERG(ent)) {
        POINTERP(sptr, 1);
        F90POINTERP(sptr, F90POINTERG(ent));
        if (!F90POINTERG(sptr)) {
          get_static_descriptor(sptr);
          get_all_descriptors(sptr);
        }
      }
    }
  
    return sptr;
  }
  
  /*---------------------------------------------------------------------*/
  
  /** \brief Make a keyword string for a ST_PROC. */
  char *
  make_kwd_str(int ext)
  {
    char *kwd_str;
    kwd_str = make_keyword_str(PARAMCTG(ext), DPDSCG(ext));
    return kwd_str;
  }
  
  /** \brief Make a keyword string from the DPDSC auxiliary structure. */
  char *
  make_keyword_str(int paramct, int dpdsc)
  {
    int cnt;
    int arg; /* argument sptr */
    int i;
    char *name;
    int optional;
    int len;
    int size;
    int avl;
    char *kwd_str;
    int td;
  
    avl = 0;
    size = 100;
    NEW(kwd_str, char, size);
    for (cnt = paramct; cnt > 0; dpdsc++, cnt--) {
      if ((arg = *(aux.dpdsc_base + dpdsc))) {
        optional = OPTARGG(arg);
        name = SYMNAME(arg);
        len = strlen(name);
        td = CLASSG(arg) && CCSYMG(arg);
        if (HCCSYMG(arg) && DESCARRAYG(arg) && STYPEG(arg) == ST_DESCRIPTOR)
          td = 1;
      } else {
        /* alternate returns */
        optional = 0;
        name = "&";
        len = 1;
        td = 0;
      }
      i = avl;
      avl += (optional + len + 2); /* len chars in name, 1 for ' ', 1 for null */
      NEED(avl, kwd_str, char, size, size + 100);
      if (optional)
        kwd_str[i++] = '*';
      else if (td)
        kwd_str[i++] = '!';
      strcpy(kwd_str + i, name);
      if (cnt > 1)
        kwd_str[i + len] = ' ';
      avl--;
    }
  
    return kwd_str;
  }
  
  /*---------------------------------------------------------------------*/
  
  /** \defgroup args  Positional and keyword arguments
   *
   *  Support for extracting positional or keyword arguments for an intrinsic.
   *  For each intrinsic, the symbol table utility has created a string which
   *  defines the arguments and their positions in the argument list and
   *  keywords.
   *
   *  Optional arguments are indicating by prefixing their keywords with '*'.
   *
   * @{
   */
  
  static LOGICAL user_subr = FALSE; /**< TRUE if invoking a user subprogram */
  static int nz_digit_str(char *);
  
  /** \brief Extract the arguments from the semantic list into `sem.argpos[]` in
   *         positional order.
   *  \param list    list of arguments
   *  \param cnt     maximum number of arguments allowed for intrinsic
   *  \param kwdarg  string defining position and keywords of arguments
   */
  LOGICAL
  get_kwd_args(ITEM *list, int cnt, char *kwdarg)
  {
    return get_keyword_args(list, cnt, kwdarg, 0, 0);
  }
  
  /** \brief Similar to get_kwd_args but can also specify a pass-object dummy
   *         argument.
   *  \param list     list of arguments
   *  \param cnt      maximum number of arguments allowed for intrinsic
   *  \param kwdarg   string defining position and keywords of arguments
   *  \param pod      if set indicates there is a passed-object dummy argument
   *  \param pass_pos index of the passed-object dummy argument when pod is set
   */
  static LOGICAL
  get_keyword_args(ITEM *list, int cnt, char *kwdarg, int pod, int pass_pos)
  {
    SST *stkp;
    int pos;
    int i;
    char *kwd, *np;
    int kwd_len;
    char *actual_kwd; /* name of keyword used with the actual arg */
    int actual_kwd_len;
    LOGICAL kwd_present;
    int varpos;
    int varbase;
    int pass_pos2 = 0, pod2 = 0; /* pass object info for type bound procedure */
  
    /* convention for the keyword 'variable' arguments ---
     * the keyword specifier is of the form
     *     #<pos>#<base>#<kwd>
     * where,
     *      <pos>  = digit indicating the zero-relative positional index where
     *               the variable arguments begin in the argument list.
     *      <base> = digit indicating value to be subtracted from the digit
     *               string suffix of the keyword.
     *      <kwd>  = name of the keyword which varies (i.e., the prefix).
     */
  
    kwd_present = FALSE;
    /* extra arguments may be stored in argpos[]; allow for 'cnt' extra args */
    sem.argpos = (argpos_t *)getitem(0, sizeof(argpos_t) * cnt * 2);
  
    for (i = 0; i < cnt * 2; i++) {
      ARG_STK(i) = NULL;
      ARG_AST(i) = 0;
    }
  
    if (!pod && !pass_pos) {
      pod2 = pass_object_dummy;
      pass_pos2 = pass_position;
    }
    pass_object_dummy = pass_position = 0;
  
    for (pos = 0; list != ITEM_END; pos++) {
      if (pod && pos == pass_pos) {
        /* examining the position of the passed-object dummy argument;
         * go to the next position, but do not move the list.
         */
        continue;
      }
      stkp = list->t.stkp;
      if (pod2 && pos == pass_pos2) {
        /* pass object for type bound procedure, so set the argument
         * and continue. Otherwise, we may get an error since the
         * pass argument does not have a keyword.
         */
        ARG_STK(pos) = stkp;
        ARG_AST(pos) = SST_ASTG(stkp);
        list = list->next;
        continue;
      }
      if (SST_IDG(stkp) == S_KEYWORD) {
        kwd_present = TRUE;
        actual_kwd = scn.id.name + SST_CVALG(stkp);
        actual_kwd_len = strlen(actual_kwd);
        kwd = kwdarg;
        for (i = 0; TRUE; i++) {
          varbase = 0; /* variable part not seen */
          if (*kwd == '*')
            kwd++;
          else if (*kwd == '#') {
            /*  #<pos>#<base>#<kwd>  */
            kwd++;
            varpos = *kwd - '0'; /* numerical value of <pos> */
            kwd += 2;
            varbase = *kwd; /* digit (char) to be subtracted */
            kwd += 2;
          } else if (strncmp(kwd, "_V_", 3) == 0 && kwd[3] != ' ' &&
                     kwd[3] != '\0') {
            /* Use the original argument name for VALUE dummy arguments
             * that have been renamed in semant.c to distinguish them from
             * their local copies.
             */
            kwd += 3;
          }
          kwd_len = 0;
          for (np = kwd; TRUE; np++, kwd_len++)
            if (*np == ' ' || *np == '\0')
              break;
          if (varbase && (i = nz_digit_str(actual_kwd + kwd_len)) &&
              strncmp(kwd, actual_kwd, kwd_len) == 0) {
            /* compute actual position as:
             *     <digit suffix> - <base> + <pos>
             */
            i = i - (varbase - '0') + varpos;
            if (i >= cnt)
              goto ill_keyword;
            break;
          }
          if (kwd_len == actual_kwd_len &&
              strncmp(kwd, actual_kwd, actual_kwd_len) == 0)
            break;
          if (*np == '\0')
            goto ill_keyword;
          kwd = np + 1; /* skip over blank */
        }
        if (ARG_STK(i))
          goto ill_keyword;
        stkp = SST_E3G(stkp);
        ARG_STK(i) = stkp;
        ARG_AST(i) = SST_ASTG(stkp);
      } else {
        if (kwd_present) {
          error(155, 3, gbl.lineno,
                "Positional arguments must not follow keyword arguments", CNULL);
          return TRUE;
        }
        if (ARG_STK(pos)) {
          char print[22];
          kwd = kwdarg;
          for (i = 0; TRUE; i++) {
            if (*kwd == '*' || *kwd == ' ')
              kwd++;
            if (*kwd == '#') {
              error(79, 3, gbl.lineno, kwd + 5, "...");
              return TRUE;
            }
            if (*kwd == '\0') {
              interr("get_keyword_args, kwdnfd", pos, 3);
              return TRUE;
            }
            kwd_len = 0;
            for (np = kwd; TRUE; np++) {
              if (*np == ' ' || *np == '\0')
                break;
              kwd_len++;
            }
            if (i == pos)
              break;
            kwd = np;
          }
          if (kwd_len > 21)
            kwd_len = 21;
          strncpy(print, kwd, kwd_len);
          print[kwd_len] = '\0';
          error(79, 3, gbl.lineno, print, CNULL);
          return TRUE;
        }
        ARG_STK(pos) = stkp;
        ARG_AST(pos) = SST_ASTG(stkp);
      }
      list = list->next;
    }
  
    /* determine if required argument is not present */
  
    kwd = kwdarg;
    for (pos = 0; pos < cnt; pos++, kwd = np) {
      if (*kwd == ' ')
        kwd++;
      if (*kwd == '#')
        break;
      kwd_len = 0;
      for (np = kwd; TRUE; np++) {
        if (*np == ' ' || *np == '\0')
          break;
        kwd_len++;
      }
      if (*kwd == '!') {
        if (ARG_STK(pos) == NULL)
          break; /* continue; */
        else
          error(155, 3, gbl.lineno, "Too many arguments specified for call",
                CNULL);
      }
      if (*kwd == '*')
        continue;
      if ((pod && pos == pass_pos) || (pod2 && pos == pass_pos2))
        /* don't check the position of the passed-object dummy argument */
        ;
      else if (ARG_STK(pos) == NULL) {
        char print[22];
        if (kwd_len > 21)
          kwd_len = 21;
        strncpy(print, kwd, kwd_len);
        print[kwd_len] = '\0';
        error(186, kwd_present || user_subr ? 3 : 1, gbl.lineno, print, CNULL);
        return TRUE;
      }
    }
  
    return FALSE;
  
  ill_keyword:
    error(79, 3, gbl.lineno, actual_kwd, CNULL);
    return TRUE;
  }
  
  static int
  nz_digit_str(char *s)
  {
    int val;
  
    val = 0; /* not a nonzero digit string */
    for (; *s != '\0'; ++s)
      switch (*s) {
      case '0':
      case '1':
      case '2':
      case '3':
      case '4':
      case '5':
      case '6':
      case '7':
      case '8':
      case '9':
        val = val * 10 + (*s - '0');
        break;
      default:
        return 0;
      }
  
    return val;
  }
  
  /** \brief  Call get_kwd_args and evaluate each argument.
   *  \param list    list of arguments
   *  \param cnt     maximum number of arguments allowed for intrinsic
   *  \param kwdarg  string defining position and keywords of arguments
   */
  LOGICAL
  evl_kwd_args(ITEM *list, int cnt, char *kwdarg)
  {
    SST *stkp;
    int pos;
    int i, sptr;
    char *kwd, *np;
    int kwd_len;
    char *actual_kwd; /* name of keyword used with the actual arg */
  
    if (get_kwd_args(list, cnt, kwdarg))
      return TRUE;
  
    for (i = 0; i < cnt; i++) {
      if ((stkp = ARG_STK(i))) {
        if (SST_IDG(stkp) == S_IDENT && (sptr = SST_SYMG(stkp)) &&
            STYPEG(sptr) == ST_PROC) {
          /* passing a procedure as an argument */
          SST_DTYPEP(stkp, DTYPEG(sptr));
          SST_LSYMP(stkp, sptr);
          SST_ASTP(stkp, mk_id(sptr));
        } else if (SST_IDG(stkp) == S_SCONST) {
          (void)mkarg(stkp, &SST_DTYPEG(stkp));
        } else {
          (void)mkexpr(stkp);
        }
        ARG_AST(i) = SST_ASTG(stkp);
      }
    }
  
    return FALSE;
  }
  
  /**
   * \param list  list of arguments
   * \param cnt   maximum number of arguments allowed for intrinsic
   *
   * Arguments are: array, base, indx1, ..., indxn, mask<br>
   * where n = rank of base, mask is optional
   *
   * Don't use get_kwd_args() since it is not designed to handle an optional
   * argument after a variable number of arguments.  Note that cnt is the
   * actual number of arguments; get_kwd_args() & evl_kwd_args() are passed the
   * the maximum number of arguments.
   *
   * If the arguments are correct, the output (ARG_STK) will be in the order:
   *
   *     0      - array
   *     1      - base
   *     2      - mask
   *     3      - indx1
   *     ...
   *     3+n-1  -  indxn
   */
  LOGICAL
  sum_scatter_args(ITEM *list, int cnt)
  {
    SST *stkp;
    int pos;
    int i;
    char *actual_kwd; /* name of keyword used with the actual arg */
    int actual_kwd_len;
    LOGICAL kwd_present;
    SST *mask;
    int rank;
  
    kwd_present = FALSE;
    sem.argpos = (argpos_t *)getitem(0, sizeof(argpos_t) * cnt);
  
    for (i = 0; i < cnt; i++) {
      ARG_STK(i) = NULL;
      ARG_AST(i) = 0;
    }
    /*
     * first, place the arguments in the positional order per the spec
     * except that 'mask=arg' is a special case.  The positional order is
     *     array, base, indx1, ..., indxn, mask
     */
    mask = NULL; /* set only if keyword form of mask is seen */
    for (pos = 0; list != ITEM_END; list = list->next, pos++) {
      stkp = list->t.stkp;
      if (SST_IDG(stkp) == S_KEYWORD) {
        kwd_present = TRUE;
        actual_kwd = scn.id.name + SST_CVALG(stkp);
        actual_kwd_len = strlen(actual_kwd);
        if (strcmp("array", actual_kwd) == 0)
          i = 0;
        else if (strcmp("base", actual_kwd) == 0)
          i = 1;
        else if (strcmp("mask", actual_kwd) == 0) {
          mask = SST_E3G(stkp);
          continue;
        } else if (strncmp("indx", actual_kwd, 4) == 0) {
          if ((i = nz_digit_str(actual_kwd + 4))) {
            /* compute actual position as:
             *     <digit suffix> - <base> + <pos>
             */
            i = i + 1; /* positions 2, ..., 2+n-1 */
            if (i >= cnt)
              goto ill_keyword;
          }
        }
        if (ARG_STK(i))
          goto ill_keyword;
        stkp = SST_E3G(stkp);
        ARG_STK(i) = stkp;
        ARG_AST(i) = SST_ASTG(stkp);
      } else {
        if (ARG_STK(pos)) {
          char *str;
          if (pos == 0)
            str = "array";
          else if (pos == 1)
            str = "base";
          else
            str = "indx or mask";
          error(79, 3, gbl.lineno, str, CNULL);
          return TRUE;
        }
        ARG_STK(pos) = stkp;
        ARG_AST(pos) = SST_ASTG(stkp);
      }
    }
  
    /* determine if required argument is not present */
  
    if (ARG_STK(0) == NULL) {
      error(186, kwd_present ? 3 : 1, gbl.lineno, "array", CNULL);
      return TRUE;
    }
    if (ARG_STK(1) == NULL) {
      error(186, kwd_present ? 3 : 1, gbl.lineno, "base", CNULL);
      return TRUE;
    }
  
    stkp = ARG_STK(1);
    mkexpr(stkp);
    rank = rank_of_ast(SST_ASTG(stkp));
  
    if (mask) {
      if (ARG_STK(cnt - 1)) {
        error(79, 3, gbl.lineno, "mask", CNULL);
        return TRUE;
      }
      if (rank != cnt - 3) {
        error(186, kwd_present ? 3 : 1, gbl.lineno, "indx...", CNULL);
        return TRUE;
      }
    } else if (rank < cnt - 2) {
      mask = ARG_STK(cnt - 1);
      if (rank != cnt - 3) {
        error(186, kwd_present ? 3 : 1, gbl.lineno, "indx...", CNULL);
        return TRUE;
      }
    } else if (rank != cnt - 2) {
      error(186, kwd_present ? 3 : 1, gbl.lineno, "indx...", CNULL);
      return TRUE;
    }
  
    /* reposition the indx arguments so that they appear at the end */
  
    for (i = 2 + rank; i > 2; i--) {
      ARG_STK(i) = ARG_STK(i - 1);
      ARG_AST(i) = ARG_AST(i - 1);
    }
  
    ARG_STK(2) = mask;
    if (mask)
      ARG_AST(2) = SST_ASTG(mask);
    else
      ARG_AST(2) = 0;
  
    /* now, evaluate the arguments */
  
    for (i = 2 + rank; i >= 0; i--) {
      if ((stkp = ARG_STK(i))) {
        (void)mkexpr(stkp);
        ARG_AST(i) = SST_ASTG(stkp);
      }
    }
  
    return FALSE;
  
  ill_keyword:
    error(79, 3, gbl.lineno, actual_kwd, CNULL);
    return TRUE;
  }
  
  /**@}*/
  
  /*---------------------------------------------------------------------*/
  
  /** \brief For arguments that are subprograms, check that their argument lists
   *         are compatible.
   */
  static LOGICAL
  compat_arg_lists(int formal, int actual)
  {
    int paramct;
    int fdscptr, adscptr;
    int i;
  
    /* TODO: Not checking certain cases for now. */
    if (STYPEG(actual) == ST_INTRIN || STYPEG(actual) == ST_GENERIC)
      return TRUE;
  
    if (STYPEG(formal) == ST_PROC && STYPEG(actual) == ST_PROC && FVALG(formal) &&
        FVALG(actual) &&
        !compatible_characteristics(formal, actual,
                                    (IGNORE_ARG_NAMES | RELAX_STYPE_CHK |
                                     RELAX_POINTER_CHK | RELAX_PURE_CHK_2))) {
      return FALSE;
    }
  
    fdscptr = DPDSCG(formal);
    adscptr = DPDSCG(actual);
    if (fdscptr == 0 || adscptr == 0)
      return TRUE; /* No dummy parameter descriptor; can't check. */
    paramct = PARAMCTG(formal);
    if (PARAMCTG(actual) != paramct)
      return FALSE;
    for (i = 0; i < paramct; i++, fdscptr++, adscptr++) {
      int farg, aarg;
  
      farg = *(aux.dpdsc_base + fdscptr);
      aarg = *(aux.dpdsc_base + adscptr);
      if (STYPEG(farg) == ST_PROC) {
        if (STYPEG(aarg) != ST_PROC && STYPEG(aarg) != ST_ENTRY &&
            STYPEG(aarg) != ST_INTRIN && STYPEG(aarg) != ST_GENERIC)
          return FALSE;
        if (!compat_arg_lists(farg, aarg))
          return FALSE;
        /* If not functions, don't try to check return type. */
        if (!DCLDG(farg) && !FUNCG(farg) && !DCLDG(aarg) && !FUNCG(aarg))
          continue;
      }
      if (!cmpat_dtype_with_size(DTYPEG(farg), DTYPEG(aarg)))
        return FALSE;
    }
    return TRUE;
  }
  
  /** \brief Check arguments passed to a user subprogram which has an interface
   *         block. Its keyword string is available and is located by kwd_str.
   */
  LOGICAL
  check_arguments(int ext, int count, ITEM *list, char *kwd_str)
  {
    int dpdsc;
    int paramct;
    paramct = PARAMCTG(ext);
    dpdsc = DPDSCG(ext);
    return chk_arguments(ext, count, list, kwd_str, paramct, dpdsc, 0, NULL);
  }
  /** \brief Check arguments passed to a user subprogram which has an interface
   *         block. Its keyword string is available and is located by kwd_str.
   *
   *  NOTE: if callee is non-zero, the call is via some procedure pointer, and
   *  callee is the ast of pointer and ext will be the sptr of the pointer
   *  variable or member. Otherwise, callee is 0 and ext is the sptr of the
   *  subroutine/function.
   */
  LOGICAL
  chk_arguments(int ext, int count, ITEM *list, char *kwd_str, int paramct,
                int dpdsc, int callee, int *p_pass_pos)
  {
    int i;
  
    if (p_pass_pos)
      *p_pass_pos = -1; /* < 0 = > NO passed object */
    if (count > paramct) {
      error(187, 3, gbl.lineno, SYMNAME(ext), CNULL);
      return TRUE;
    }
    if (callee == 0 || A_TYPEG(callee) != A_MEM || !PASSG(ext)) {
      user_subr = TRUE;
      if (get_kwd_args(list, paramct, kwd_str)) {
        user_subr = FALSE;
        return TRUE;
      }
    } else {
      /* component procedure pointer with a passed-object dummy argument */
      int pass_pos;
      int pdum;
  
      pdum = PASSG(ext);
      if (!tk_match_arg(DTYPEG(pdum), A_DTYPEG(A_PARENTG(callee)), TRUE)) {
        error(155, 3, gbl.lineno,
              "Type mismatch for the passed-object dummy argument",
              SYMNAME(pdum));
        return TRUE;
      }
      for (i = 0; i < paramct; i++) {
        if (pdum == aux.dpdsc_base[dpdsc + i]) {
          pass_pos = i;
          break;
        }
      }
      if (pass_pos >= paramct) {
        /* This should not happen since semant has already searched for
         * the passed-object dummy.  Just call it a type mismatch error!.
         */
        error(155, 3, gbl.lineno,
              "Type mismatch for the passed-object dummy argument",
              SYMNAME(pdum));
        return TRUE;
      }
      user_subr = TRUE;
      if (get_keyword_args(list, paramct, kwd_str, 1, pass_pos)) {
        user_subr = FALSE;
        return TRUE;
      }
      *p_pass_pos = pass_pos;
    }
    user_subr = FALSE;
  
    for (i = 0; i < paramct; i++, dpdsc++) {
      SST *sp;
      int dum;
      int actual;
      int arg;
      char buf[32];
      int sptr;
      int doif;
  
      sprintf(buf, "%d", i + 1); /* prepare for error messages */
      if ((sp = ARG_STK(i))) {
        (void)chkarg(sp, &dum);
        XFR_ARGAST(i);
      }
      actual = ARG_AST(i);
      arg = aux.dpdsc_base[dpdsc];
  
      if (arg) {
        if (!actual) {
          /* optional argument not present; store in the ast entry
           * the number of ast arguments which must be filled in with
           * the 'null' pointer (astb.ptr0).
           */
          ARG_AST(i) = 1;
        } else {
          int ddum, dact, elddum, eldact;
          int shape;
          LOGICAL dum_is_proc;
  
          if (STYPEG(arg) == ST_ENTRY || STYPEG(arg) == ST_PROC) {
            dum_is_proc = TRUE;
            if (FVALG(arg))
              ddum = DTYPEG(FVALG(arg));
            else
              ddum = DTYPEG(arg);
          } else {
            dum_is_proc = FALSE;
            ddum = DTYPEG(arg);
          }
          elddum = DDTG(ddum);
          dact = A_DTYPEG(actual);
          eldact = DDTG(dact);
          shape = A_SHAPEG(actual);
          if (DTY(eldact) == TY_PTR && DTY(elddum) == TY_PROC) {
            eldact = DTY(eldact + 1);
            eldact = DDTG(eldact);
          } else if (DTY(eldact) == TY_PROC && DTY(elddum) == TY_PTR) {
            elddum = DTY(elddum + 1);
            elddum = DDTG(elddum);
          } else if (dum_is_proc && DTY(eldact) == TY_PTR) {
            eldact = DTY(eldact + 1);
            if (DTY(eldact) == TY_PROC && DTY(eldact + 5)) {
              int ss;
              ss = DTY(eldact + 5);
              if (FVALG(ss))
                eldact = DTYPEG(FVALG(ss));
              else
                eldact = DTYPEG(ss);
            }
            eldact = DDTG(eldact);
          }
          if (STYPEG(arg) == ST_ARRAY) {
            if (shape == 0) {
              int tmp;
              tmp = actual;
              if (A_TYPEG(tmp) == A_SUBSTR)
                tmp = A_LOPG(tmp);
              if (ASSUMSHPG(arg)) {
                /* if the dummy is assumed-shape,
                 * the user is trying to pass a scalar, constant
                 * or array element into an assumed-shape array
                 *  error */
                error(189, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
              if (A_TYPEG(tmp) != A_SUBSCR) {
                /* if the dummy is not assumed-shape
                 * (explicit-shape or assumed-size), the user is
                 * trying to pass a scalar or constant
                 * to an array; give warning unless -Mstandard */
                if (ignore_tkr(arg, IGNORE_R))
                  continue;
                if (DTY(eldact) == TY_CHAR || DTY(eldact) == TY_NCHAR)
                  /*
                   * It's legal for a character scalar to be
                   * passed to a character array. This takes
                   * care of a scalar to an array but sill
                   * need to check types, POINTER, etc.
                   */
                  ;
                else {
                  if (flg.standard) {
                    error(189, 3, gbl.lineno, buf, SYMNAME(ext));
                    continue;
                  }
                  error(189, 2, gbl.lineno, buf, SYMNAME(ext));
                  /*
                   * continue with checking types, POINTER, etc.
                   */
                }
              }
            }
          } else if (STYPEG(arg) == ST_PROC) {
            while (A_TYPEG(actual) == A_MEM) {
              actual = A_MEMG(actual);
            }
            if (A_TYPEG(actual) != A_ID) {
              error(447, 3, gbl.lineno, buf, SYMNAME(ext));
              continue;
            }
            sptr = A_SPTRG(actual);
            if (STYPEG(sptr) != ST_PROC && STYPEG(sptr) != ST_ENTRY &&
                STYPEG(sptr) != ST_INTRIN && STYPEG(sptr) != ST_GENERIC &&
                !(DTY(DTYPEG(sptr)) == TY_PTR &&
                  DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC)) {
              error(447, 3, gbl.lineno, buf, SYMNAME(ext));
              continue;
            }
            /* FS#3742 Check that argument lists are compatible. */
            if (!compat_arg_lists(arg, sptr)) {
              char details[1000];
              sprintf(details, "- arguments of %s and %s do not agree",
                      SYMNAME(sptr), SYMNAME(arg));
              error(74, 3, gbl.lineno, SYMNAME(ext), details);
              continue;
            }
            if (ddum == 0) {
              /* formal has no dtype; was actual explicitly typed? */
              if (DCLDG(sptr) && DTYPEG(sptr) &&
                  !(DTY(DTYPEG(sptr)) == TY_PTR &&
                    DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC)) {
                /* actual was given a datatype */
                error(448, 3, gbl.lineno, buf, SYMNAME(ext));
              }
              continue;
            }
            if (dact == 0) {
              /* actual has no datatype; was the formal explicitly typed? */
              if (DCLDG(arg)) { /* formal was declared */
                error(449, 3, gbl.lineno, buf, SYMNAME(ext));
              }
              continue;
            }
            if (!DCLDG(arg) && !FUNCG(arg) && !DCLDG(sptr) && !FUNCG(sptr))
              /* formal & actual are subroutines?? */
              continue;
          }
          if (DTY(ddum) == TY_ARRAY) {
            if (ASSUMSHPG(arg) && !ignore_tkr(arg, IGNORE_R)) {
              if (shape == 0) {
                error(189, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
              if (ADD_NUMDIM(ddum) != SHD_NDIM(shape)) {
                error(446, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
              if (!cmpat_arr_arg(ddum, shape)) {
                error(190, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
              if (SHD_UPB(shape, SHD_NDIM(shape) - 1) == 0) {
                error(191, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
            }
          } else if (is_iso_cloc(actual)) {
  
            /* smooth LOC() typechecking ? */
            A_DTYPEP(actual, elddum);
            eldact = elddum;
          } else if (!ELEMENTALG(ext) && DTY(dact) == TY_ARRAY) {
            /* scalar passed to array */
            if (!ignore_tkr(arg, IGNORE_R))
              error(446, 3, gbl.lineno, buf, SYMNAME(ext));
            continue;
          }
          /* Check if types of actual and dummy match.
           * When the the procedure argument is a procedure, the
           * type of the dummy may not be available.  When the actual
           * is an ST_PROC  and the dummy is an ST_IDENT, don't check
           * the case if the ST_PROC's FVAL field is not set.
           */
          if (A_TYPEG(actual) != A_ID ||
              (STYPEG(A_SPTRG(actual)) != ST_PROC || FVALG(A_SPTRG(actual))) ||
              STYPEG(arg) != ST_IDENT) {
            if (DTY(elddum) != DTY(eldact)) {
              if (eldact == 0 && STYPEG(sym_of_ast(actual)) == ST_PROC &&
                  IS_PROC_DUMMYG(arg)) {
                continue;
              }
              if (DTY(elddum) == TY_DERIVED && UNLPOLYG(DTY(elddum + 3)))
                continue; /* FS#18004 */
              /* TY_ values are not the same */
              if (same_type_different_kind(elddum, eldact)) {
                /* kind differs */
                if (!ignore_tkr(arg, IGNORE_K))
                  error(450, 3, gbl.lineno, buf, SYMNAME(ext));
                else {
                  if (PASSBYVALG(arg) && DT_ISNUMERIC(DTYPEG(arg))) {
                    /*
                     * ensure the arg's semantic stack is
                     * evaluated and converted; this obviates
                     * the need for checking IGNORE_TKRG(
                     * param_dummy) in * semfunc.c:func_call2()
                     * - June 17,2015
                     */
                    (void)cngtyp(ARG_STK(i), DTYPEG(arg));
                    XFR_ARGAST(i);
                  }
                }
              } else if (DTY(eldact) == TY_WORD) {
                if (A_TYPEG(actual) == A_INTR && A_OPTYPEG(actual) == I_NULL &&
                    A_ARGCNTG(actual) == 0 && POINTERG(arg)) {
                  /* NULL() matches any POINTER formal */
                  ;
                } else if (DT_ISWORD(elddum))
                  ;
                else if (DT_ISDWORD(elddum)) {
                  ARG_AST(i) = mk_convert(ARG_AST(i), DT_DWORD);
                } else {
                  /* type differs */
                  if (!ignore_tkr(arg, IGNORE_T))
                    error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                }
              } else if (DTY(eldact) == TY_DWORD) {
                if (DT_ISDWORD(elddum))
                  ;
                else if (DT_ISWORD(elddum)) {
                  ARG_AST(i) = mk_convert(ARG_AST(i), DT_WORD);
                } else {
                  /* type differs */
                  if (!ignore_tkr(arg, IGNORE_T))
                    error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                }
              } else {
                /* type differs */
                if (!ignore_tkr(arg, IGNORE_T))
                  error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                else if (!ignore_tkr(arg, IGNORE_K) &&
                         !different_type_same_kind(elddum, eldact))
                  error(188, 3, gbl.lineno, buf, SYMNAME(ext));
              }
              continue;
            }
            /* check if type and kind of the data types match */
            if (!ignore_tkr(arg, IGNORE_T) &&
                !tk_match_arg(elddum, eldact, CLASSG(arg))) {
              if (DTY(elddum) != TY_DERIVED || !UNLPOLYG(DTY(elddum + 3))) {
                int mem;
                mem = get_generic_member(elddum, ext);
                if (!mem) {
                  mem = get_generic_member(eldact, ext);
                }
                if (!mem || NOPASSG(mem)) {
                  error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                  continue;
                }
                if (i == 0 && !PASSG(mem) &&
                    !tk_match_arg(eldact, elddum, CLASSG(arg))) {
                  error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                  continue;
                }
                if (PASSG(mem) &&
                    strcmp(SYMNAME(PASSG(mem)), SYMNAME(arg)) == 0 &&
                    !tk_match_arg(eldact, elddum, CLASSG(arg))) {
                  error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                  continue;
                }
              }
            }
          }
          if (POINTERG(arg)) {
            if (INTENTG(arg) != INTENT_IN) {
              int s;
              int iface;
              s = 0;
              switch (A_TYPEG(actual)) {
              case A_ID:
              case A_MEM:
                s = memsym_of_ast(actual);
                break;
              case A_FUNC:
                s = A_SPTRG(A_LOPG(actual));
                proc_arginfo(s, NULL, NULL, &iface);
                s = iface;
                break;
              case A_INTR:
                if (A_OPTYPEG(actual) == I_NULL)
                  s = A_SPTRG(A_LOPG(actual));
                break;
              }
              if (s == 0 || (!POINTERG(s) &&
                             !(STYPEG(s) == ST_PD && PDNUMG(s) == PD_null))) {
                sprintf(buf, "%d (non-POINTER)", i + 1);
                error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
            } else if (IS_CHAR_TYPE(DTYG(DTYPEG(arg)))) {
              if (!IS_CHAR_TYPE(DTYG(A_DTYPEG(actual)))) {
                error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
              /* dummy must be adjustable length or the sizes must match */
              if (!ADJLENG(arg) && !eq_dtype(DTYPEG(arg), A_DTYPEG(actual))) {
                error(188, 3, gbl.lineno, buf, SYMNAME(ext));
                continue;
              }
            } else if (!eq_dtype2(DTYPEG(arg), A_DTYPEG(actual), TRUE)) {
              error(188, 3, gbl.lineno, buf, SYMNAME(ext));
              continue;
            } else if (CONTIGATTRG(arg) && !simply_contiguous(actual)) {
              error(546, 3, gbl.lineno, SYMNAME(arg), NULL);
              continue;
            }
          }
          if (ALLOCATTRG(arg)) {
            int s;
            int iface;
            s = 0;
            switch (A_TYPEG(actual)) {
            case A_ID:
              s = A_SPTRG(actual);
              break;
            case A_FUNC:
              s = A_SPTRG(A_LOPG(actual));
              proc_arginfo(s, NULL, NULL, &iface);
              s = iface;
              s = FVALG(s);
              break;
            case A_MEM:
              s = A_SPTRG(A_MEMG(actual));
              break;
            }
            if (s == 0 || !ALLOCATTRG(s)) {
              sprintf(buf, "%d (non-allocatable)", i + 1);
              error(188, 3, gbl.lineno, buf, SYMNAME(ext));
              continue;
            }
            NOALLOOPTP(s, 1);
          }
        }
        if (PASSBYVALG(arg)) {
          if (INTENTG(arg) == INTENT_OUT) {
            error(134, 3, gbl.lineno, "- INTENT(OUT) conflicts with VALUE",
                  CNULL);
            continue;
          }
          if (INTENTG(arg) == INTENT_INOUT) {
            error(134, 3, gbl.lineno, "- INTENT(INOUT) conflicts with VALUE",
                  CNULL);
            continue;
          }
        }
        if (actual && !A_ISLVAL(A_TYPEG(actual)) &&
            (INTENTG(arg) == INTENT_OUT || INTENTG(arg) == INTENT_INOUT)) {
          error(193, 2, gbl.lineno, buf, SYMNAME(ext));
          continue;
        }
        if (actual && A_ISLVAL(A_TYPEG(actual)) &&
            (INTENTG(arg) == INTENT_OUT || INTENTG(arg) == INTENT_INOUT)) {
          if (POINTERG(arg)) {
            /*
             * The formal argument is a pointer; the corresponding
             * actual cannot be an intent(in) argument.
             */
            sptr = find_pointer_variable(actual);
            if (sptr && POINTERG(sptr))
              (void)chk_pointer_intent(sptr, actual);
            if (is_protected(sym_of_ast(actual))) {
              err_protected(sptr, "be an actual argument when the dummy argument "
                                  "is INTENT(OUT) or INTENT(INOUT)");
            }
          } else if (A_TYPEG(actual) == A_ID &&
                     SCG(A_SPTRG(actual)) == SC_DUMMY &&
                     INTENTG(A_SPTRG(actual)) == INTENT_IN &&
                     !POINTERG(A_SPTRG(actual)))
            error(193, 2, gbl.lineno, buf, SYMNAME(ext));
        }
        if (!ALLOCATTRG(arg) && ASSUMSHPG(arg) && actual) {
          /* full descriptor required for 'arg' */
          int aid;
          switch (A_TYPEG(actual)) {
          case A_SUBSCR:
            aid = A_LOPG(actual);
            if (aid && A_TYPEG(aid) == A_ID) {
              sptr = A_SPTRG(aid);
              goto chk_allocatable;
            }
            break;
          case A_ID:
            sptr = A_SPTRG(actual);
            goto chk_allocatable;
          case A_MEM:
            sptr = A_SPTRG(A_MEMG(actual));
          chk_allocatable:
            if (ALLOCATTRG(sptr)) {
              ALLOCDESCP(sptr, TRUE);
            }
          default:
            break;
          }
        }
      } else {
        if (actual == 0 || A_TYPEG(actual) != A_LABEL) {
          /* alternate returns */
          error(192, 3, gbl.lineno, buf, SYMNAME(ext));
        }
      }
    }
  
    return FALSE;
  }
  
  LOGICAL
  ignore_tkr(int arg, int tkr)
  {
    /*
     * Is it ok to ignore checking the specified TKR based on the presence
     * and value of the IGNORE_TKR directive?
     *
     * NOTE: * If we need to ignore the effects of the IGNORE_TKR directive,
     * guard the following 'if' with a test of an XBIT or whatever.
     */
    if (tkr == IGNORE_C && (IGNORE_TKRG(arg) & IGNORE_C) && ASSUMSHPG(arg))
      return TRUE;
    if ((IGNORE_TKRG(arg) & tkr) &&
        (ignore_tkr_all(arg) ||
         (!ASSUMSHPG(arg) && !POINTERG(arg) && !ALLOCATTRG(arg))))
      return TRUE;
    return FALSE;
  }
  
  LOGICAL
  ignore_tkr_all(int arg)
  {
    if (((IGNORE_TKRG(arg) & IGNORE_TKR_ALL) == IGNORE_TKR_ALL) ||
        ((IGNORE_TKRG(arg) & IGNORE_TKR_ALL) == IGNORE_TKR_ALL0))
      return TRUE;
    return FALSE;
  }
  
  /** \brief Check conformance of two arrays, where the first array is described
   *         with a dtype record, and the second is described with a shape
   * descriptor.
   *
   *  Return true if the data types for two shapes are conformable (have the same
   *  shape). Shape is defined to be the rank and the extents of each dimension.
   */
  static LOGICAL
  cmpat_arr_arg(int d1, int shape2)
  {
    int ndim;
    int i;
    int bnd;
    ADSC *ad1;
    INT lb1, lb2; /* lower bounds if constants */
    INT ub1, ub2; /* upper bounds if constants */
    INT st2;      /* stride of shape2 if constant */
  
    ad1 = AD_DPTR(d1);
    ndim = AD_NUMDIM(ad1);
    if (ndim != SHD_NDIM(shape2))
      return FALSE;
  
    for (i = 0; i < ndim; i++) {
      if ((bnd = AD_LWAST(ad1, i))) {
        if ((bnd = A_ALIASG(bnd)) == 0)
          continue; /* nonconstant bound => skip this dimension */
        lb1 = get_int_cval(A_SPTRG(bnd));
      } else
        lb1 = 1; /* no lower bound => 1 */
  
      if ((bnd = AD_UPAST(ad1, i))) {
        if ((bnd = A_ALIASG(bnd)) == 0)
          continue; /* nonconstant bound => skip this dimension */
        ub1 = get_int_cval(A_SPTRG(bnd));
      } else
        continue; /* no upper bound => skip this dimension */
  
      if ((lb2 = A_ALIASG(SHD_LWB(shape2, i))) == 0)
        continue; /*  not a constant => skip this dimension */
      lb2 = get_int_cval(A_SPTRG(lb2));
  
      if ((ub2 = A_ALIASG(SHD_UPB(shape2, i))) == 0)
        continue; /*  not a constant => skip this dimension */
      ub2 = get_int_cval(A_SPTRG(ub2));
  
      if ((st2 = A_ALIASG(SHD_STRIDE(shape2, i))) == 0)
        continue; /*  not a constant => skip this dimension */
      st2 = get_int_cval(A_SPTRG(st2));
  
      /* lower and upper bounds and stride are constants in this dimension*/
  
      if ((ub1 - lb1 + 1) != (ub2 - lb2 + st2) / st2)
        return FALSE;
    }
  
    return TRUE;
  }
  
  static int iface_arg(int, int, int);
  
  int
  iface_intrinsic(int sptr)
  {
    int ii;
    int paramct, dtyper, argdtype;
    int ss;
    int iface, arg, dpdsc, fval;
    char *kwd, *np;
    int kwd_len;
    int optional;
  
    ii = INTASTG(sptr);
    switch (ii) {
    case I_ABS: /* abs */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_ACOS: /* acos */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_AIMAG: /* aimag */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_AINT: /* aint */
      paramct = 2;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_ALOG: /* alog */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_ALOG10: /* alog10 */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_AMOD: /* amod */
      paramct = 2;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_ANINT: /* anint */
      paramct = 2;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_ASIN: /* asin */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_ATAN: /* atan */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_ATAN2: /* atan2 */
      paramct = 2;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_CABS: /* cabs */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_CCOS: /* ccos */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_CEXP: /* cexp */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_CLOG: /* clog */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_CONJG: /* conjg */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_COS: /* cos */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_COSH: /* cosh */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_CSIN: /* csin */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_CSQRT: /* csqrt */
      paramct = 1;
      dtyper = DT_CMPLX;
      argdtype = DT_CMPLX;
      break;
    case I_DABS: /* dabs */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DACOS: /* dacos */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DASIN: /* dasin */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DATAN: /* datan */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DATAN2: /* datan2 */
      paramct = 2;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DCOS: /* dcos */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DCOSH: /* dcosh */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DDIM: /* ddim */
      paramct = 2;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DEXP: /* dexp */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DIM: /* dim */
      paramct = 2;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_DINT: /* dint */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DLOG: /* dlog */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DLOG10: /* dlog10 */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DMOD: /* dmod */
      paramct = 2;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DNINT: /* dnint */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DPROD: /* dprod */
      paramct = 2;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_DSIGN: /* dsign */
      paramct = 2;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DSIN: /* dsin */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DSINH: /* dsinh */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DSQRT: /* dsqrt */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DTAN: /* dtan */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_DTANH: /* dtanh */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_EXP: /* exp */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_IABS: /* iabs */
      paramct = 1;
      dtyper = DT_INT;
      argdtype = DT_INT;
      break;
    case I_IDIM: /* idim */
      paramct = 2;
      dtyper = DT_INT;
      argdtype = DT_INT;
      break;
    case I_IDNINT: /* idnint */
      paramct = 1;
      dtyper = DT_DBLE;
      argdtype = DT_DBLE;
      break;
    case I_INDEX: /* index */
      paramct = 4;
      dtyper = DT_INT;
      argdtype = DT_ASSCHAR;
      break;
    case I_ISIGN: /* isign */
      paramct = 2;
      dtyper = DT_INT;
      argdtype = DT_INT;
      break;
    case I_LEN: /* len */
      paramct = 2;
      dtyper = DT_INT;
      argdtype = DT_ASSCHAR;
      break;
    case I_MOD: /* mod */
      paramct = 2;
      dtyper = DT_INT;
      argdtype = DT_INT;
      break;
    case I_NINT: /* nint */
      paramct = 2;
      dtyper = DT_INT;
      argdtype = DT_REAL;
      break;
    case I_SIGN: /* sign */
      paramct = 2;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_SIN: /* sin */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_SINH: /* sinh */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_SQRT: /* sqrt */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_TAN: /* tan */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    case I_TANH: /* tanh */
      paramct = 1;
      dtyper = DT_REAL;
      argdtype = DT_REAL;
      break;
    default:
      return 0;
    }
    ss = intast_sym[ii];
    /*
     * Build an 'abstract' interface from the intrinisic.
     * create a new symbol from the intrinsic with a fake name so that
     * it doesn't clash with a user or intrinsic symbol.
     */
    iface = getsymf("...%s", SYMNAME(ss));
    if (STYPEG(iface) != ST_UNKNOWN)
      return iface;
    CCSYMP(iface, 1);
    STYPEP(iface, ST_PROC);
    ABSTRACTP(iface, 1);
    DTYPEP(iface, dtyper);
    DCLDP(iface, 1);
    PUREP(iface, 1);
    if (INKINDG(ss) == IK_ELEMENTAL) {
      ELEMENTALP(iface, 1);
    }
    fval = iface_arg(iface, dtyper, iface);
    RESULTP(fval, 1);
    FVALP(iface, fval);
    FUNCP(iface, 1);
    PARAMCTP(iface, paramct);
    ++aux.dpdsc_avl; /* reserve one for fval */
    dpdsc = aux.dpdsc_avl;
    DPDSCP(iface, dpdsc);
    aux.dpdsc_avl += paramct;
    NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size,
         aux.dpdsc_size + paramct + 100);
    aux.dpdsc_base[dpdsc - 1] = fval;
    kwd = KWDARGSTR(ss);
    for (ii = 0; TRUE; ii++, kwd = np) {
      if (*kwd == '\0')
        break;
      if (*kwd == ' ')
        kwd++;
      if (*kwd != '*')
        optional = 0;
      else {
        optional = 1;
        kwd++;
      }
      kwd_len = 0;
      for (np = kwd; TRUE; np++) {
        if (*np == ' ' || *np == '\0')
          break;
        kwd_len++;
      }
      arg = getsym(kwd, kwd_len);
      arg = iface_arg(arg, argdtype, iface);
      OPTARGP(arg, optional);
      INTENTP(arg, INTENT_IN);
      aux.dpdsc_base[dpdsc] = arg;
      dpdsc++;
    }
  #if DEBUG
    assert(ii == paramct, "iface_intrinsic: paramct does not match", iface, 3);
  #endif
    return iface;
  }
  
  static int
  iface_arg(int arg, int dt, int iface)
  {
    if (STYPEG(arg) != ST_UNKNOWN)
      arg = insert_sym(arg);
    pop_sym(arg);
    STYPEP(arg, ST_VAR);
    DTYPEP(arg, dt);
    SCOPEP(arg, iface);
    SCP(arg, SC_DUMMY);
    DCLDP(arg, 1);
    NODESCP(arg, 1);
    IGNOREP(arg, 1);
  
    return arg;
  }
  