osprey/crayf90/fe90/s_asg_expr.c

Go to the documentation of this file.

/*
 * Copyright 2007, 2008. PathScale, LLC.  All Rights Reserved.
 */
/*
 *  Copyright (C) 2006, 2007. QLogic Corporation. All Rights Reserved.
 */

/*
 * Copyright 2004, 2005, 2006 PathScale, Inc.  All Rights Reserved.
 */

/*

  Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.

  This program is free software; you can redistribute it and/or modify it
  under the terms of version 2 of the GNU General Public License as
  published by the Free Software Foundation.

  This program is distributed in the hope that it would be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

  Further, this software is distributed without any warranty that it is
  free of the rightful claim of any third person regarding infringement 
  or the like.  Any license provided herein, whether implied or 
  otherwise, applies only to this software file.  Patent licenses, if 
  any, provided herein do not apply to combinations of this program with 
  other software, or any other product whatsoever.  

  You should have received a copy of the GNU General Public License along
  with this program; if not, write the Free Software Foundation, Inc., 59
  Temple Place - Suite 330, Boston MA 02111-1307, USA.

  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
  Mountain View, CA 94043, or:

  http://www.sgi.com

  For further information regarding this notice, see:

  http://oss.sgi.com/projects/GenInfo/NoticeExplan

*/



static char USMID[] = "\n@(#)5.0_pl/sources/s_asg_expr.c  5.10  10/26/99 17:20:56\n";

# include "defines.h"   /* Machine dependent ifdefs */

# include "host.m"    /* Host machine dependent macros.*/
# include "host.h"    /* Host machine dependent header.*/
# include "target.m"    /* Target machine dependent macros.*/
# include "target.h"    /* Target machine dependent header.*/

# include "globals.m"
# include "tokens.m"
# include "sytb.m"
# include "s_globals.m"
# include "debug.m"
# include "s_asg_expr.m"

# include "globals.h"
# include "tokens.h"
# include "sytb.h"
# include "s_globals.h"

# include "s_asg_expr.h"

# if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
# include <fortran.h>
# endif

boolean has_present_opr;

/*****************************************************************\
|* Function prototypes of static functions declared in this file. |
\*****************************************************************/

static boolean  array_construct_semantics(opnd_type *, expr_arg_type *);
static boolean  bin_array_syntax_check(expr_arg_type *, expr_arg_type *,
               expr_arg_type *, int, int);

static void   make_logical_array_tmp(opnd_type *, expr_arg_type *);
static void     fold_nested_substrings(int);
static boolean  uplus_opr_handler(opnd_type *, expr_arg_type *);
static boolean  power_opr_handler(opnd_type *, expr_arg_type *);
static boolean  mult_opr_handler(opnd_type *, expr_arg_type *);
static boolean  minus_opr_handler(opnd_type *, expr_arg_type *);
static boolean  plus_opr_handler(opnd_type *, expr_arg_type *);
static boolean  concat_opr_handler(opnd_type *, expr_arg_type *);
static boolean  eq_opr_handler(opnd_type *, expr_arg_type *);
static boolean  lg_opr_handler(opnd_type *, expr_arg_type *);
static boolean  lt_opr_handler(opnd_type *, expr_arg_type *);
static boolean  not_opr_handler(opnd_type *, expr_arg_type *);
static boolean  and_opr_handler(opnd_type *, expr_arg_type *);
static boolean  defined_un_opr_handler(opnd_type *, expr_arg_type *);
static boolean  defined_bin_opr_handler(opnd_type *, expr_arg_type *);
static boolean  max_opr_handler(opnd_type *, expr_arg_type *);
static boolean  struct_opr_handler(opnd_type *, expr_arg_type *, int);
static boolean  struct_construct_opr_handler(opnd_type *, expr_arg_type *);
static boolean  array_construct_opr_handler(opnd_type *, expr_arg_type *);
static boolean  subscript_opr_handler(opnd_type *, expr_arg_type *, int);
static boolean  substring_opr_handler(opnd_type *, expr_arg_type *, int);
static boolean  triplet_opr_handler(opnd_type *, expr_arg_type *);
static boolean  dealloc_obj_opr_handler(opnd_type *, expr_arg_type *, int);
static boolean  alloc_obj_opr_handler(opnd_type *, expr_arg_type *, int);
static boolean  cvrt_opr_handler(opnd_type *, expr_arg_type *);
static boolean  paren_opr_handler(opnd_type *, expr_arg_type *);
static boolean  stmt_func_call_opr_handler(opnd_type *, expr_arg_type *);
static int  implied_do_depth(opnd_type *);
static long64 outer_imp_do_count(opnd_type *);
static void lower_ptr_asg(expr_arg_type *);
# if defined(_F_MINUS_MINUS)
static void translate_distant_ref1(opnd_type *, expr_arg_type *, int);

# if defined(_TARGET_OS_MAX)
static void translate_t3e_distant_ref(opnd_type *, expr_arg_type *, int);
static void translate_t3e_dv_component(opnd_type *, expr_arg_type *);
static int      capture_bounds_from_dv(int, int, int);
# endif

static void translate_distant_dv_ref(opnd_type *, expr_arg_type *, int);
static void translate_distant_ref2(opnd_type *, expr_arg_type *, int);
static int  set_up_pe_offset_attr(void);
static void gen_bias_ref(opnd_type *);
static void linearize_pe_dims(int, int, int, int, opnd_type *);
# endif
#ifdef KEY /* Bug 934 */
static boolean expr_sem_d(opnd_type *result_opnd, expr_arg_type *exp_desc,
  boolean derived_assign);
static boolean expr_semantics_d (opnd_type *result_opnd,
  expr_arg_type *exp_desc, boolean derived_assign);
#endif /* KEY Bug 934 */


# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX) || defined(_HOST_OS_DARWIN))
# pragma inline uplus_opr_handler
# pragma inline power_opr_handler
# pragma inline mult_opr_handler
# pragma inline minus_opr_handler
# pragma inline plus_opr_handler
# pragma inline concat_opr_handler
# pragma inline eq_opr_handler
# pragma inline lg_opr_handler
# pragma inline lt_opr_handler
# pragma inline not_opr_handler
# pragma inline and_opr_handler
# pragma inline defined_un_opr_handler
# pragma inline defined_bin_opr_handler
# pragma inline max_opr_handler
# pragma inline struct_opr_handler
# pragma inline struct_construct_opr_handler
# pragma inline array_construct_opr_handler
# pragma inline subscript_opr_handler
# pragma inline substring_opr_handler
# pragma inline triplet_opr_handler
# pragma inline dealloc_obj_opr_handler
# pragma inline alloc_obj_opr_handler
# pragma inline cvrt_opr_handler
# pragma inline paren_opr_handler
# pragma inline stmt_func_call_opr_handler
# else
# pragma _CRI inline uplus_opr_handler
# pragma _CRI inline power_opr_handler
# pragma _CRI inline mult_opr_handler
# pragma _CRI inline minus_opr_handler
# pragma _CRI inline plus_opr_handler
# pragma _CRI inline concat_opr_handler
# pragma _CRI inline eq_opr_handler
# pragma _CRI inline lg_opr_handler
# pragma _CRI inline lt_opr_handler
# pragma _CRI inline not_opr_handler
# pragma _CRI inline and_opr_handler
# pragma _CRI inline defined_un_opr_handler
# pragma _CRI inline defined_bin_opr_handler
# pragma _CRI inline max_opr_handler
# pragma _CRI inline struct_opr_handler
# pragma _CRI inline struct_construct_opr_handler
# pragma _CRI inline array_construct_opr_handler
# pragma _CRI inline subscript_opr_handler
# pragma _CRI inline substring_opr_handler
# pragma _CRI inline triplet_opr_handler
# pragma _CRI inline dealloc_obj_opr_handler
# pragma _CRI inline alloc_obj_opr_handler
# pragma _CRI inline cvrt_opr_handler
# pragma _CRI inline paren_opr_handler
# pragma _CRI inline stmt_func_call_opr_handler
# endif


#ifdef KEY /* Bug 4810 */
/*
 * Return true if op0 is the same node as op1
 */
static boolean opnd_matches(opnd_type *op0, opnd_type *op1) {
  return op0->fld == op1->fld && op0->idx == op1->idx;
  }

/*
 * An assignment statement following an OMP "atomic" statement is supposed to
 * have one of these forms, with any operators inside "expr" having precedence
 * greater than or equal to that of "op":
 *
 *   lhs = function_call(...)
 *   lhs = expr op lhs
 *   lhs = lhs op expr
 *
 * But in a case like this:
 *
 *   lhs = lhs + expr_b + expr_c
 *
 * the parser generates a left-associative expression:
 *
 *   lhs = (lhs + expr_b) + expr_c
 *
 * and the OMP lowering code cannot find the nested reference to "lhs". We use
 * the Fortran associativity rules to change this to:
 *
 *   lhs = lhs + (expr_b + expr_c)
 *
 * While OMP allows non-commutative operators "-" and "/", it also requires
 * that "lhs op expr" be mathematically equivalent to "lhs op (expr)". That
 * means "lhs + expr_b - expr_c" must work (so we can't just swap "lhs" with
 * "expr_c") but "lhs - expr_b - expr_c" is a user error (which we want to
 * leave alone, so the lowerer can issue a diagnostic.) Thus the operator
 * adjacent to "lhs" must be one of the commutative ones.
 */
static void unbury_lhs_for_omp() {
  /* Previous statement wasn't OMP "atomic" */
  if (curr_stmt_sh_idx == SCP_FIRST_SH_IDX(curr_scp_idx) ||
    IR_OPR(SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))) != Atomic_Open_Mp_Opr) {
    return;
  }
  int stmt_idx = SH_IR_IDX(curr_stmt_sh_idx);
  int rhs_idx = IR_IDX_R(stmt_idx);
  /* RHS isn't an operator node */
  if (IR_FLD_R(stmt_idx) != IR_Tbl_Idx) {
    return;
  }
  operator_type operator = IR_OPR(rhs_idx);
  /* RHS is not an OMP-approved operator */
  if (operator != Plus_Opr && operator != Minus_Opr &&
    operator != Mult_Opr && operator != Div_Opr &&
    operator != And_Opr && operator != Or_Opr &&
    operator != Eqv_Opr && operator != Neqv_Opr) {
    return;
    }
  opnd_type *lhs_opnd = &(IR_OPND_L(stmt_idx));
  /* Top left operand already matches LHS, so no need to swap */
  if (opnd_matches(lhs_opnd, &(IR_OPND_L(rhs_idx)))) {
    return;
  }
  /* Top right operand already matches LHS, so no need to swap */
  if (opnd_matches(lhs_opnd, &(IR_OPND_R(rhs_idx)))) {
    return;
  }

  operator_type alt_operator = operator;
  if (operator == Plus_Opr) {
    alt_operator = Minus_Opr;
    }
  else if (operator == Minus_Opr) {
    alt_operator = Plus_Opr;
    }
  else if (operator == Mult_Opr) {
    alt_operator = Div_Opr;
    }
  else if (operator == Div_Opr) {
    alt_operator = Mult_Opr;
    }
  else if (operator == Eqv_Opr) {
    alt_operator == Neqv_Opr;
    }
  else if (operator == Neqv_Opr) {
    alt_operator == Eqv_Opr;
    }

  int parent_idx = rhs_idx;
  for (int node_idx = IR_IDX_L(parent_idx);
    IR_Tbl_Idx == IR_FLD_L(parent_idx) &&
      (operator == IR_OPR(node_idx) || alt_operator == IR_OPR(node_idx));
    parent_idx = node_idx, node_idx = IR_IDX_L(parent_idx)) {
    /* "-" or "/" can't be the operator we're unburying */
    if (opnd_matches(lhs_opnd, &(IR_OPND_L(node_idx))) &&
      (IR_OPR(node_idx) != Minus_Opr) && (IR_OPR(node_idx) != Div_Opr)) {
      opnd_type save_rhs = IR_OPND_R(stmt_idx);
      opnd_type save_right_opnd = IR_OPND_R(node_idx);
      IR_OPND_R(stmt_idx) = IR_OPND_L(parent_idx);
      IR_OPND_R(node_idx) = save_rhs;
      IR_OPND_L(parent_idx) = save_right_opnd;
      break;
    }
  }
}

#endif /* KEY Bug 4810 */
#ifdef KEY /* Bug 6845 */
static void help_assign_cpnts(int, int, Uint, int, fld_type, int, fld_type);

static void
help_assign_array_of_structure(int line, int col, int idx_l, fld_type fld_l,
  int idx_r, fld_type fld_r) {
  opnd_type opnd_l, opnd_r;
  expr_arg_type exp_desc_l, exp_desc_r;
  int next_sh_idx = NULL_IDX;
  int placeholder_sh_idx = pre_gen_loops(line, col, &next_sh_idx);
  OPND_FLD(opnd_l) = fld_l;
  OPND_IDX(opnd_l) = idx_l;
  OPND_FLD(opnd_r) = fld_r;
  OPND_IDX(opnd_r) = idx_r;
  OPND_LINE_NUM(opnd_l) = OPND_LINE_NUM(opnd_r) = line;
  OPND_COL_NUM(opnd_l) = OPND_COL_NUM(opnd_r) = col;
  gen_loops(&opnd_l, &opnd_r, TRUE);
  help_assign_cpnts(line, col, IR_TYPE_IDX(OPND_IDX(opnd_l)), OPND_IDX(opnd_l),
    OPND_FLD(opnd_l), OPND_IDX(opnd_r), OPND_FLD(opnd_r));
  post_gen_loops(placeholder_sh_idx, next_sh_idx);
}

/*
 * Given an assignment of a structure type known to have one or more
 * allocatable components, replace the assignment with a series of assignments
 * of the individual components, using a runtime system call to handle the
 * allocatable components, since they require automatic reallocation in
 * addition to the copying of data.
 *
 * line   Source line
 * col    Source column
 * type_idx Type of lvalue (or rvalue) of assignment
 * lvalue_idx Index of lvalue
 * lvalue_fld IR_Tbl_Idx or AT_Tbl_Idx of lvalue
 * rvalue_idx Index of rvalue
 * lvalue_fld IR_Tbl_Idx or AT_Tbl_Idx of rvalue
 */
static void
help_assign_cpnts(int line, int col, Uint type_idx,
  int lvalue_idx, fld_type lvalue_fld, int rvalue_idx, fld_type rvalue_fld) {

  for (int sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX(type_idx));
    sn_idx != NULL_IDX;
    sn_idx = SN_SIBLING_LINK(sn_idx)) {
    boolean need_semantics = FALSE;
    int cpnt_attr_idx = SN_ATTR_IDX(sn_idx);
    int l_idx = do_make_struct_opr(line, col, lvalue_idx, lvalue_fld,
      cpnt_attr_idx);

    int r_idx = do_make_struct_opr(line, col, rvalue_idx, rvalue_fld,
      cpnt_attr_idx);
    int new_ir_idx = NULL_IDX;

    /* Allocatable array: generate runtime system call */
    if (ATD_ALLOCATABLE(cpnt_attr_idx)) {
      new_ir_idx = build_call(Assign_Allocatable_Idx, ASSIGN_ALLOCATABLE_ENTRY,
  gen_il(4, TRUE, line, col,
    IR_Tbl_Idx, pass_by_ref(IR_Tbl_Idx, l_idx, line, col),
    IR_Tbl_Idx, pass_by_ref(IR_Tbl_Idx, r_idx, line, col),
    CN_Tbl_Idx, CN_INTEGER_ONE_IDX,
    CN_Tbl_Idx, CN_INTEGER_ZERO_IDX),
  line, col);
    }

    else if (allocatable_structure_component(cpnt_attr_idx)) {

      /* Non-allocatable array whose element type is a structure having
       * allocatable components or subcomponents: no dope vector, so we can't
       * use ASSIGN_ALLOCATABLE_ARRAY: instead loop, assigning elements */
      if (ATD_ARRAY_IDX(cpnt_attr_idx) != NULL_IDX) {
        help_assign_array_of_structure(line, col, l_idx, IR_Tbl_Idx, r_idx,
    IR_Tbl_Idx);
      }

      /* Scalar structure having allocatable components or subcomponents:
       * recursively assign them. */
      else {
  help_assign_cpnts(line, col,
    ATD_TYPE_IDX(cpnt_attr_idx), l_idx, IR_Tbl_Idx, r_idx, IR_Tbl_Idx);
      }
    }

    /* Generate ordinary component assignment */
    else {
      new_ir_idx = gen_ir(IR_Tbl_Idx, l_idx, Asg_Opr,
        ATD_TYPE_IDX(cpnt_attr_idx), line, col, IR_Tbl_Idx, r_idx);
      /* Array, character assignments need expansion by semantics processing */
      need_semantics = (ATD_ARRAY_IDX(cpnt_attr_idx) != NULL_IDX ||
        TYP_TYPE(ATD_TYPE_IDX(cpnt_attr_idx)) == Character);
    }

    if (new_ir_idx != NULL_IDX) {
      gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
      SH_IR_IDX(curr_stmt_sh_idx) = new_ir_idx;
      if (need_semantics) {
  assignment_stmt_semantics();
      }
      else {
  SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
      }
    }
  }
}

#endif /* KEY Bug 6845 */
/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Top semantics routine for assignment and pointer assignment.          *|
|*                        *|
|* Input parameters:                    *|
|*  NONE                      *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NONE                      *|
|*                        *|
\******************************************************************************/

void assignment_stmt_semantics (void)

{
   int         asg_idx;
   int               attr_idx;
   int               col;
   expr_arg_type     exp_desc_l;
   expr_arg_type     exp_desc_r;
   opnd_type       forall_tmp_opnd;
   opnd_type       forall_tmp_opnd_l;
   boolean       forall_dependence;
   expr_arg_type     forall_exp_desc;
   int         i;
   int               ir_idx;
   int               idx;
   char              l_err_word[40];
   opnd_type         l_opnd;
   int               line;
   int         list_idx;
   int         label_idx;
   boolean           ok     = TRUE;
   opnd_type       opnd;
   int         opnd_col;
   int         opnd_line;
   char              r_err_word[40];
   opnd_type         r_opnd;
   linear_type_type  result_type;
   int         save_curr_stmt_sh_idx;
   int         save_where_ir_idx;


   TRACE (Func_Entry, "assignment_stmt_semantics", NULL);

#ifdef KEY /* Bug 4810 */
   unbury_lhs_for_omp();
#endif /* KEY Bug 4810 */

   ir_idx = SH_IR_IDX(curr_stmt_sh_idx);

   line = IR_LINE_NUM(ir_idx);
   col  = IR_COL_NUM(ir_idx);

   if (IR_OPR(ir_idx) == Asg_Opr) {


      /* clear the where_ir_idx so that intrinsics on left hand */
      /* side (in subscripts) are handled without mask.          */

      save_where_ir_idx = where_ir_idx;
      where_ir_idx = NULL_IDX;

      if (active_forall_sh_idx) {
        defer_stmt_expansion = TRUE;
      }

      xref_state = CIF_Symbol_Modification;
      COPY_OPND(l_opnd, IR_OPND_L(ir_idx));
      exp_desc_l.rank = 0;
      ok = expr_semantics(&l_opnd, &exp_desc_l);
      COPY_OPND(IR_OPND_L(ir_idx), l_opnd);

      where_ir_idx = save_where_ir_idx;

      if (IR_FLD_R(ir_idx) == IR_Tbl_Idx &&
          IR_OPR(IR_IDX_R(ir_idx)) == Call_Opr &&
          AT_IS_INTRIN(IR_IDX_L(IR_IDX_R(ir_idx))) &&
          (strcmp(AT_OBJ_NAME_PTR(IR_IDX_L(IR_IDX_R(ir_idx))), "NULL") == 0)) {
         ok = FALSE;
         PRINTMSG(IR_LINE_NUM_R(ir_idx), 1557, Error, IR_COL_NUM_R(ir_idx));
      }

      if (! ok) {
         /* intentionally blank */
      }
      else if (exp_desc_l.constant) {
         ok = FALSE;

         if (OPND_FLD(l_opnd) == AT_Tbl_Idx &&
            AT_OBJ_CLASS(OPND_IDX(l_opnd)) == Data_Obj &&
            ATD_SYMBOLIC_CONSTANT(OPND_IDX(l_opnd))) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 1632, Error, IR_COL_NUM(ir_idx),
                     AT_OBJ_NAME_PTR(OPND_IDX(l_opnd)));
         }
         else {
            PRINTMSG(IR_LINE_NUM(ir_idx), 326, Error, IR_COL_NUM(ir_idx));
         }
      }
      else if (SH_COMPILER_GEN(curr_stmt_sh_idx)) {
         /* intentionally empty, to prevent the following clauses */

      }
      else if (! check_for_legal_define(&l_opnd)) {
         ok = FALSE;
      }

      if (cif_flags & MISC_RECS) {
         cif_stmt_type_rec(TRUE,
                           (exp_desc_l.rank == 0) ?
                              CIF_Assignment_Stmt : CIF_Array_Assignment_Stmt,
                           statement_number);
      } 

      xref_state = CIF_Symbol_Reference;
      COPY_OPND(r_opnd, IR_OPND_R(ir_idx));
      exp_desc_r.rank = 0;
#ifdef KEY /* Bug 934 */
      ok &= expr_semantics_d(&r_opnd, &exp_desc_r,
        (exp_desc_l.type == Structure));
#else /* KEY Bug 934 */
      ok &= expr_semantics(&r_opnd, &exp_desc_r);
#endif /* KEY Bug 934 */
      COPY_OPND(IR_OPND_R(ir_idx), r_opnd);

      if (! ok) {
         goto EXIT;
      }

      OPND_FLD(r_opnd) = IR_Tbl_Idx;
      OPND_IDX(r_opnd) = ir_idx;

      if (exp_desc_l.rank == exp_desc_r.rank) {
         for (i = 0; i < exp_desc_r.rank; i++) {
            if (OPND_FLD(exp_desc_l.shape[i]) == CN_Tbl_Idx &&
                OPND_FLD(exp_desc_r.shape[i]) == CN_Tbl_Idx &&
                fold_relationals(OPND_IDX(exp_desc_l.shape[i]),
                                 OPND_IDX(exp_desc_r.shape[i]),
                                 Ne_Opr)) {

               /* non conforming array syntax */
               PRINTMSG(IR_LINE_NUM(ir_idx), 253, Error,
                        IR_COL_NUM(ir_idx));
               ok = FALSE;
               break;
            }
         }
      }

      result_type = ASG_TYPE(exp_desc_l.linear_type, exp_desc_r.linear_type);

# if defined(_EXTENDED_CRI_CHAR_POINTER)
      if (result_type == CRI_Ch_Ptr_8 &&
          exp_desc_r.linear_type != CRI_Ch_Ptr_8) {

         transform_cri_ch_ptr(&l_opnd);
         COPY_OPND(IR_OPND_L(ir_idx), l_opnd);
      }
# endif

      if (result_type != Err_Res                                        &&
          result_type != Structure_Type                                 &&
          (exp_desc_l.rank == exp_desc_r.rank || exp_desc_r.rank == 0)) {
   
         if (ASG_EXTN(exp_desc_l.linear_type, exp_desc_r.linear_type)) {
            /* check for defined asg */
   
            if (resolve_ext_opr(&r_opnd, FALSE, FALSE, FALSE,
                                &ok,
                                &exp_desc_l, &exp_desc_r)) {
   
               SH_IR_IDX(curr_stmt_sh_idx)    = OPND_IDX(r_opnd);
               SH_STMT_TYPE(curr_stmt_sh_idx) = Call_Stmt;
               goto CK_WHERE;
            }
            else if (exp_desc_r.type == Character ||
                     exp_desc_r.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *) &IR_OPND_R(ir_idx),
                                         &opnd_line, 
                                         &opnd_col);

               if (exp_desc_r.type == Character) {

                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx),
                                                         exp_desc_l.type_idx,
                                                         opnd_line,
                                                         opnd_col);
               exp_desc_r.type_idx    = exp_desc_l.type_idx;
               exp_desc_r.type        = exp_desc_l.type;
               exp_desc_r.linear_type = exp_desc_l.linear_type;
            }
         }
      
         IR_RANK(ir_idx) = exp_desc_l.rank;

         IR_TYPE_IDX(ir_idx)  = exp_desc_l.type_idx;

      }
      else if (result_type == Structure_Type      &&
               (exp_desc_l.rank == exp_desc_r.rank || 
                exp_desc_r.rank == 0)              &&
         compare_derived_types(exp_desc_l.type_idx, exp_desc_r.type_idx)) {
   

         if (resolve_ext_opr(&r_opnd, FALSE, FALSE, FALSE,
                             &ok,
                             &exp_desc_l, &exp_desc_r)) {
            SH_IR_IDX(curr_stmt_sh_idx)    = OPND_IDX(r_opnd);
            SH_STMT_TYPE(curr_stmt_sh_idx) = Call_Stmt;
         }
         else {
            IR_RANK(ir_idx) = exp_desc_l.rank;

            IR_TYPE_IDX(ir_idx) = exp_desc_l.type_idx;
         }
      }
      else if (resolve_ext_opr(&r_opnd, TRUE, FALSE, 
                               (result_type == Err_Res ||
                                (result_type == Structure_Type &&
                                 !compare_derived_types(exp_desc_l.type_idx, 
                                                        exp_desc_r.type_idx) )),
                               &ok,
                               &exp_desc_l, &exp_desc_r)) {

         SH_IR_IDX(curr_stmt_sh_idx)    = OPND_IDX(r_opnd);
         SH_STMT_TYPE(curr_stmt_sh_idx) = Call_Stmt;
      }
      else {
         ok = FALSE;
      }

      if (ok &&
          SH_STMT_TYPE(curr_stmt_sh_idx) != Call_Stmt &&
          exp_desc_l.type == Integer &&
          exp_desc_r.type == Real) {
      
         COPY_OPND(r_opnd, IR_OPND_R(ir_idx));
         look_for_real_div(&r_opnd);
         COPY_OPND(IR_OPND_R(ir_idx), r_opnd);
      }

# ifdef _TRANSFORM_CHAR_SEQUENCE
      if (ok &&
          SH_STMT_TYPE(curr_stmt_sh_idx) != Call_Stmt &&
          exp_desc_l.type == Structure &&
          ATT_CHAR_SEQ(TYP_IDX(exp_desc_l.type_idx))) {

         /* change character sequence assignment to character assignment */

         COPY_OPND(l_opnd, IR_OPND_L(ir_idx));
         transform_char_sequence_ref(&l_opnd, exp_desc_l.type_idx);
         COPY_OPND(IR_OPND_L(ir_idx), l_opnd);

         COPY_OPND(r_opnd, IR_OPND_R(ir_idx));
         transform_char_sequence_ref(&r_opnd, exp_desc_r.type_idx);
         COPY_OPND(IR_OPND_R(ir_idx), r_opnd);
      }
# endif

CK_WHERE:

      if (ok &&
          where_ir_idx > 0)   {

         /* we are in a where block */
         
         if (SH_STMT_TYPE(curr_stmt_sh_idx) == Call_Stmt &&
             ! ATP_ELEMENTAL(IR_IDX_L(ir_idx))) {
            PRINTMSG(line, 1638, Error, col);
            ok = FALSE;
         }
         else if (! check_where_conformance(&exp_desc_l)) {

            find_opnd_line_and_column((opnd_type *) &IR_OPND_L(ir_idx),
                                      &opnd_line,
                                      &opnd_col);
            PRINTMSG(opnd_line, 195, Error, opnd_col);
            ok = FALSE;
         }
                  
         if (ok) {
            /* set up list */
            change_asg_to_where(ir_idx);
         }
      }


      if (active_forall_sh_idx) {
         defer_stmt_expansion = FALSE;

         if (IR_OPR(ir_idx) != Call_Opr) {
            /* still an assignment */

            save_curr_stmt_sh_idx = curr_stmt_sh_idx;
            line = IR_LINE_NUM(ir_idx);
            col = IR_COL_NUM(ir_idx);

            forall_dependence = FALSE;
            check_dependence(&forall_dependence,
                             IR_OPND_L(ir_idx),
                             IR_OPND_R(ir_idx));

            if (forall_dependence) {

               /* take the type for the tmp from the lhs, */
               /* take the shape from the rhs */

               forall_exp_desc             = exp_desc_r;
               forall_exp_desc.type_idx    = exp_desc_l.type_idx;
               forall_exp_desc.type        = exp_desc_l.type;
               forall_exp_desc.linear_type = exp_desc_l.linear_type;

               if (exp_desc_l.type == Character) {
                  /* use the base attr's char type idx */

                  COPY_OPND(l_opnd, IR_OPND_L(ir_idx));
                  attr_idx = find_base_attr(&l_opnd, &opnd_line, &opnd_col);
                  forall_exp_desc.type_idx = ATD_TYPE_IDX(attr_idx);
                  forall_exp_desc.type = Character;
                  forall_exp_desc.linear_type = 
                                  TYP_LINEAR(forall_exp_desc.type_idx);
                  forall_exp_desc.char_len.fld = 
                                  TYP_FLD(ATD_TYPE_IDX(attr_idx));
                  forall_exp_desc.char_len.idx = 
                                  TYP_IDX(ATD_TYPE_IDX(attr_idx));
               }

               gen_forall_tmp(&forall_exp_desc, 
                              &forall_tmp_opnd, 
                              line, 
                              col, 
                              FALSE);

               asg_idx = gen_ir(OPND_FLD(forall_tmp_opnd), 
                                       OPND_IDX(forall_tmp_opnd),
                            Asg_Opr, forall_exp_desc.type_idx, line, col,
                                IR_FLD_R(ir_idx), IR_IDX_R(ir_idx));

               gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
               SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
               SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
               curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

               gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx);
   
               gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx);

               COPY_OPND(opnd, IR_OPND_R(asg_idx));
               process_deferred_functions(&opnd);
               COPY_OPND(IR_OPND_R(asg_idx), opnd);

               curr_stmt_sh_idx = save_curr_stmt_sh_idx;

               copy_subtree(&forall_tmp_opnd, &forall_tmp_opnd);
               COPY_OPND(IR_OPND_R(ir_idx), forall_tmp_opnd);
   
               gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx);
   
               gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx);
   
               COPY_OPND(opnd, IR_OPND_L(ir_idx));
               process_deferred_functions(&opnd);
               COPY_OPND(IR_OPND_L(ir_idx), opnd);
            }
            else {
               gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx);
   
               gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx);

               COPY_OPND(opnd, IR_OPND_R(ir_idx));
               process_deferred_functions(&opnd);
               COPY_OPND(IR_OPND_R(ir_idx), opnd);

               COPY_OPND(opnd, IR_OPND_L(ir_idx));
               process_deferred_functions(&opnd);
               COPY_OPND(IR_OPND_L(ir_idx), opnd);
            }
         }
         else {
            gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx);
 
            gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx);

            gen_opnd(&opnd, 
                     SH_IR_IDX(curr_stmt_sh_idx), 
                     IR_Tbl_Idx, 
                     line, 
                     col);
            process_deferred_functions(&opnd);
            SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(opnd);
         }
      }

#ifdef KEY /* Bug 6845 */
      /* TR15581 requires automatic deallocation and allocation during
       * assignment of scalar structure having allocatable components, but
       * does not require this during assignment of an allocatable array;
       * that's a F2003 feature (which requires more work, and study to figure
       * out how it interacts with 'where' and 'forall'.)
       *
       * Possible optimization would deallocate the allocatable components
       * in the target, bytewise copy the structure, and then allocate and
       * copy the allocatable components. For now, we do it one component
       * at a time.
       */
      int type_idx_l = exp_desc_l.type_idx;
      if (Structure == exp_desc_l.type &&
  ATT_ALLOCATABLE_CPNT(TYP_IDX(type_idx_l)) &&
  SH_STMT_TYPE(curr_stmt_sh_idx) == Assignment_Stmt &&
  IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Asg_Opr) {

  /* Change original assignment to "continue" (it might be labelled) */
  SH_STMT_TYPE(curr_stmt_sh_idx) = Continue_Stmt;
  int asg_ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
  SH_IR_IDX(curr_stmt_sh_idx) = NULL_IDX;

  /* Non-allocatable array whose element type is a structure containing
   * allocatable components */
  if (exp_desc_l.rank) {
    help_assign_array_of_structure(line, col, IR_IDX_L(asg_ir_idx),
      IR_FLD_L(asg_ir_idx), IR_IDX_R(asg_ir_idx), IR_FLD_R(asg_ir_idx));
  }

  else {
    help_assign_cpnts(line, col, exp_desc_l.type_idx,
      IR_IDX_L(asg_ir_idx), IR_FLD_L(asg_ir_idx), IR_IDX_R(asg_ir_idx),
      IR_FLD_R(asg_ir_idx));
  }
      }
#endif /* KEY Bug 6845 */

      /*
      Generate this label immediately prior to the assignment
      statement.   PDGCS will extract the information from
      this label and put it on the TOP OF LOOP label they
      create when they create the DO loop for this assignent statement.
      */
      if (IR_RANK(ir_idx) > 0) {
         label_idx = gen_internal_lbl(line);
         NTR_IR_TBL(idx);
         IR_OPR(idx)                 = Label_Opr;
         IR_TYPE_IDX(idx)            = TYPELESS_DEFAULT_TYPE;
         IR_LINE_NUM(idx)            = line;
         IR_COL_NUM(idx)             = col;
         IR_FLD_L(idx)               = AT_Tbl_Idx;
         IR_IDX_L(idx)               = label_idx;
         IR_COL_NUM_L(idx)           = col;
         IR_LINE_NUM_L(idx)          = line;
         AT_DEFINED(label_idx)       = TRUE;
         AT_REFERENCED(label_idx)    = Not_Referenced;
         ATL_TOP_OF_LOOP(label_idx)  = TRUE;
         ATL_INFORM_ONLY(label_idx)  = TRUE;

         gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
         SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
         SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = idx;
         ATL_DEF_STMT_IDX(label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
         set_directives_on_label(label_idx);
      }
   }
   else if (IR_OPR(ir_idx) == Ptr_Asg_Opr) {

      if (IR_FLD_R(ir_idx) == IR_Tbl_Idx &&
          IR_OPR(IR_IDX_R(ir_idx)) == Call_Opr &&
          IR_LIST_CNT_R(IR_IDX_R(ir_idx)) == 0 &&
          AT_IS_INTRIN(IR_IDX_L(IR_IDX_R(ir_idx))) &&
          (strcmp(AT_OBJ_NAME_PTR(IR_IDX_L(IR_IDX_R(ir_idx))), "NULL") == 0)) {

         NTR_IR_LIST_TBL(list_idx);
         attr_idx = find_base_attr(&(IR_OPND_L(ir_idx)), &line, &col);
         IL_FLD(list_idx) = AT_Tbl_Idx;
         IL_IDX(list_idx) = attr_idx;
         IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx);
         IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx);

         IR_IDX_R(IR_IDX_R(ir_idx)) = list_idx;
         IR_FLD_R(IR_IDX_R(ir_idx)) = IL_Tbl_Idx;
         IR_LIST_CNT_R(IR_IDX_R(ir_idx)) = 1; 
      }

      IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;

      xref_state = CIF_Symbol_Modification;
      COPY_OPND(l_opnd, IR_OPND_L(ir_idx));
      exp_desc_l.rank = 0;
      ok = expr_semantics(&l_opnd, &exp_desc_l);
      COPY_OPND(IR_OPND_L(ir_idx), l_opnd);

      if (! ok) {
         goto EXIT;
      }

      if (! exp_desc_l.pointer) {
         attr_idx = find_base_attr(&l_opnd, &line, &col);
         PRINTMSG(line, 417, Error, col);
         ok = FALSE;
      }
#ifdef KEY /* Bug 572 */
      /* An expression like "parameter_x%ptr_component_y" might be both a
       * pointer and a constant, and a constant is not allowed here. */
      if (exp_desc_l.constant) {
         PRINTMSG(line, 326, Error, col);
         ok = FALSE;
      }
#endif /* KEY Bug 572 */

#ifdef KEY /* Bug 14150 */
      ok &= check_for_legal_assignment_define(&l_opnd,
        IR_OPR(ir_idx) == Ptr_Asg_Opr);
#else /* KEY Bug 14150 */
      ok &= check_for_legal_define(&l_opnd);
#endif /* KEY Bug 14150 */

      attr_idx = find_base_attr(&l_opnd, &line, &col);

      if (attr_idx &&
          AT_OBJ_CLASS(attr_idx) == Data_Obj) {
         ATD_PTR_ASSIGNED(attr_idx) = TRUE;
      }

# ifdef _F_MINUS_MINUS
      /* prevent ptr asg to pointer component of co-array */

      if (ok &&
          dump_flags.f_minus_minus &&
          AT_OBJ_CLASS(attr_idx) == Data_Obj &&
          ATD_CLASS(attr_idx) == Struct_Component) {

         attr_idx = find_left_attr(&l_opnd);

         if (ATD_PE_ARRAY_IDX(attr_idx)) {

            PRINTMSG(line, 1572, Error, col);
         }
      }
# endif

      /* The pointer assignment statement really should have its own CIF stmt */
      /* but libcif did not want to add another value at this time.           */
      /* LRR    12 May 1994                 */

      if (cif_flags & MISC_RECS) {
         cif_stmt_type_rec(TRUE, CIF_Assignment_Stmt, statement_number); 
      } 

      xref_state = CIF_Symbol_Reference;
      COPY_OPND(r_opnd, IR_OPND_R(ir_idx));
      exp_desc_r.rank = 0;
#ifdef KEY /* Bug 572 */
      /* Pointer assignment definitely allows pointer on RHS */
      int save_constant_ptr_ok = constant_ptr_ok;
      constant_ptr_ok = TRUE;
#endif /* KEY Bug 572 */
      ok = expr_semantics(&r_opnd, &exp_desc_r)
                       && ok;
#ifdef KEY /* Bug 572 */
      constant_ptr_ok = save_constant_ptr_ok;
#endif /* KEY Bug 572 */
      COPY_OPND(IR_OPND_R(ir_idx), r_opnd);

      if (! ok) {
         goto EXIT;
      }

      if (OPND_FLD(r_opnd) == AT_Tbl_Idx) {
         
         if (AT_OBJ_CLASS(OPND_IDX(r_opnd)) == Data_Obj &&
             !ATD_POINTER(OPND_IDX(r_opnd)) && !ATD_TARGET(OPND_IDX(r_opnd)))  {
            PRINTMSG(OPND_LINE_NUM(r_opnd), 418, Error, OPND_COL_NUM(r_opnd));
            ok = FALSE;
         }

         if (AT_OBJ_CLASS(OPND_IDX(r_opnd)) == Data_Obj &&
             ATD_PURE(OPND_IDX(r_opnd))) {
            PRINTMSG(OPND_LINE_NUM(r_opnd), 1270, Error, OPND_COL_NUM(r_opnd),
                     AT_OBJ_NAME_PTR(OPND_IDX(r_opnd)),
                     ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure":"elemental");
            ok = FALSE;
         }
      }
      else if (OPND_FLD(r_opnd) == IR_Tbl_Idx) {
         
         if (IR_OPR(OPND_IDX(r_opnd)) == Call_Opr) {

            if (!ATD_POINTER(ATP_RSLT_IDX(IR_IDX_L(OPND_IDX(r_opnd))))) {
               PRINTMSG(IR_LINE_NUM_L(OPND_IDX(r_opnd)), 421, Error,
                        IR_COL_NUM_L(OPND_IDX(r_opnd)));
               ok = FALSE;
            }
         }
         else if (exp_desc_r.reference      ||
                  exp_desc_r.tmp_reference) {
            attr_idx = find_base_attr(&r_opnd, &line, &col);

            if (! exp_desc_r.pointer && ! exp_desc_r.target) {
               PRINTMSG(line, 418, Error, col);
               ok = FALSE;
            }
            else {
               if (exp_desc_r.rank != 0) {

                  /* check for IL_VECTOR_SUBSCRIPT */

                  if (exp_desc_r.vector_subscript) {

                     /* might want to find a more correct position */

                     PRINTMSG(IR_LINE_NUM(OPND_IDX(r_opnd)), 420, Error,
                              IR_COL_NUM(OPND_IDX(r_opnd)));
                     ok = FALSE;
                  }
               }

               if (IR_OPR(OPND_IDX(r_opnd)) == Dv_Deref_Opr &&
                   IR_FLD_L(OPND_IDX(r_opnd)) == AT_Tbl_Idx &&
                   AT_OBJ_CLASS(IR_IDX_L(OPND_IDX(r_opnd))) == Data_Obj &&
                   ATD_PURE(IR_IDX_L(OPND_IDX(r_opnd)))) {
                  ok = FALSE;
                  PRINTMSG(IR_COL_NUM_L(OPND_IDX(r_opnd)), 1270, Error,
                           IR_COL_NUM_L(OPND_IDX(r_opnd)),
                           AT_OBJ_NAME_PTR(IR_IDX_L(OPND_IDX(r_opnd))),
                           ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ?
                                    "pure" : "elemental");
               }
               else {

                  if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)){
                     find_opnd_line_and_column(&r_opnd, &opnd_line, &opnd_col);
                     ok = FALSE;
                     PRINTMSG(opnd_line, 1270, Error, opnd_col,
                              AT_OBJ_NAME_PTR(attr_idx),
                              ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ?
                                       "pure" : "elemental");
                  }
               }
            }
         }
         else { /* an expression other than a call .. error */
            find_opnd_line_and_column(&r_opnd, &opnd_line, &opnd_col);
            PRINTMSG(opnd_line, 421, Error, opnd_col);
            ok = FALSE;
         }
      }
      else { /* error .. must be pointer .. assuming only constants here */
         find_opnd_line_and_column(&r_opnd, &opnd_line, &opnd_col);
         PRINTMSG(opnd_line, 418, Error, opnd_col);
         ok = FALSE;
      }

      if (ok) {

         if (exp_desc_r.rank   != exp_desc_l.rank) {
            /* rank error */
            PRINTMSG(IR_LINE_NUM(ir_idx), 431, Error, IR_COL_NUM(ir_idx));
            ok = FALSE;
         }

         if (exp_desc_r.type != exp_desc_l.type ||
             (exp_desc_r.type == Structure &&
              !compare_derived_types(exp_desc_r.type_idx,exp_desc_l.type_idx))){
            r_err_word[0] = '\0';
            l_err_word[0] = '\0';

            strcat(r_err_word, get_basic_type_str(exp_desc_r.type_idx));

            strcat(l_err_word, get_basic_type_str(exp_desc_l.type_idx));

            PRINTMSG(IR_LINE_NUM(ir_idx), 432, Error,
                     IR_COL_NUM(ir_idx),
                     r_err_word,
                     l_err_word);
            ok = FALSE;
         }

         if (exp_desc_r.type == exp_desc_l.type &&
             exp_desc_r.type != Character       &&
             exp_desc_r.type != Structure       &&
             exp_desc_r.linear_type != exp_desc_l.linear_type) {

            PRINTMSG(IR_LINE_NUM(ir_idx), 419, Error, IR_COL_NUM(ir_idx));
            ok = FALSE;
         }
         else if (exp_desc_r.type == exp_desc_l.type      &&
                  exp_desc_r.type == Character            &&
                  exp_desc_r.char_len.fld == CN_Tbl_Idx   &&
                  exp_desc_l.char_len.fld == CN_Tbl_Idx   &&
                  fold_relationals(exp_desc_r.char_len.idx,
                                   exp_desc_l.char_len.idx,
                                   Ne_Opr)) {

            PRINTMSG(IR_LINE_NUM(ir_idx), 853, Error, IR_COL_NUM(ir_idx));
            ok = FALSE;
         }
      }

      if (ok) {
            
         if (active_forall_sh_idx) {
            defer_stmt_expansion = FALSE;

            save_curr_stmt_sh_idx = curr_stmt_sh_idx;
            line = IR_LINE_NUM(ir_idx);
            col = IR_COL_NUM(ir_idx);

            forall_exp_desc = exp_desc_l;
            gen_forall_tmp(&forall_exp_desc, &forall_tmp_opnd, 
                           line, col, TRUE);

            copy_subtree(&forall_tmp_opnd, &forall_tmp_opnd_l);
            asg_idx = gen_ir(OPND_FLD(forall_tmp_opnd_l),
                                    OPND_IDX(forall_tmp_opnd_l),
                         Ptr_Asg_Opr, exp_desc_r.type_idx, line, col,
                             IR_FLD_R(ir_idx), IR_IDX_R(ir_idx));

            gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
            SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
            SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
            curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

            gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx);

            gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx);

            if (OPND_FLD(forall_tmp_opnd_l) == IR_Tbl_Idx) {
               if (IR_OPR(OPND_IDX(forall_tmp_opnd_l)) == Whole_Substring_Opr) {
                  COPY_OPND(forall_tmp_opnd_l,
                            IR_OPND_L(OPND_IDX(forall_tmp_opnd_l)));
               }

               if (IR_OPR(OPND_IDX(forall_tmp_opnd_l)) == Whole_Subscript_Opr) {
                  COPY_OPND(forall_tmp_opnd_l,
                            IR_OPND_L(OPND_IDX(forall_tmp_opnd_l)));
               }

               if (IR_OPR(OPND_IDX(forall_tmp_opnd_l)) == Dv_Deref_Opr) {
                  COPY_OPND(forall_tmp_opnd_l,
                            IR_OPND_L(OPND_IDX(forall_tmp_opnd_l)));
               }
            }

            copy_subtree(&forall_tmp_opnd_l, &forall_tmp_opnd_l);

            attr_idx = find_base_attr(&forall_tmp_opnd_l,&opnd_line,&opnd_col);

            gen_dv_whole_def_init(&forall_tmp_opnd_l,
                                  attr_idx,
                                  Before);

            COPY_OPND(opnd, IR_OPND_R(asg_idx));
            process_deferred_functions(&opnd);
            COPY_OPND(IR_OPND_R(asg_idx), opnd);

            lower_ptr_asg(&exp_desc_r);

            curr_stmt_sh_idx = save_curr_stmt_sh_idx;

            COPY_OPND(IR_OPND_R(ir_idx), forall_tmp_opnd);

            gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx);

            gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx);

            COPY_OPND(opnd, IR_OPND_L(ir_idx));
            process_deferred_functions(&opnd);
            COPY_OPND(IR_OPND_L(ir_idx), opnd);

            lower_ptr_asg(&forall_exp_desc);
         }
         else {
            lower_ptr_asg(&exp_desc_r);
         }
      }
   }

EXIT: 

   defer_stmt_expansion = FALSE;

   TRACE (Func_Exit, "assignment_stmt_semantics", NULL);

   return;

}  /* assignment_stmt_semantics */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  <description>                   *|
|*                        *|
|* Input parameters:                    *|
|*  NONE                      *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static void lower_ptr_asg(expr_arg_type *exp_desc_r)

{
   int      ir_idx;
   opnd_type    l_opnd;
   opnd_type    r_opnd;
   int      sh_idx;

   TRACE (Func_Entry, "lower_ptr_asg", NULL);

   ir_idx = SH_IR_IDX(curr_stmt_sh_idx);

   if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
      if (IR_OPR(IR_IDX_L(ir_idx)) == Whole_Substring_Opr) {
         COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx)));
      }

      if (IR_OPR(IR_IDX_L(ir_idx)) == Whole_Subscript_Opr) {
         COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx)));
      }

      if (IR_OPR(IR_IDX_L(ir_idx)) == Dv_Deref_Opr) {
         COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx)));
      }
   }
   else {
# ifdef _DEBUG
      print_ir(ir_idx);
# endif
      PRINTMSG(IR_LINE_NUM(ir_idx), 973, Internal,
               IR_COL_NUM(ir_idx));
   }

   /* do the stmt thing here */

   COPY_OPND(l_opnd, IR_OPND_L(ir_idx));
   COPY_OPND(r_opnd, IR_OPND_R(ir_idx));

   if (exp_desc_r->pointer || exp_desc_r->allocatable) {
      sh_idx = curr_stmt_sh_idx;
      ptr_assign_from_ptr(&l_opnd, &r_opnd);

      /* Remove the pointer assignment SH unless it is labeled.  If  */
      /* it was labeled, just turn it into a compiler-generated      */
      /* CONTINUE so the SH index in the Label_Def SH remains        */
      /* correct.                                               */

      if (SH_LABELED(sh_idx)) {

# ifdef _DEBUG
         if (IR_OPR(SH_IR_IDX(sh_idx)) != Ptr_Asg_Opr) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 974, Internal,
                     IR_COL_NUM(ir_idx));
         }
# endif

         SH_STMT_TYPE(sh_idx)    = Continue_Stmt;
         SH_IR_IDX(sh_idx)       = NULL_IDX;
         SH_COMPILER_GEN(sh_idx) = TRUE;


         /* If the pointer assignment stmt is also a loop termination*/
         /* stmt, copy the loop end info to the current assignment   */
         /* SH (for Dv_Set_P_Or_A).                                     */

         if (SH_LOOP_END(sh_idx)) {
            SH_LOOP_END(curr_stmt_sh_idx) = TRUE;
            SH_PARENT_BLK_IDX(curr_stmt_sh_idx) =
               SH_PARENT_BLK_IDX(sh_idx);
         }
      }
      else {

# ifdef _DEBUG
         if (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) != Ptr_Asg_Opr) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 974, Internal,
                     IR_COL_NUM(ir_idx));
         }
# endif

         remove_sh(curr_stmt_sh_idx);
         curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
      }
   }
   else if (exp_desc_r->target) {
      dope_vector_setup(&r_opnd, exp_desc_r, &l_opnd, TRUE);
   }

   TRACE (Func_Exit, "lower_ptr_asg", NULL);

   return;

}  /* lower_ptr_asg */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This routine is the wrapper for expr_sem. It will fold any aggregate  *|
|*      expression that are returned by expr_sem().                           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

boolean expr_semantics (opnd_type       *result_opnd,
                        expr_arg_type   *exp_desc)
#ifdef KEY /* Bug 934 */
{
  return expr_semantics_d(result_opnd, exp_desc, FALSE);
}

/*
 * Like expr_semantics(), but capable of passing along the knowledge that
 * we're dealing with the RHS of an assignment of an entire derived type.
 */
static boolean expr_semantics_d (opnd_type     *result_opnd,
                        expr_arg_type   *exp_desc,
      boolean   derived_assign)
#endif /* KEY Bug 934 */

{
   boolean        ok = TRUE;
   opnd_type      opnd;
   boolean              save_check_type_conversion;
   int                  save_target_array_idx;
   opnd_type            save_init_target_opnd;
   int      save_target_char_len_idx;
   int                  save_target_type_idx;


   TRACE (Func_Entry, "expr_semantics", NULL);

   save_check_type_conversion   = check_type_conversion;
   save_target_array_idx        = target_array_idx;
   COPY_OPND(save_init_target_opnd, init_target_opnd);
   save_target_char_len_idx     = target_char_len_idx;
   save_target_type_idx         = target_type_idx;

   check_type_conversion        = FALSE;
   target_array_idx             = NULL_IDX;
   init_target_opnd   = null_opnd;

   target_char_len_idx          = NULL_IDX;
   target_type_idx              = NULL_IDX;

#ifdef KEY /* Bug 934 */
   ok = expr_sem_d(result_opnd, exp_desc, derived_assign);
#else /* KEY Bug 934 */
   ok = expr_sem(result_opnd, exp_desc);
#endif /* KEY Bug 934 */

   check_type_conversion        = save_check_type_conversion;
   target_array_idx             = save_target_array_idx;
   COPY_OPND(init_target_opnd, save_init_target_opnd);
   target_char_len_idx          = save_target_char_len_idx;
   target_type_idx              = save_target_type_idx;

   if (ok                            &&
       exp_desc->foldable            &&
       ((OPND_FLD((*result_opnd)) != CN_Tbl_Idx &&
         OPND_FLD((*result_opnd)) != AT_Tbl_Idx &&
         (OPND_FLD((*result_opnd)) != IR_Tbl_Idx ||
          (IR_OPR(OPND_IDX((*result_opnd))) != Whole_Subscript_Opr &&
           (IR_OPR(OPND_IDX((*result_opnd))) != Whole_Substring_Opr ||
            IR_FLD_L(OPND_IDX((*result_opnd))) != IR_Tbl_Idx ||
            IR_OPR(IR_IDX_L(OPND_IDX((*result_opnd)))) !=
                                                    Whole_Subscript_Opr)))) ||
        check_type_conversion == TRUE ||
        OPND_FLD(init_target_opnd) != NO_Tbl_Idx ||
        target_array_idx != NULL_IDX)) {

      COPY_OPND(opnd, (*result_opnd));
      ok = fold_aggragate_expression(&opnd, exp_desc, FALSE) && ok;
      COPY_OPND((*result_opnd), opnd);
   }

   TRACE (Func_Exit, "expr_semantics", NULL);

   return(ok);

}  /* expr_semantics */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*   Expr_semantics is the main expression semantics checker. It works        *|
|*   recursively to process the entire subtree it is called with.             *|
|*   Expr_semantics should be called for all references and expressions       *|
|*   that require attr_link and type resolution.                              *|
|*   It does other things too.                                                *|
|*      1. All attr indexes are resolved to the ultimate attr in an attr_link *|
|*         chain. Type, rank and other stuff is propagated up the call chain. *|
|*      2. Semantic checks (type, rank etc) are done on all numeric operators *|
|*         and information is propagated up.                                  *|
|*      3. Folding is done for constant operands of some operators.           *|
|*      4. Function calls are pulled out of expressions and replaced with     *|
|*         temps.                                                             *|
|*      5. Ambiguous array refs or other blah() formations are possibly       *|
|*         changed to function calls.                                         *|
|*      6. Subscript oprs are inserted over whole array references.           *|
|*      7. Substring Oprs are inserted over character variable refs that      *|
|*         weren't substringed by the user.                                   *|
|*      8. Calls to resolve_ext_opr check for overloaded operators.           *|
|*      9. Calls to call_list_semantics check for generic interface calls     *|
|*         and do actual argument semantic checks. (back through here)        *|
|*     10. Allocate and deallocate objects are semantically checked here.     *|
|*     11. Other minor things.                                                *|
|*                        *|
|* Input parameters:                    *|
|*  result_opnd - operand to examine.                                     *|
|*      exp_desc    - exp_arg_type (declared in sytb.h)                       *|
|*                    This is used to propagate information up the call chain *|
|*                    and some information down the chain.                    *|
|*                                                                            *|
|*               exp_desc is declared as follows ...                          *|
|*      struct  expr_semantics_args    {                                      *|
|*                                                                            *|
|*           basic type of subtree  -> basic_type_type   type            : 8; *|
|*           linear type            -> linear_type_type  linear_type     : 8; *|
|*           type index of subtree  -> Uint              type_idx        : 16;*|
|*                                                                            *|
|*           unused                 -> Uint              UNUSED1         : 5; *|
|*           rank of subtree        -> Uint              rank            : 8; *|
|*           subtree is a constant  -> boolean           constant        : 1; *|
|*           subtree is foldable now-> boolean           foldable        : 1; *|
|*                                                                            *|
|*           subtree involves a constant                                      *|
|*           value implied do lcv but will                                    *|
|*           fold when its replaced -> boolean           will_fold_later : 1; *|
|*           has pointer attribute  -> boolean           pointer         : 1; *|
|*           has target attribute   -> boolean           target          : 1; *|
|*           vector subscript ref   -> boolean           vector_subscript: 1; *|
|*           is a data obj ref      -> boolean           reference       : 1; *|
|*           ref is a constructor   -> boolean           constructor     : 1; *|
|*           structure subobject    -> boolean           component       : 1; *|
|*           array section ref      -> boolean           section         : 1; *|
|*           tree is a label ref    -> boolean           label           : 1; *|
|*           tree is array element  -> boolean           array_elt       : 1; *|
|*           whole assumed shape    -> boolean           assumed_shape   : 1; *|
|*           whole assumed size     -> boolean           assumed_size    : 1; *|
|*           allocatable array ref  -> boolean           allocatable     : 1; *|
|*           ref is dope vector     -> boolean           dope_vector     : 1; *|
|*           reference to tmp       -> boolean           tmp_reference   : 1; *|
|*           tree has constructor   -> boolean           has_constructor : 1; *|
|*           optional dummy ref     -> boolean           optional_darg   : 1; *|
|*           expr contains a        -> boolean           has_symbolic    : 1; *|
|*                sybolic constant                                            *|
|*                                                                            *|
|*           unused                 -> Uint              UNUSED2         : 32;*|
|*                                                                            *|
|*           unused                 -> Uint              UNUSED3         : 8; *|
|*           cif id for ref         -> Uint              cif_id          : 24;*|
|*                                                                            *|
|*                                                                            *|
|*           character length       -> opnd_type         char_len;            *|
|*           shape of subtree       -> opnd_type         shape[7];            *|
|*                                     };                                     *|
|*                                                                            *|
|*                                                                            *|
|*               reference means that subtree describes a data object         *|
|*               reference, and is not an expression.                         *|
|*               Most of these flags are for special use and any questions    *|
|*               about specific behavior should be directed to the developer. *|
|*                                                                            *|
|*   =========>  RANK MUST BE SET TO ZERO BEFORE CALLING THIS ROUTINE!!!!!    *|
|*                                                                            *|
|*               The exp_desc->rank variable is used to propagate the rank    *|
|*               of a part-ref to the rest of the reference tree and so is    *|
|*               used to pass information down the call chain. This is to     *|
|*               catch that wonderful constraint that a pointer subobject     *|
|*               cannot have a part-ref to the left that has rank > 0.        *|
|*                                                                            *|
|*               Always copy your operand to a local variable of type         *|
|*               opnd_type before the call to expr_semantics and copy the     *|
|*               returned opnd back to your original. This is because tables  *|
|*               may be realloc'ed and moved.                                 *|
|*                                                                            *|
|*               Use the information from the exp_desc structure if you want  *|
|*               things like type, type_idx, rank ... when you don't care     *|
|*               the tree actually looks like. Constant and reference are     *|
|*               also handy to quickly see what type of subtree you have.     *|
|*                        *|
|* Output parameters:                   *|
|*  result_opnd - output opnd_type                                        *|
|*      exp_desc    - the expression descriptor (see above) that describes    *|
|*                    the result tree.                                        *|
|*                        *|
|* Returns:                     *|
|*      TRUE if no semantic errors.                                           *|
|*      FALSE if errors were issued or if an attr with AT_DCL_ERR was found.  *|
|*                        *|
\******************************************************************************/

boolean expr_sem (opnd_type       *result_opnd,
                  expr_arg_type   *exp_desc)
#ifdef KEY /* Bug 934 */
{
  return expr_sem_d(result_opnd, exp_desc, FALSE);
}

/*
 * Like expr_sem(), but capable of passing in the knowledge that we're dealing
 * with the RHS of an assignment of an entire derived type.
 */
static boolean expr_sem_d(opnd_type      *result_opnd,
                  expr_arg_type   *exp_desc,
      boolean   derived_assign)
#endif /* KEY Bug 934 */

{
   int                 al_list_idx;
   int                 attr_idx;
   int           col;
   int                 dv_idx;
   expr_arg_type       exp_desc_l;
   expr_arg_type       exp_desc_r;
   boolean         host_associated;
   int                 ir_idx   = NULL_IDX;
   int           line;
   int           list_idx;
#ifdef KEY /* Bug 10177 */
   int                 msg_num = 0;
#else /* KEY Bug 10177 */
   int                 msg_num;
#endif /* KEY Bug 10177 */
   opnd_type         opnd;
   int           rank_in;
   boolean             junk;
   boolean         save_in_call_list;
   boolean         save_in_constructor;
   boolean         save_no_sub_or_deref;
   boolean             save_insert_subs_ok;
   boolean             ok = TRUE;


   TRACE (Func_Entry, "expr_sem", NULL);

   /* these are here to initialize so that cases that are incomplete */
   /* do not return wierd stuff.                                     */

   rank_in      = exp_desc->rank;
   (*exp_desc)      = init_exp_desc;
#ifdef KEY /* Bug 934 */
   exp_desc->derived_assign = derived_assign;
#endif /* KEY Bug 934 */
   exp_desc->linear_type  = TYPELESS_DEFAULT_TYPE;
   exp_desc->type_idx   = TYPELESS_DEFAULT_TYPE;

   find_opnd_line_and_column(result_opnd, &line, &col);

   switch (OPND_FLD((*result_opnd))) {

      case NO_Tbl_Idx :
         break;

      case CN_Tbl_Idx:

         exp_desc->type_idx = CN_TYPE_IDX(OPND_IDX((*result_opnd)));
         exp_desc->type   = TYP_TYPE(exp_desc->type_idx);
         exp_desc->linear_type  = TYP_LINEAR(exp_desc->type_idx);

         if (exp_desc->type == Character) {
            exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx);
            exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx);
            OPND_LINE_NUM(exp_desc->char_len) = line;
            OPND_COL_NUM(exp_desc->char_len) = col;
         }

         if (exp_desc->type == Character                             &&
            compare_cn_and_value(TYP_IDX(exp_desc->type_idx),
                                 MAX_CHARS_IN_TYPELESS, 
                                 Le_Opr)) {
            exp_desc->linear_type = Short_Char_Const;
         }
                  
         exp_desc->rank        = 0;
         exp_desc->constant    = TRUE;
         exp_desc->foldable    = TRUE;
         exp_desc->will_fold_later = TRUE;
         break;

      case AT_Tbl_Idx  :

         attr_idx   = OPND_IDX((*result_opnd));
         AT_LOCKED_IN(attr_idx) = TRUE;
         host_associated  = FALSE;



         if (expr_mode == Restricted_Imp_Do_Expr) {

            if (in_implied_do               &&
                AT_OBJ_CLASS(attr_idx) == Data_Obj) {

               while (AT_ATTR_LINK(attr_idx) &&
                      ! AT_IGNORE_ATTR_LINK(attr_idx)) {
                  attr_idx                 = AT_ATTR_LINK(attr_idx);
                  AT_LOCKED_IN(attr_idx)   = TRUE;
                  host_associated          = TRUE;
               }

               if (AT_ATTR_LINK(attr_idx)) {
                  attr_idx                 = AT_ATTR_LINK(attr_idx);
                  AT_LOCKED_IN(attr_idx)   = TRUE;
               }
            }
            else {

               while (AT_ATTR_LINK(attr_idx)           &&
                      ! AT_IGNORE_ATTR_LINK(attr_idx)) {

                  if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
                      ATD_IMP_DO_LCV(attr_idx)) {
                     break;
                  }
              
                  attr_idx = AT_ATTR_LINK(attr_idx);
                  AT_LOCKED_IN(attr_idx) = TRUE;
               }
            }

            if (AT_NOT_VISIBLE(attr_idx)) {
               PRINTMSG(line, 486, Error,
                        col,
                        AT_OBJ_NAME_PTR(attr_idx),
                        AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx))));
               ok = FALSE;
               break;
            }

            if (! AT_DCL_ERR(attr_idx)) {

               if (AT_OBJ_CLASS(attr_idx) != Data_Obj           ||
                   (ATD_CLASS(attr_idx) != Constant          &&
                    ATD_CLASS(attr_idx) != Struct_Component  &&
                    ! ATD_IMP_DO_LCV(attr_idx))) {
                  OPND_IDX((*result_opnd)) = attr_idx;
                  PRINTMSG(line, 658, Error, col, AT_OBJ_NAME_PTR(attr_idx));
                  ok = FALSE;
                  break;
               }
            }
         }
         else if (in_implied_do               &&
                  AT_OBJ_CLASS(attr_idx) == Data_Obj) {

            while (AT_ATTR_LINK(attr_idx)           &&
                   ! AT_IGNORE_ATTR_LINK(attr_idx)) {
               attr_idx                 = AT_ATTR_LINK(attr_idx);
               AT_LOCKED_IN(attr_idx)   = TRUE;
               host_associated          = TRUE;
            }

            if (AT_ATTR_LINK(attr_idx)) {
               attr_idx                 = AT_ATTR_LINK(attr_idx);
               AT_LOCKED_IN(attr_idx)   = TRUE;
            }


            if (ATD_IMP_DO_LCV(attr_idx) &&
                constructor_level > ATD_TMP_IDX(attr_idx)) {
               constructor_level = ATD_TMP_IDX(attr_idx);
            }
         }
         else {
            while (AT_ATTR_LINK(attr_idx)           &&
                   ! AT_IGNORE_ATTR_LINK(attr_idx)) {

               attr_idx     = AT_ATTR_LINK(attr_idx);
               AT_LOCKED_IN(attr_idx) = TRUE;
               host_associated    = TRUE;
            }

            if (AT_ATTR_LINK(attr_idx) &&
                AT_OBJ_CLASS(AT_ATTR_LINK(attr_idx)) == Data_Obj &&
                ATD_FORALL_INDEX(AT_ATTR_LINK(attr_idx))) {

               attr_idx                 = AT_ATTR_LINK(attr_idx);
               AT_LOCKED_IN(attr_idx)   = TRUE;
            }
         }

         if (AT_NOT_VISIBLE(attr_idx)) {
            PRINTMSG(line, 486, Error,
                     col,
                     AT_OBJ_NAME_PTR(attr_idx),
                     AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx))));
            ok = FALSE;
            break; 
         }

         if (expr_mode == Data_Stmt_Target_Expr &&
             (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
              (ATD_CLASS(attr_idx) != Constant &&
               ATD_CLASS(attr_idx) != Struct_Component))) {

            PRINTMSG(line, 705, Error, col, AT_OBJ_NAME_PTR(attr_idx));
            ok = FALSE;
         }

         OPND_IDX((*result_opnd)) = attr_idx;

         if (! in_component_ref              &&
             (cif_flags & XREF_RECS) != 0    &&
             (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
              ATD_CLASS(attr_idx) != Dummy_Argument ||
              ! ATD_PARENT_OBJECT(attr_idx) ||
              ! ATD_SF_DARG(attr_idx)) &&
             xref_state != CIF_No_Usage_Rec) {

            if (in_call_list) { /* output CIF_Symbol_Is_Actual_Arg */
               cif_usage_rec(attr_idx, AT_Tbl_Idx, line, col, 
                             CIF_Symbol_Is_Actual_Arg);
            }
            else { /* output according xref_state */
               cif_usage_rec(attr_idx, AT_Tbl_Idx, line, col, xref_state);
             }
         }

         exp_desc->cif_id = AT_CIF_SYMBOL_ID(attr_idx);

         if (AT_DCL_ERR(attr_idx)) {      /* just quit */
            ok = FALSE;
         }

         if (AT_OPTIONAL(attr_idx)) {
            exp_desc->optional_darg = TRUE;
         }

         switch (AT_OBJ_CLASS(attr_idx)) {

         case Data_Obj:

            if (ATD_CLASS(attr_idx) == Dummy_Argument &&
                ATD_COPY_ASSUMED_SHAPE(attr_idx) &&
                ATD_SF_ARG_IDX(attr_idx) != NULL_IDX) {

               attr_idx = ATD_SF_ARG_IDX(attr_idx);
               OPND_IDX((*result_opnd)) = attr_idx;
            }
# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
# if 0
            else if (ATD_CLASS(attr_idx) == Dummy_Argument &&
                     ATD_ARRAY_IDX(attr_idx) &&
                     BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx))==Assumed_Shape &&
                     ATD_SF_ARG_IDX(attr_idx) != NULL_IDX) {

               attr_idx = ATD_SF_ARG_IDX(attr_idx);
               OPND_IDX((*result_opnd)) = attr_idx;
            }
# endif
# endif


            exp_desc->type_idx  = ATD_TYPE_IDX(attr_idx);
            exp_desc->type  = TYP_TYPE(exp_desc->type_idx);
            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);

            if (ATD_PURE(attr_idx) && 
#ifdef KEY /* Bug 934 */
    /* This constraint only applies when assigning an entire
     * derived type. Note that it's one of the areas where
     * "allocatable" and "pointer" behave differently. */
                exp_desc->derived_assign &&
#endif /* KEY Bug 934 */
                stmt_type == Assignment_Stmt &&
                exp_desc->type == Structure &&
                ATT_POINTER_CPNT(TYP_IDX(exp_desc->type_idx))) {
               ok = FALSE;
               PRINTMSG(line, 1270, Error, col, AT_OBJ_NAME_PTR(attr_idx),
                        ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ?
                        "pure":"elemental");
            }

            if (exp_desc->type == Character) {
               if (!TYP_RESOLVED(ATD_TYPE_IDX(attr_idx))) {
                  char_bounds_resolution(attr_idx, &junk);
                  exp_desc->type_idx = ATD_TYPE_IDX(attr_idx);
               }

# if defined(_EXTENDED_CRI_CHAR_POINTER)
               if (TYP_FLD(exp_desc->type_idx) == AT_Tbl_Idx &&
                   AT_OBJ_CLASS(TYP_IDX(exp_desc->type_idx)) == Data_Obj &&
                   TYP_TYPE(ATD_TYPE_IDX(TYP_IDX(exp_desc->type_idx))) == 
                                                                  CRI_Ch_Ptr) {

                  NTR_IR_TBL(ir_idx);
                  IR_OPR(ir_idx) = Clen_Opr;
                  IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE;
                  IR_LINE_NUM(ir_idx) = line;
                  IR_COL_NUM(ir_idx) = col;
                  IR_FLD_L(ir_idx) = AT_Tbl_Idx;
                  IR_IDX_L(ir_idx) = attr_idx;
                  IR_LINE_NUM_L(ir_idx) = line;
                  IR_COL_NUM_L(ir_idx) = col;

                  exp_desc->char_len.fld = IR_Tbl_Idx;
                  exp_desc->char_len.idx = ir_idx;
               }
               else {
                  exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx);
                  exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx);
                  OPND_LINE_NUM(exp_desc->char_len) = line;
                  OPND_COL_NUM(exp_desc->char_len) = col;
               }
# else
               exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx);
               exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx);
               OPND_LINE_NUM(exp_desc->char_len) = line;
               OPND_COL_NUM(exp_desc->char_len) = col;
# endif

               if (TYP_FLD(exp_desc->type_idx) == AT_Tbl_Idx) {
                  ADD_TMP_TO_SHARED_LIST(TYP_IDX(exp_desc->type_idx));
               }

               if (ATD_CLASS(attr_idx) == Constant &&
                   compare_cn_and_value(TYP_IDX(exp_desc->type_idx),
                                        MAX_CHARS_IN_TYPELESS,
                                        Le_Opr)) {
                  exp_desc->linear_type = Short_Char_Const;
               }
            }

            exp_desc->pointer     = ATD_POINTER(attr_idx);
            exp_desc->target      = ATD_TARGET(attr_idx);
            exp_desc->allocatable = ATD_ALLOCATABLE(attr_idx);
            exp_desc->dope_vector = ATD_IM_A_DOPE(attr_idx);

            if (ATD_POINTER(attr_idx) && rank_in != 0) {
               ok = FALSE;
               PRINTMSG(line, 408, Error, col);
            }

            if (cdir_switches.parallel_region       &&
                ATD_CLASS(attr_idx) != Struct_Component    &&
                ATD_CLASS(attr_idx) != Constant     &&
                ATD_CLASS(attr_idx) != Compiler_Tmp &&
                ATD_CLASS(attr_idx) != CRI__Pointee &&
                (ATD_CLASS(attr_idx) != Dummy_Argument ||
                 ! ATD_SF_DARG(attr_idx))           &&
                ! cdir_switches.autoscope           &&
#ifdef KEY /* Bug 8287 */
                SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) != Threadprivate &&
#endif /* KEY Bug 8287 */
                ! ATD_TASK_PRIVATE(attr_idx)        &&
                ! ATD_TASK_GETFIRST(attr_idx)       &&
                ! ATD_TASK_LASTLOCAL(attr_idx)      &&
                ! ATD_TASK_REDUCTION(attr_idx)      &&
                ! ATD_TASK_LASTTHREAD(attr_idx)     &&
                ! ATD_TASK_FIRSTPRIVATE(attr_idx)   &&
                ! ATD_TASK_COPYIN(attr_idx)         &&
                ! ATD_TASK_LASTPRIVATE(attr_idx)    &&
                ! ATD_TASK_SHARED(attr_idx))        {


               if (dump_flags.open_mp &&
                   OPND_FLD(cdir_switches.first_sh_blk_stk) == IL_Tbl_Idx) {
                   /* this means that we are in some sort of openmp region */
                   /* rather than a cmic region.                           */

                  if (cdir_switches.default_scope_list_idx != NULL_IDX &&
                      CN_INT_TO_C(IL_IDX(cdir_switches.default_scope_list_idx))
                                   == OPEN_MP_DEFAULT_NONE) {

                     PRINTMSG(line, 1510, Error, col,
                              AT_OBJ_NAME_PTR(attr_idx));
                     ok = FALSE;
                     /* add it to the shared list to prevent */
                     /* further errors.                      */
                     ADD_VAR_TO_SHARED_LIST(attr_idx);
                  }
               }
               else if (dump_flags.mp) {

# if 0
                  if (processing_do_var) {
                     /* do vars are scope private, by default */

                     ADD_VAR_TO_PRIVATE_LIST(attr_idx);
                  }
                  else {
                     ADD_VAR_TO_SHARED_LIST(attr_idx);
                  }
# endif
               }
               else {

                  if (processing_do_var) {
                     PRINTMSG(line, 1509, Error, col, 
                              AT_OBJ_NAME_PTR(attr_idx));
                     /* add it to the private list to prevent */
                     /* further errors.                       */
                     ADD_VAR_TO_PRIVATE_LIST(attr_idx);
                  }
                  else {
                     PRINTMSG(line, 960, Error, col, 
                              AT_OBJ_NAME_PTR(attr_idx));
                     /* add it to the shared list to prevent */
                     /* further errors.                      */
                     ADD_VAR_TO_SHARED_LIST(attr_idx);
                  }
                  ok = FALSE;
               }
            }

            ADD_TMP_TO_SHARED_LIST(attr_idx);

            if (ATD_ARRAY_IDX(attr_idx)) {

               if (! BD_RESOLVED(ATD_ARRAY_IDX(attr_idx))) {
                  array_bounds_resolution(attr_idx, &junk);
               }

               exp_desc->assumed_shape = 
                   (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape);
               exp_desc->assumed_size  = 
                   (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Size);

               exp_desc->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx));
               get_shape_from_attr(exp_desc,
                                   attr_idx,
                                   exp_desc->rank,
                                   line,
                                   col);

               /* set contig_array to TRUE even if it is a POINTER */
               /* The a_contig flag in the dope vector will be     */
               /* checked to see if copy in/out is needed.         */

               exp_desc->contig_array = TRUE;
            }

            if (ATD_DISTRIBUTION_IDX(attr_idx) != NULL_IDX &&
                BD_DISTRIBUTE_RESHAPE(ATD_DISTRIBUTION_IDX(attr_idx))) {

               exp_desc->dist_reshape_ref = TRUE;
            }

            if (ATD_IM_A_DOPE(attr_idx) &&
                ! no_sub_or_deref) {

               /* DO NOT SET IR_RANK(dv_idx) */
               /* IT MUST BE ZERO HERE.      */

               NTR_IR_TBL(dv_idx);
               IR_OPR(dv_idx)           = Dv_Deref_Opr;
               IR_LINE_NUM(dv_idx)      = OPND_LINE_NUM((*result_opnd));
               IR_COL_NUM(dv_idx)       = OPND_COL_NUM((*result_opnd));

               IR_TYPE_IDX(dv_idx)  = exp_desc->type_idx;
               IR_FLD_L(dv_idx)         = OPND_FLD((*result_opnd));
               IR_IDX_L(dv_idx)         = OPND_IDX((*result_opnd));
               IR_LINE_NUM_L(dv_idx)    = OPND_LINE_NUM((*result_opnd));
               IR_COL_NUM_L(dv_idx)     = OPND_COL_NUM((*result_opnd));
               OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
               OPND_IDX((*result_opnd)) = dv_idx;
            }

            if (ATD_CLASS(attr_idx) == Constant) {
               exp_desc->constant = TRUE;
               exp_desc->foldable = TRUE;
               exp_desc->will_fold_later = TRUE;

               if (ATD_CONST_IDX(attr_idx) == NULL_IDX) {
                  exp_desc->constant = FALSE;
                  break;
               }

               OPND_IDX((*result_opnd)) = ATD_CONST_IDX(attr_idx);
               OPND_LINE_NUM((*result_opnd)) = line;
               OPND_COL_NUM((*result_opnd))  = col;

               if (ATD_FLD(attr_idx) == AT_Tbl_Idx) {
                  OPND_FLD((*result_opnd)) = AT_Tbl_Idx;

                  ADD_TMP_TO_SHARED_LIST(ATD_CONST_IDX(attr_idx));

                  if (insert_subs_ok &&
                      ! no_sub_or_deref) {

# if defined(_TARGET_OS_MAX)
                     if (ATD_ARRAY_IDX(attr_idx) ||
                         ATD_PE_ARRAY_IDX(attr_idx))
# else
                     if (ATD_ARRAY_IDX(attr_idx))
# endif
                                                     {

                        ok &= gen_whole_subscript(result_opnd, exp_desc);
                     }
                     else if (exp_desc->type == Character) {
                        ok &= gen_whole_substring(result_opnd, 0);
                     }
                  }
               }
               else {
                  OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
               }
            }
            else if (ATD_CLASS(attr_idx) == Dummy_Argument &&
                     ATD_SF_DARG(attr_idx))           {

               OPND_FLD((*result_opnd))   = (fld_type) ATD_FLD(attr_idx);
               OPND_IDX((*result_opnd))   = ATD_SF_ARG_IDX(attr_idx);
               OPND_LINE_NUM((*result_opnd))  = line;
               OPND_COL_NUM((*result_opnd)) = col;

               (*exp_desc) = arg_info_list[ATD_SF_LINK(attr_idx)].ed;

               if (OPND_FLD((*result_opnd)) == AT_Tbl_Idx &&
                   AT_OBJ_CLASS(OPND_IDX((*result_opnd))) == Data_Obj &&
                   ATD_IM_A_DOPE(OPND_IDX((*result_opnd))) &&
                   ! no_sub_or_deref) {

                  /* DO NOT SET IR_RANK(dv_idx) */
                  /* IT MUST BE ZERO HERE.      */

                  NTR_IR_TBL(dv_idx);
                  IR_OPR(dv_idx)           = Dv_Deref_Opr;
                  IR_LINE_NUM(dv_idx)      = OPND_LINE_NUM((*result_opnd));
                  IR_COL_NUM(dv_idx)       = OPND_COL_NUM((*result_opnd));

                  IR_TYPE_IDX(dv_idx)      = exp_desc->type_idx;
                  COPY_OPND(IR_OPND_L(dv_idx), (*result_opnd));
                  OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
                  OPND_IDX((*result_opnd)) = dv_idx;
               }

               if (OPND_FLD((*result_opnd)) == AT_Tbl_Idx ||
                   (OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
                    (IR_OPR(OPND_IDX((*result_opnd))) == Dv_Deref_Opr ||
                     IR_OPR(OPND_IDX((*result_opnd))) == Struct_Opr))) {

                  if (insert_subs_ok &&
                      ! no_sub_or_deref) {

                     if (exp_desc->rank) {
                        ok &= gen_whole_subscript(result_opnd, exp_desc);
                     }
                     else if (exp_desc->type == Character) {
                        ok &= gen_whole_substring(result_opnd, 0);
                     }
                  }
               }
               break;
            }
            else { /* must be variable */

               if (ATD_LCV_IS_CONST(attr_idx)) {
                  exp_desc->will_fold_later = TRUE;
               }

               exp_desc->reference  = TRUE;
               exp_desc->has_symbolic = ATD_SYMBOLIC_CONSTANT(attr_idx);

               if (insert_subs_ok &&
                   ! no_sub_or_deref) {

# if defined(_TARGET_OS_MAX)
                  if (ATD_ARRAY_IDX(attr_idx) ||
                      ATD_PE_ARRAY_IDX(attr_idx))
# else
                  if (ATD_ARRAY_IDX(attr_idx))
# endif
                                                     {
                     ok &= gen_whole_subscript(result_opnd, exp_desc);
                  }
                  else if (exp_desc->type == Character) {
                     ok &= gen_whole_substring(result_opnd, 0);
                  }
               }
            }


            if (expr_mode == Specification_Expr) {

               /* Only call fnd_semantic_err if there is a problem, to     */
               /* keep things running fast.  There are some problems that  */
               /* fnd_semantic_err won't get.  Issue these msgs here.  To  */
               /* be legal, the data object must be a dummy argument (but  */
               /* not INTENT(OUT) or OPTIONAL), in common, a constant, or  */
               /* host or use associated.                                  */

               switch (ATD_CLASS(attr_idx)) {
               case Dummy_Argument:

                  if (AT_OPTIONAL(attr_idx) ||
                      TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == CRI_Ptr) {
                     fnd_semantic_err(Obj_Use_Spec_Expr,
                                      line,
                                      col,
                                      attr_idx,
                                      TRUE);
                     ok = FALSE;
                  }
                  else if (ATD_INTENT(attr_idx) == Intent_Out) {
                     PRINTMSG(line, 519, Error, col,
                              AT_OBJ_NAME_PTR(attr_idx));
                     ok = FALSE;
                  }
                  else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
                     PRINTMSG(line, 1439, Error, col,
                              AT_OBJ_NAME_PTR(attr_idx));
                     ok = FALSE;
                  }

                  if (AT_ALT_DARG(attr_idx)) {

                     /* This darg is not at all entry points.  Add to a  */
                     /* list for this specification expression.  This    */
                     /* only happens if there are alternate entry points */
                     /* and bounds expressions.                          */

                     al_list_idx = SCP_TMP_LIST(curr_scp_idx);

                     while (al_list_idx != NULL_IDX &&
                            attr_idx != AL_ATTR_IDX(al_list_idx)) {
                        al_list_idx = AL_NEXT_IDX(al_list_idx);
                     }

                     if (al_list_idx == NULL_IDX) { /* Not on list - add it*/
                        NTR_ATTR_LIST_TBL(al_list_idx);
                        AL_NEXT_IDX(al_list_idx) =SCP_TMP_LIST(curr_scp_idx);
                        AL_ATTR_IDX(al_list_idx) = attr_idx;
                        SCP_TMP_LIST(curr_scp_idx) = al_list_idx;
                     }
                  }
                     
                  break;

               case Variable:
               case Atd_Unknown:

                  if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == CRI_Ptr) {
                     fnd_semantic_err(Obj_Use_Spec_Expr,
                                      line,
                                      col,
                                      attr_idx,
                                      TRUE);
                     ok = FALSE;
                  }
                  else if (!ATD_IN_COMMON(attr_idx) &&
                           !AT_USE_ASSOCIATED(attr_idx) &&
                           !host_associated &&
                           !ATD_SYMBOLIC_CONSTANT(attr_idx)) { 

                     if (ATD_EQUIV(attr_idx)) {
                        ATD_EQUIV_IN_BNDS_EXPR(attr_idx) = TRUE;
                     }
                     else {

                        if (!AT_DCL_ERR(attr_idx)) {
                           PRINTMSG(line, 521, Error, col,
                                    AT_OBJ_NAME_PTR(attr_idx));
                        }
                        ok = FALSE;
                     }
                  }
                  break;

               case Constant:
               case Struct_Component:
                  break;

               case Function_Result:
               case CRI__Pointee: 
                  fnd_semantic_err(Obj_Use_Spec_Expr,
                                   line,
                                   col,
                                   attr_idx,
                                   TRUE);
                  ok = FALSE;
                  break;
               }  /* End switch */
            }
            else if (expr_mode == Initialization_Expr) {

               if (ATD_CLASS(attr_idx) != Struct_Component &&
                   ! ATD_LCV_IS_CONST(attr_idx)     &&
                   ! ATD_PARENT_OBJECT(attr_idx) &&
                   ATD_CLASS(attr_idx) != Constant) {

                  if (!fnd_semantic_err(Obj_Use_Init_Expr,
                                        line,
                                        col,
                                        attr_idx,
                                        TRUE)) {
                     PRINTMSG(line, 868, Error, col,   /* Must be a constant */
                              AT_OBJ_NAME_PTR(attr_idx));
                     AT_DCL_ERR(attr_idx) = TRUE;
                  }

                  ok = FALSE;
               }
            }
            break;

         case Pgm_Unit:

            if (ATP_PROC(attr_idx) == Dummy_Proc &&
                ATP_DUMMY_PROC_LINK(attr_idx) != NULL_IDX) {

               attr_idx = ATP_DUMMY_PROC_LINK(attr_idx);
            }

            if (pgm_unit_illegal && !in_call_list) {
               ok = FALSE;

               switch (ATP_PGM_UNIT(attr_idx)) {
                  case Function    :
                     msg_num = 451;
                     break;

                  case Subroutine  :
                     msg_num = 452;
                     break;

                  case Program    :
                     msg_num = 453;
                     break;

                  case Blockdata   :
                     msg_num = 454;
                     break;

                  case Module      :
                     msg_num = 455;
                     break;

                  case Pgm_Unknown :
                     msg_num = 378;
                     break;
               }
               PRINTMSG(line, msg_num, Error, col,
                        AT_OBJ_NAME_PTR(attr_idx));
            }
            else if (ATP_PGM_UNIT(attr_idx) == Function) {

               exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
               exp_desc->type = TYP_TYPE(exp_desc->type_idx);
               exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);

               if (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))) {
                  exp_desc->rank=BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)));

                  get_shape_from_attr(exp_desc,
                                      ATP_RSLT_IDX(attr_idx),
                                      exp_desc->rank,
                                      line,
                                      col);
               }
               else {
                  exp_desc->rank = 0;
               }
            }
            break;

         case Label:
            if (ATL_CLASS(attr_idx) == Lbl_Construct) {

               /* always an error for a construct name here */

               PRINTMSG(line, 1461, Error, col,
                        AT_OBJ_NAME_PTR(attr_idx));
               ok = FALSE;
            }
            else if (label_allowed) {
               exp_desc->label = TRUE;
            }
            else {
               /* can't have label here */
               PRINTMSG(line, 1462, Error, col,
                        AT_OBJ_NAME_PTR(attr_idx));
               ok = FALSE;
            }
            break;

         case Namelist_Grp:
            if (expr_mode == Specification_Expr) {
               fnd_semantic_err(Obj_Use_Spec_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }
            else if (expr_mode == Initialization_Expr) {
               fnd_semantic_err(Obj_Use_Init_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }
            else if (namelist_illegal) {
               PRINTMSG(line, 512, Error, col,
                        AT_OBJ_NAME_PTR(attr_idx));

               ok = FALSE;
            }
            break;


         case Derived_Type :

            if (!AT_DEFINED(attr_idx)) {

               /* Will not get duplicate messages, because if AT_DCL_ERR */
               /* is TRUE, it will not get here.                         */

               issue_undefined_type_msg(attr_idx, line, col);
               ok = FALSE;
            }
            else if (expr_mode == Specification_Expr) {
               fnd_semantic_err(Obj_Use_Spec_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }
            else if (expr_mode == Initialization_Expr) { 
               fnd_semantic_err(Obj_Use_Init_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }
            break;


         case Interface    :

            if (pgm_unit_illegal) {

               if (in_call_list                        &&
                   ATI_PROC_IDX(attr_idx) != NULL_IDX) {

                  /* change to the specific with same name */
                  attr_idx = ATI_PROC_IDX(attr_idx);
                  OPND_FLD((*result_opnd)) = AT_Tbl_Idx;
                  OPND_IDX((*result_opnd)) = attr_idx;
                  OPND_LINE_NUM((*result_opnd)) = line;
                  OPND_COL_NUM((*result_opnd))  = col;

                  AT_REFERENCED(attr_idx) = (expr_mode == Specification_Expr ||
                                             expr_mode == Stmt_Func_Expr) ?
                                             Dcl_Bound_Ref : Referenced;

                  if (ATP_PGM_UNIT(attr_idx) == Function) {

                     exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
                     exp_desc->type        = TYP_TYPE(exp_desc->type_idx);
                     exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);

                     AT_REFERENCED(ATP_RSLT_IDX(attr_idx)) =
                                                    AT_REFERENCED(attr_idx);

                     if (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))) {
                        exp_desc->rank =
                            BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)));

                        get_shape_from_attr(exp_desc,
                                            ATP_RSLT_IDX(attr_idx),
                                            exp_desc->rank,
                                            line,
                                            col);
                     }
                     else {
                        exp_desc->rank = 0;
                     }
                  }
               }
               else {
                  /* invalid use of interface */
                  if (!AT_DCL_ERR(attr_idx)) {
                     PRINTMSG(line, 1078, Error, col,
                              AT_OBJ_NAME_PTR(attr_idx));
                  }
                  ok = FALSE;
               }
            }
            else if (expr_mode == Specification_Expr) {
               fnd_semantic_err(Obj_Use_Spec_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }
            else if (expr_mode == Initialization_Expr) { 
               fnd_semantic_err(Obj_Use_Init_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }
            break;

         case Stmt_Func    :

            if (expr_mode == Specification_Expr) {
               fnd_semantic_err(Obj_Use_Spec_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }
            else if (expr_mode == Initialization_Expr) {
               fnd_semantic_err(Obj_Use_Init_Expr,
                                line,
                                col,
                                attr_idx,
                                TRUE);
               ok = FALSE;
            }

            exp_desc->type_idx    = ATD_TYPE_IDX(attr_idx);
            exp_desc->type    = TYP_TYPE(exp_desc->type_idx);
            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);

            break;

         }
         break;

      case IR_Tbl_Idx :

         namelist_illegal     = TRUE;
         label_allowed        = FALSE;

         ir_idx = OPND_IDX((*result_opnd));

         /* clear rank on the descriptors */
         IR_ARRAY_SYNTAX(ir_idx) = FALSE;

         switch (IR_OPR(ir_idx)) {

            case Null_Opr             :
               break;

            case Defined_Un_Opr       :

               ok = defined_un_opr_handler(result_opnd, exp_desc);
               break;

            case Uplus_Opr            :
            case Uminus_Opr           :

               ok = uplus_opr_handler(result_opnd, exp_desc);
               break;

            case Power_Opr            :

               ok = power_opr_handler(result_opnd, exp_desc);
               break;

            case Mult_Opr             :
            case Div_Opr              :

               ok = mult_opr_handler(result_opnd, exp_desc);
               break;

            case Minus_Opr            :

               ok = minus_opr_handler(result_opnd, exp_desc);
               break;

            case Plus_Opr             :

               ok = plus_opr_handler(result_opnd, exp_desc);
               break;

            case Concat_Opr           :

               ok = concat_opr_handler(result_opnd, exp_desc);
               break;

            case Eq_Opr               :
            case Ne_Opr               :

               ok = eq_opr_handler(result_opnd, exp_desc);
               break;

            case Lg_Opr               :

               ok = lg_opr_handler(result_opnd, exp_desc);
               break;

            case Lt_Opr               :
            case Le_Opr               :
            case Gt_Opr               :
            case Ge_Opr               :

               ok = lt_opr_handler(result_opnd, exp_desc);
               break;

            case Not_Opr              :

               ok = not_opr_handler(result_opnd, exp_desc);
               break;

            case And_Opr              :
            case Or_Opr               :
            case Eqv_Opr              :
            case Neqv_Opr             :

               ok = and_opr_handler(result_opnd, exp_desc);
               break;

            case Defined_Bin_Opr      :

               ok = defined_bin_opr_handler(result_opnd, exp_desc);
               break;

            case Max_Opr              :
            case Min_Opr              :

               ok = max_opr_handler(result_opnd, exp_desc);
               break;

            case Call_Opr             :
               
               if (need_pure_function && 
                   AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Pgm_Unit &&
#ifdef KEY /* Bug 7726 */
         /* Fortran 95 says every elemental function is a pure function */
                   !(ATP_PURE(IR_IDX_L(ir_idx)) ||
         ATP_ELEMENTAL(IR_IDX_L(ir_idx))))
#else /* KEY Bug 7726 */
                   !ATP_PURE(IR_IDX_L(ir_idx)))
#endif /* KEY Bug 7726 */
       {
                  /* KAY - insert call to message here */
                  ok = FALSE;
                  break;
               }

               if (expr_mode == Restricted_Imp_Do_Expr) {
                  PRINTMSG(line, 706, Error, col);
                  ok = FALSE;
                  break;
               }

               save_in_constructor = in_constructor;
               in_constructor = FALSE;

               ok = call_list_semantics(result_opnd, 
                                        exp_desc,
                                        TRUE);

               in_constructor = save_in_constructor;

               if (expr_mode == Data_Stmt_Target_Expr &&
                   !exp_desc->constant) {

                  PRINTMSG(line, 706, Error, col);
                  ok = FALSE;
               }

               break;

            case Struct_Opr           :

               ok = struct_opr_handler(result_opnd, exp_desc, rank_in);
               break;

            case Struct_Construct_Opr :
            case Constant_Struct_Construct_Opr :

               ok = struct_construct_opr_handler(result_opnd, exp_desc);
               break;

            case Array_Construct_Opr :
            case Constant_Array_Construct_Opr :

               ok = array_construct_opr_handler(result_opnd, exp_desc);
               break;

            case Whole_Subscript_Opr  :
            case Section_Subscript_Opr :
            case Subscript_Opr        :

               ok = subscript_opr_handler(result_opnd, exp_desc, rank_in);
               break;

            case Whole_Substring_Opr  :
            case Substring_Opr        :

               ok = substring_opr_handler(result_opnd, exp_desc, rank_in);
               break;

            case Triplet_Opr          :

               ok = triplet_opr_handler(result_opnd, exp_desc);
               break;

            case Dealloc_Obj_Opr      :

               ok = dealloc_obj_opr_handler(result_opnd, exp_desc, rank_in);
               break;

            case Alloc_Obj_Opr        :

               ok = alloc_obj_opr_handler(result_opnd, exp_desc, rank_in);
               break;

            case Cvrt_Opr             :
            case Cvrt_Unsigned_Opr    :

               ok = cvrt_opr_handler(result_opnd, exp_desc);
               break;

            case Paren_Opr            :

               ok = paren_opr_handler(result_opnd, exp_desc);
               break;

            case Kwd_Opr              :
   
               /* must be error in array spec */

               PRINTMSG(IR_LINE_NUM(ir_idx), 197, Error, IR_COL_NUM(ir_idx),
                        ", or )", "=");
               ok = FALSE;
               break;

            case Stmt_Func_Call_Opr   :

               ok = stmt_func_call_opr_handler(result_opnd, exp_desc);
               break;

            case Clen_Opr:

               save_insert_subs_ok = insert_subs_ok;
               insert_subs_ok = FALSE;

               save_in_call_list = in_call_list;

               if (IR_FLD_L(ir_idx) == AT_Tbl_Idx &&
                   AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Pgm_Unit) {
                  in_call_list = TRUE;
               }

               COPY_OPND(opnd, IR_OPND_L(ir_idx));
               ok = expr_sem(&opnd, exp_desc);
               COPY_OPND(IR_OPND_L(ir_idx), opnd);
               insert_subs_ok = save_insert_subs_ok;
               in_call_list = save_in_call_list;

               exp_desc->type        = Integer;
               exp_desc->linear_type = INTEGER_DEFAULT_TYPE;
               exp_desc->type_idx    = INTEGER_DEFAULT_TYPE;

               fold_clen_opr(result_opnd, exp_desc);
               break;

            case Percent_Val_Opr :
               COPY_OPND(opnd, IR_OPND_L(ir_idx));
               ok = expr_sem(&opnd, exp_desc);
               COPY_OPND(IR_OPND_L(ir_idx), opnd);

               if (OPND_FLD(opnd) == AT_Tbl_Idx &&
                   AT_OBJ_CLASS(OPND_IDX(opnd)) == Pgm_Unit) {
                  /* just ignore the %val */
                  COPY_OPND((*result_opnd), opnd);
               }
               else if (exp_desc->rank == 0 &&
                        (exp_desc->type == Integer ||
                         exp_desc->type == Logical ||
                         exp_desc->type == Real)) {

                  COPY_OPND((*result_opnd), opnd);
                  exp_desc->percent_val_arg = TRUE;
               }
               else {
                  PRINTMSG(IR_LINE_NUM(ir_idx), 1125, Error, 
                           IR_COL_NUM(ir_idx));
                  ok = FALSE;
               }
               break;

            /**********************************************************\
            |* These oprs are only seen when we are traversing a tree *|
            |* for the second time in special circumstances.          *|
            \**********************************************************/

            case Dv_Deref_Opr :

               save_no_sub_or_deref = no_sub_or_deref;
               no_sub_or_deref = TRUE;
               COPY_OPND(opnd, IR_OPND_L(ir_idx));
               ok = expr_sem(&opnd, exp_desc);
               COPY_OPND(IR_OPND_L(ir_idx), opnd);
               no_sub_or_deref = save_no_sub_or_deref;
               break;

            case Dv_Access_Base_Addr:
            case Dv_Access_El_Len:
            case Dv_Access_Assoc:
            case Dv_Access_Ptr_Alloc:
            case Dv_Access_P_Or_A:
            case Dv_Access_A_Contig:
            case Dv_Access_N_Dim:
            case Dv_Access_Typ_Code:
            case Dv_Access_Orig_Base:
            case Dv_Access_Orig_Size:
            case Dv_Access_Low_Bound:
            case Dv_Access_Extent:
            case Dv_Access_Stride_Mult:
               save_no_sub_or_deref = no_sub_or_deref;
               no_sub_or_deref = TRUE;
               exp_desc_l.rank = 0;
               COPY_OPND(opnd, IR_OPND_L(ir_idx));
               ok = expr_sem(&opnd, &exp_desc_l);
               COPY_OPND(IR_OPND_L(ir_idx), opnd);
               no_sub_or_deref = save_no_sub_or_deref;

               exp_desc->type_idx    = IR_TYPE_IDX(ir_idx);
               exp_desc->type        = TYP_TYPE(exp_desc->type_idx);
               exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
               exp_desc->has_symbolic= exp_desc_l.has_symbolic;
               break;

            default :
               save_no_sub_or_deref = no_sub_or_deref;
               no_sub_or_deref = TRUE;
               exp_desc_l.rank = 0;
               COPY_OPND(opnd, IR_OPND_L(ir_idx));
               ok = expr_sem(&opnd, &exp_desc_l);
               COPY_OPND(IR_OPND_L(ir_idx), opnd);

               no_sub_or_deref = TRUE;
               exp_desc_r.rank = 0;
               COPY_OPND(opnd, IR_OPND_R(ir_idx));
               ok = expr_sem(&opnd, &exp_desc_r);
               COPY_OPND(IR_OPND_R(ir_idx), opnd);
               no_sub_or_deref = save_no_sub_or_deref;

               exp_desc->type_idx    = IR_TYPE_IDX(ir_idx);
               exp_desc->type        = TYP_TYPE(exp_desc->type_idx);
               exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
               exp_desc->rank        = IR_RANK(ir_idx);
               break;
         }

         break;

      case IL_Tbl_Idx :
         list_idx = OPND_IDX((*result_opnd));
         while (list_idx) {
            COPY_OPND(opnd, IL_OPND(list_idx));
            ok = expr_sem(&opnd, &exp_desc_l);
            COPY_OPND(IL_OPND(list_idx), opnd);
            list_idx = IL_NEXT_LIST_IDX(list_idx);
         }
            
         break;
   }


   TRACE (Func_Exit, "expr_sem", NULL);

   return (ok);

}  /* expr_sem */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  inserts subscript and triplet texts for whole array refs.             *|
|*                        *|
|* Input parameters:                    *|
|*  opnd .. copy of array obj opnd.                                       *|
|*                        *|
|* Output parameters:                   *|
|*      exp_desc .. expression descriptor for opnd. The rank and shape are    *|
|*                  are filled in here.                                       *|
|*                        *|
|* Returns:                     *|
|*  TRUE if no errors.                                                    *|
|*                        *|
\******************************************************************************/

boolean  gen_whole_subscript (opnd_type *opnd, expr_arg_type *exp_desc)

{
   int    attr_idx;
   int    bd_idx;
   int          col;
   int    dv_idx;
   opnd_type  dv_opnd;
   int    i;
   int          line;
   int    list1_idx = NULL_IDX;
   int    list2_idx;
   expr_arg_type loc_exp_desc;
   int    minus_idx;
   opnd_type  opnd2;
   int    plus_idx;

# if defined(_TARGET_OS_MAX) && defined(_F_MINUS_MINUS)
   int    save_pe_dv_list_idx = NULL_IDX;
# endif

   int    sub_idx;
   boolean      ok = TRUE;
   int    tlst1_idx;
   int    tlst2_idx;
   int    tlst3_idx;
   int    trip_idx;


   TRACE (Func_Entry, "gen_whole_subscript", NULL);

   attr_idx = find_base_attr(opnd, &line, &col);

   bd_idx = ATD_ARRAY_IDX(attr_idx);

   if (bd_idx &&
       BD_ARRAY_CLASS(bd_idx) == Assumed_Size) {

      if (in_call_list) {
         /* it's ok, just don't try to gen the whole subscript */

         if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
            ok = gen_whole_substring(opnd, BD_RANK(bd_idx));
         }
      }
      else {
         /* error .. can't have assumed size here */
         ok = FALSE;

         if (SH_STMT_TYPE(curr_stmt_sh_idx)             == Assignment_Stmt &&
             IR_FLD_L(SH_IR_IDX(curr_stmt_sh_idx))      == AT_Tbl_Idx      &&
             IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx))      == attr_idx        &&
             IR_COL_NUM_L(SH_IR_IDX(curr_stmt_sh_idx))  == col             &&
             IR_LINE_NUM_L(SH_IR_IDX(curr_stmt_sh_idx)) == line)           {
   
            PRINTMSG(line, 411, Error, col);
         }
         else {
            PRINTMSG(line, 412, Error, col);
         }
      }

      goto EXIT;
   }

   NTR_IR_TBL(sub_idx);
   IR_OPR(sub_idx)             = Whole_Subscript_Opr;

# if defined(_TARGET_OS_MAX) &&  defined(_F_MINUS_MINUS)
   if (exp_desc->pe_dim_ref &&
       OPND_FLD((*opnd)) == IR_Tbl_Idx &&
       IR_OPR(OPND_IDX((*opnd))) == Subscript_Opr &&
       IR_LIST_CNT_R(OPND_IDX((*opnd))) == 1 &&
       IL_PE_SUBSCRIPT(IR_IDX_R(OPND_IDX((*opnd))))) {

      /* save the pe subscript */
      save_pe_dv_list_idx = IR_IDX_R(OPND_IDX((*opnd)));

      plus_idx = OPND_IDX((*opnd));
      COPY_OPND((*opnd), IR_OPND_L(OPND_IDX((*opnd))));
      FREE_IR_NODE(plus_idx);
   }
# endif

   if (OPND_FLD((*opnd))         == IR_Tbl_Idx    &&
       IR_OPR(OPND_IDX((*opnd))) == Dv_Deref_Opr) {

      COPY_OPND(dv_opnd, IR_OPND_L(OPND_IDX((*opnd))));
   }
   else {
      COPY_OPND(dv_opnd, (*opnd));
   }

   copy_subtree(&dv_opnd, &dv_opnd);

   COPY_OPND(IR_OPND_L(sub_idx), (*opnd));

   /* hook Whole_Subscript text onto *opnd */

   OPND_FLD((*opnd))  = IR_Tbl_Idx;
   OPND_IDX((*opnd))  = sub_idx;

   IR_RANK(sub_idx) = (bd_idx ? BD_RANK(bd_idx) : 0);
   IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx);
   IR_LINE_NUM(sub_idx) = line;
   IR_COL_NUM(sub_idx)  = col;

   exp_desc->rank = IR_RANK(sub_idx);

   IR_FLD_R(sub_idx)    = IL_Tbl_Idx;
   IR_LIST_CNT_R(sub_idx) = IR_RANK(sub_idx);

   for (i = 1 ; i <= IR_LIST_CNT_R(sub_idx); i++) {
      
      /* set up exp_desc->shape */
      if (ATD_IM_A_DOPE(attr_idx)) {
         OPND_FLD(exp_desc->shape[i-1]) = IR_Tbl_Idx;
         NTR_IR_TBL(dv_idx);
         IR_OPR(dv_idx)   = Dv_Access_Extent;
         IR_TYPE_IDX(dv_idx)  = SA_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(dv_idx)  = line;
         IR_COL_NUM(dv_idx) = col;
         IR_DV_DIM(dv_idx)  = i;
         COPY_OPND(IR_OPND_L(dv_idx), dv_opnd);
         OPND_IDX(exp_desc->shape[i-1]) = dv_idx;
         SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE;
         SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE;
      }
      else {
         OPND_FLD(exp_desc->shape[i-1]) = BD_XT_FLD(bd_idx, i);
         OPND_IDX(exp_desc->shape[i-1]) = BD_XT_IDX(bd_idx, i);

         if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx) {
            ADD_TMP_TO_SHARED_LIST(OPND_IDX(exp_desc->shape[i-1]));
         }

         if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx) {
            SHAPE_FOLDABLE(exp_desc->shape[i-1]) = TRUE;
            SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = TRUE;
         }
         else if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx &&
                  AT_OBJ_CLASS(OPND_IDX(exp_desc->shape[i-1])) == Data_Obj &&
                  ATD_LCV_IS_CONST(OPND_IDX(exp_desc->shape[i-1]))) {

            SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE;
            SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = TRUE;
         }
         else {
            SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE;
            SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE;
         }
      }

      if (list1_idx == NULL_IDX) {
         NTR_IR_LIST_TBL(list1_idx);
         IR_IDX_R(sub_idx)           = list1_idx;
      }
      else {
         list2_idx = list1_idx;
         NTR_IR_LIST_TBL(list1_idx);
         IL_NEXT_LIST_IDX(list2_idx) = list1_idx;
         IL_PREV_LIST_IDX(list1_idx) = list2_idx;
      }

      IL_FLD(list1_idx)   = IR_Tbl_Idx;
      NTR_IR_TBL(trip_idx);
      IR_OPR(trip_idx)    = Triplet_Opr;
      IR_TYPE_IDX(trip_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_RANK(trip_idx)   = 1;
      IR_LINE_NUM(trip_idx) = line;
      IR_COL_NUM(trip_idx)  = col;
      IL_IDX(list1_idx)   = trip_idx;

      NTR_IR_LIST_TBL(tlst1_idx);
      NTR_IR_LIST_TBL(tlst2_idx);
      NTR_IR_LIST_TBL(tlst3_idx);
      IR_FLD_L(trip_idx)          = IL_Tbl_Idx;
      IR_LIST_CNT_L(trip_idx)     = 3;
      IR_IDX_L(trip_idx)          = tlst1_idx;

      IL_NEXT_LIST_IDX(tlst1_idx) = tlst2_idx;
      IL_PREV_LIST_IDX(tlst2_idx) = tlst1_idx;
      IL_NEXT_LIST_IDX(tlst2_idx) = tlst3_idx;
      IL_PREV_LIST_IDX(tlst3_idx) = tlst2_idx;
      
      if (ATD_IM_A_DOPE(attr_idx)) {

         /* set up first triplet value */

         gen_dv_access_low_bound(&opnd2, &dv_opnd, i);

         COPY_OPND(IL_OPND(tlst1_idx), opnd2);

         /* set up upper bound value */

         NTR_IR_TBL(minus_idx);
         IR_OPR(minus_idx)            = Minus_Opr;
         IR_TYPE_IDX(minus_idx)       = SA_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(minus_idx)       = line;
         IR_COL_NUM(minus_idx)        = col;
         IR_FLD_R(minus_idx)          = CN_Tbl_Idx;
         IR_IDX_R(minus_idx)          = CN_INTEGER_ONE_IDX;
         IR_LINE_NUM_R(minus_idx)     = line;
         IR_COL_NUM_R(minus_idx)      = col;

         NTR_IR_TBL(plus_idx);
         IR_OPR(plus_idx)           = Plus_Opr;
         IR_TYPE_IDX(plus_idx)      = SA_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(plus_idx)      = line;
         IR_COL_NUM(plus_idx)       = col;
         IR_FLD_L(minus_idx)          = IR_Tbl_Idx;
         IR_IDX_L(minus_idx)          = plus_idx;

         gen_dv_access_low_bound(&opnd2, &dv_opnd, i);

         COPY_OPND(IR_OPND_R(plus_idx), opnd2);

         NTR_IR_TBL(dv_idx);
         IR_OPR(dv_idx)              = Dv_Access_Extent;
         IR_TYPE_IDX(dv_idx)         = SA_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(dv_idx)         = line;
         IR_COL_NUM(dv_idx)          = col;
         IR_DV_DIM(dv_idx)           = i;
         COPY_OPND(IR_OPND_L(dv_idx), dv_opnd);

         IR_FLD_L(plus_idx)         = IR_Tbl_Idx;
         IR_IDX_L(plus_idx)         = dv_idx;

         IL_FLD(tlst2_idx)           = IR_Tbl_Idx;
         IL_IDX(tlst2_idx)           = minus_idx;
         
      }
      else {
         IL_FLD(tlst1_idx)      = BD_LB_FLD(bd_idx, i);
         IL_IDX(tlst1_idx)      = BD_LB_IDX(bd_idx, i);
         IL_LINE_NUM(tlst1_idx) = line;
         IL_COL_NUM(tlst1_idx)  = col;

         if (IL_FLD(tlst1_idx) == AT_Tbl_Idx) {
            ADD_TMP_TO_SHARED_LIST(IL_IDX(tlst1_idx));
         }

         if (IL_FLD(tlst1_idx) != CN_Tbl_Idx) {

            /* assumes that this is an AT_Tbl_Idx */
            loc_exp_desc.type_idx = ATD_TYPE_IDX(IL_IDX(tlst1_idx));
            loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx);
            loc_exp_desc.linear_type =
                                 TYP_LINEAR(loc_exp_desc.type_idx);
         }
         else {
            loc_exp_desc.type_idx = CN_TYPE_IDX(IL_IDX(tlst1_idx));
            loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx);
            loc_exp_desc.linear_type =
                                 TYP_LINEAR(loc_exp_desc.type_idx);
         }

#ifdef KEY /* Bug 4709 */
         /* Converting array bounds from Integer_8 to Integer_4 breaks
    * customer code which uses large array bounds, and isn't
    * correct for our 64-bit-oriented runtime.
    */
#else
         if (in_io_list) {

            /* on mpp, must cast shorts to longs in io lists */
            /* on solaris, must cast Integer_8 to Integer_4 */

            COPY_OPND(opnd2, IL_OPND(tlst1_idx));
            cast_to_cg_default(&opnd2, &loc_exp_desc);
            COPY_OPND(IL_OPND(tlst1_idx), opnd2);
         }
#endif /* KEY Bug 4709 */

         IL_FLD(tlst2_idx)      = BD_UB_FLD(bd_idx, i);
         IL_IDX(tlst2_idx)      = BD_UB_IDX(bd_idx, i);
         IL_LINE_NUM(tlst2_idx) = line;
         IL_COL_NUM(tlst2_idx)  = col;

         if (IL_FLD(tlst2_idx) == AT_Tbl_Idx) {
            ADD_TMP_TO_SHARED_LIST(IL_IDX(tlst2_idx));
         }

         if (IL_FLD(tlst2_idx) != CN_Tbl_Idx) {

            /* assumes that this is an AT_Tbl_Idx */
            loc_exp_desc.type_idx = ATD_TYPE_IDX(IL_IDX(tlst2_idx));
            loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx);
            loc_exp_desc.linear_type =
                                 TYP_LINEAR(loc_exp_desc.type_idx);
         }
         else {
            loc_exp_desc.type_idx = CN_TYPE_IDX(IL_IDX(tlst2_idx));
            loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx);
            loc_exp_desc.linear_type =
                                 TYP_LINEAR(loc_exp_desc.type_idx);
         }

#ifdef KEY /* Bug 4709 */
         /* Converting array bounds from Integer_8 to Integer_4 breaks
    * customer code which uses large array bounds, and isn't
    * correct for our 64-bit-oriented runtime.
    */
#else
         if (in_io_list) {

            /* on mpp, must cast shorts to longs in io lists */
            /* on solaris, must cast Integer_8 to Integer_4 */

            COPY_OPND(opnd2, IL_OPND(tlst2_idx));
            cast_to_cg_default(&opnd2, &loc_exp_desc);
            COPY_OPND(IL_OPND(tlst2_idx), opnd2);
         }
#endif /* KEY Bug 4709 */
      }

      IL_FLD(tlst3_idx)      = CN_Tbl_Idx;
      IL_LINE_NUM(tlst3_idx) = line;
      IL_COL_NUM(tlst3_idx)  = col;
      IL_IDX(tlst3_idx)      = CN_INTEGER_ONE_IDX;
   }

# if defined(_TARGET_OS_MAX)

# ifdef _F_MINUS_MINUS
   if (save_pe_dv_list_idx != NULL_IDX) {

      /* add the pe subscript to ir_idx */
      list1_idx = IR_IDX_R(sub_idx);

      while (IL_NEXT_LIST_IDX(list1_idx)) {
         list1_idx = IL_NEXT_LIST_IDX(list1_idx);
      }

      IL_NEXT_LIST_IDX(list1_idx) = save_pe_dv_list_idx;
      IL_PREV_LIST_IDX(save_pe_dv_list_idx) = list1_idx;
      IR_LIST_CNT_R(sub_idx) += 1;
   }
   else if (ATD_PE_ARRAY_IDX(attr_idx) &&
            ! ATD_ALLOCATABLE(attr_idx)) {
      /* supply mype() as pe dim */

      list1_idx = IR_IDX_R(sub_idx);

      if (list1_idx) {
         while (IL_NEXT_LIST_IDX(list1_idx) != NULL_IDX) {
            list1_idx = IL_NEXT_LIST_IDX(list1_idx);
         }

         NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list1_idx));
         IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list1_idx)) = list1_idx;
         list1_idx = IL_NEXT_LIST_IDX(list1_idx);
         IR_LIST_CNT_R(sub_idx) += 1;
      }
      else {
         NTR_IR_LIST_TBL(list1_idx);
         IR_FLD_R(sub_idx) = IL_Tbl_Idx;
         IR_LIST_CNT_R(sub_idx) = 1;
         IR_IDX_R(sub_idx) = list1_idx;

         IR_OPR(sub_idx) = Subscript_Opr;
      }

      NTR_IR_TBL(plus_idx);
      IR_OPR(plus_idx) = My_Pe_Opr;
      IR_TYPE_IDX(plus_idx) = INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(plus_idx) = IR_LINE_NUM(sub_idx);
      IR_COL_NUM(plus_idx) = IR_COL_NUM(sub_idx);

      IL_FLD(list1_idx) = IR_Tbl_Idx;
      IL_IDX(list1_idx) = plus_idx;

      IL_PE_SUBSCRIPT(list1_idx) = TRUE;
      io_item_must_flatten = TRUE;
   }
# endif
# endif

   if (ok && 
       TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
      ok = gen_whole_substring(opnd, IR_RANK(sub_idx));
   }

   IR_ARRAY_SYNTAX(sub_idx) = FALSE;

EXIT:

   TRACE (Func_Exit, "gen_whole_subscript", NULL);

   return(ok);

}  /* gen_whole_subscript */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      inserts substring texts and bounds for whole character refs.          *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      opnd .. copy of array obj opnd.                                       *|
|*      rank .. rank of opnd, it is placed on substring opr.                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      TRUE if no problem                                                    *|
|*                                                                            *|
\******************************************************************************/

boolean  gen_whole_substring (opnd_type *opnd,
                              int        rank)

{
   int          attr_idx;
   int    clen_idx;
   int          col;
   int    ir_idx;
   int          line;
   int    list_idx;
   int          list1_idx;
   int          list2_idx;
   int    shift_idx;
   int          sub_idx;
   boolean      ok = TRUE;


   TRACE (Func_Entry, "gen_whole_substring", NULL);

   /* what do we do with assumed size character? */

   attr_idx = find_base_attr(opnd, &line, &col);

   NTR_IR_TBL(sub_idx);

   COPY_OPND(IR_OPND_L(sub_idx), (*opnd));

   IR_OPR(sub_idx)    = Whole_Substring_Opr;
   IR_RANK(sub_idx)   = rank;
   IR_TYPE_IDX(sub_idx)   = ATD_TYPE_IDX(attr_idx);
   IR_LINE_NUM(sub_idx)   = line;
   IR_COL_NUM(sub_idx)    = col;

   OPND_FLD((*opnd))    = IR_Tbl_Idx;
   OPND_IDX((*opnd))    = sub_idx;

   IR_FLD_R(sub_idx)    = IL_Tbl_Idx;
   IR_LIST_CNT_R(sub_idx) = 2;

   NTR_IR_LIST_TBL(list1_idx);
   IR_IDX_R(sub_idx) = list1_idx;
   IL_FLD(list1_idx) = CN_Tbl_Idx;
   IL_IDX(list1_idx) = CN_INTEGER_ONE_IDX;
   IL_LINE_NUM(list1_idx) = line;
   IL_COL_NUM(list1_idx)  = col;

   NTR_IR_LIST_TBL(list2_idx);
   IL_NEXT_LIST_IDX(list1_idx)  = list2_idx;
   IL_PREV_LIST_IDX(list2_idx)  = list1_idx;

   if (ATD_CLASS(attr_idx)                    == CRI__Pointee &&
       TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Assumed_Size_Char){

      NTR_IR_TBL(clen_idx);
      IR_OPR(clen_idx)        = Clen_Opr;
      IR_TYPE_IDX(clen_idx)   = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(clen_idx)   = line;
      IR_COL_NUM(clen_idx)    = col;
      IR_FLD_L(clen_idx)      = AT_Tbl_Idx;
      IR_IDX_L(clen_idx)      = attr_idx;
      IR_LINE_NUM_L(clen_idx) = line;
      IR_COL_NUM_L(clen_idx)  = col;
      IL_FLD(list2_idx)       = IR_Tbl_Idx;
      IL_IDX(list2_idx)       = clen_idx;
   }
   else if (ATD_CHAR_LEN_IN_DV(attr_idx)) {
      NTR_IR_TBL(ir_idx);
      IR_OPR(ir_idx)           = Dv_Access_El_Len;
      IR_TYPE_IDX(ir_idx)      = SA_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(ir_idx)      = line;
      IR_COL_NUM(ir_idx)       = col;
      IR_FLD_L(ir_idx)         = AT_Tbl_Idx;
      IR_IDX_L(ir_idx)         = attr_idx;
      IR_LINE_NUM_L(ir_idx)    = line;
      IR_COL_NUM_L(ir_idx)     = col;

      if (char_len_in_bytes) {
         /* Len in dope vector is in bytes for solaris */
         IL_FLD(list2_idx) = IR_Tbl_Idx;
         IL_IDX(list2_idx) = ir_idx;
      }
      else {
         NTR_IR_TBL(shift_idx);
         IR_OPR(shift_idx)        = Shiftr_Opr;
         IR_TYPE_IDX(shift_idx)   = CG_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(shift_idx)   = line;
         IR_COL_NUM(shift_idx)    = col;

         NTR_IR_LIST_TBL(list_idx);

         IR_FLD_L(shift_idx)      = IL_Tbl_Idx;
         IR_IDX_L(shift_idx)      = list_idx;
         IR_LIST_CNT_L(shift_idx) = 2;
         IL_FLD(list_idx)         = IR_Tbl_Idx;
         IL_IDX(list_idx)         = ir_idx;

         NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
         IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
         list_idx = IL_NEXT_LIST_IDX(list_idx);

         IL_FLD(list_idx)         = CN_Tbl_Idx;
         IL_LINE_NUM(list_idx)    = line;
         IL_COL_NUM(list_idx)     = col;
         IL_IDX(list_idx)   = CN_INTEGER_THREE_IDX;
         IL_FLD(list2_idx)    = IR_Tbl_Idx;
         IL_IDX(list2_idx)    = shift_idx;
      }
   }
   else {
      IL_IDX(list2_idx)   = TYP_IDX(ATD_TYPE_IDX(attr_idx));
      IL_FLD(list2_idx)   = TYP_FLD(ATD_TYPE_IDX(attr_idx));
      IL_LINE_NUM(list2_idx)  = line;
      IL_COL_NUM(list2_idx) = col;

      if (IL_FLD(list2_idx) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(IL_IDX(list2_idx));
      }
   }

   add_substring_length(sub_idx);

   IR_ARRAY_SYNTAX(sub_idx) = FALSE;

   TRACE (Func_Exit, "gen_whole_substring", NULL);

   return(ok);

}  /* gen_whole_substring */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  This routine accesses the semantic tables for any operator            *|
|*      to see if the operation (or assignment) is intrinsic.                 *|
|*                        *|
|* Input parameters:                    *|
|*  opr   - operator_type                                       *|
|*      type_idx_l  - type of left operand                                *|
|*      rank_l    - rank of left operand                                *|
|*      type_idx_r  - type of right operand                               *|
|*      rank_r    - rank of right operand                               *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  TRUE if operation is intrinsic.                                       *|
|*                        *|
\******************************************************************************/

boolean  operation_is_intrinsic(operator_type   opr,
        int   type_idx_l,
                                int             rank_l,
        int   type_idx_r,
                                int             rank_r)

{
   linear_type_type exp_idx_l;
   linear_type_type exp_idx_r;
   boolean    intrinsic = TRUE;
   basic_type_type  type_l;
   basic_type_type  type_r;


   TRACE (Func_Entry, "operation_is_intrinsic", NULL);

   if (opr == Null_Opr) {
      intrinsic = FALSE;
      goto EXIT;
   }

   type_l = TYP_TYPE(type_idx_l);
   type_r = TYP_TYPE(type_idx_r);
   exp_idx_l  = TYP_LINEAR(type_idx_l);
   exp_idx_r  = TYP_LINEAR(type_idx_r);

   if (type_r != Typeless) {

      if (opr == Asg_Opr) {
   
         if (rank_l != rank_r &&
             rank_r != 0) {
            /* not intrinsic */
            intrinsic = FALSE;
            goto EXIT;
         }
      }
      else {
   
         if (rank_l != rank_r &&
             rank_l * rank_r != 0) {
            /* not intrinsic */
            intrinsic = FALSE;
            goto EXIT;
         }
      }
   }

   switch (opr) {
      case Plus_Opr :

         if (type_r == Typeless) {

            if (UN_PLUS_TYPE(exp_idx_l) == Err_Res ||
                UN_PLUS_EXTN(exp_idx_l)) {
               intrinsic = FALSE;
            }
         }
         else {
            if (BIN_ADD_TYPE(exp_idx_l, exp_idx_r) == Err_Res ||
                BIN_ADD_EXTN(exp_idx_l, exp_idx_r)) {
               intrinsic = FALSE;
            }
         }
         break;

      case Minus_Opr :

         if (type_r == Typeless) {

            if (UN_PLUS_TYPE(exp_idx_l) == Err_Res ||
                UN_PLUS_EXTN(exp_idx_l)) {
               intrinsic = FALSE;
            }
         }
         else {
            if (BIN_SUB_TYPE(exp_idx_l, exp_idx_r) == Err_Res ||
                BIN_SUB_EXTN(exp_idx_l, exp_idx_r)) {
               intrinsic = FALSE;
            }
         }
         break;

      case Power_Opr :

         if (POWER_TYPE(exp_idx_l, exp_idx_r) == Err_Res ||
             POWER_EXTN(exp_idx_l, exp_idx_r)) {
            intrinsic = FALSE;
         }
         break;

      case Div_Opr :
      case Mult_Opr :

         if (MULT_DIV_TYPE(exp_idx_l, exp_idx_r) == Err_Res ||
             MULT_DIV_EXTN(exp_idx_l, exp_idx_r)) {
            intrinsic = FALSE;
         }
         break;

      case Concat_Opr :

         if (type_l != Character || type_r != Character) {
            intrinsic = FALSE;
         }
         break;

      case Eq_Opr :
# ifndef KEY
      case Ge_Opr :
# endif

         if (EQ_NE_TYPE(exp_idx_l, exp_idx_r) == Err_Res ||
             EQ_NE_EXTN(exp_idx_l, exp_idx_r)) {
            intrinsic = FALSE;
         }
         break;
// Bug 2236
# ifdef KEY
      case Ge_Opr :
# endif
      case Gt_Opr :
      case Le_Opr :
      case Lt_Opr :
      case Ne_Opr :

         if (GT_LT_TYPE(exp_idx_l, exp_idx_r) == Err_Res ||
             GT_LT_EXTN(exp_idx_l, exp_idx_r)) {
            intrinsic = FALSE;
         }
         break;

      case And_Opr :
      case Eqv_Opr :
      case Neqv_Opr :
      case Or_Opr :

         if (AND_OR_TYPE(exp_idx_l, exp_idx_r) == Err_Res ||
             AND_OR_EXTN(exp_idx_l, exp_idx_r)) {
            intrinsic = FALSE;
         }
         break;

      case Not_Opr :

         if (NOT_TYPE(exp_idx_l) == Err_Res ||
             NOT_EXTN(exp_idx_l)) {
            intrinsic = FALSE;
         }
         break;

      case Asg_Opr :

         if (ASG_TYPE(exp_idx_l, exp_idx_r) == Err_Res        ||
             ASG_TYPE(exp_idx_l, exp_idx_r) == Structure_Type ||
             ASG_EXTN(exp_idx_l, exp_idx_r)) {
            intrinsic = FALSE;
         }
         break;
   }



EXIT:

   TRACE (Func_Exit, "operation_is_intrinsic", NULL);

   return(intrinsic);

}  /* operation_is_intrinsic */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  This routine takes two constant table indexes and applies the         *|
|*      relational operator to them and returns the boolean result.           *|
|*      It uses the fortran folders and assumes that the input indexes are    *|
|*      constant table indexes. Big trouble could result if they are not.     *|
|*      It issues internal errors if the operator is not a relational or if   *|
|*      the types of the operands are invalid.                                *|
|*                        *|
|* Input parameters:                    *|
|*  idx_1, idx_2 - the two constant table indexes.                        *|
|*      opr          - the operator to use.                                   *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  The result of the fold.                                               *|
|*                        *|
\******************************************************************************/

boolean fold_relationals(int    idx_1,
         int    idx_2,
       operator_type  opr)

{
   long_type          folded_const[MAX_WORDS_FOR_NUMERIC];
   boolean    ok;
   int      unused;


   TRACE (Func_Entry, "fold_relationals", NULL);

   switch (opr) {
      case Eq_Opr:
      case Ne_Opr:
      case Lt_Opr:
      case Le_Opr:
      case Gt_Opr:
      case Ge_Opr:

         unused = CG_LOGICAL_DEFAULT_TYPE;

         ok = folder_driver((char *)&CN_CONST(idx_1),
                            CN_TYPE_IDX(idx_1),
                           (char *)&CN_CONST(idx_2),
                            CN_TYPE_IDX(idx_2),
                           folded_const,
                           &unused,
                            stmt_start_line,
                            stmt_start_col,
                            2,
                            opr);

         break;

      default : 
         PRINTMSG(stmt_start_line, 251, Internal, stmt_start_col);
         break;

   }


   TRACE (Func_Exit, "fold_relationals", NULL);

   return(THIS_IS_TRUE(folded_const,unused));

}  /* fold_relationals */

# ifdef KEY
static boolean is_loop_index_of_forall_loop (int ir_idx)
{
  int stmt_sh_idx, forall_list_idx, index_idx;
  boolean found = FALSE;

  stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
  while (stmt_sh_idx != NULL_IDX){
    if ( IR_OPR(SH_IR_IDX(stmt_sh_idx)) == Forall_Opr ){
      found = TRUE;
      break;
    }
    else if (SH_STMT_TYPE(stmt_sh_idx) == End_Forall_Stmt)
      break;
    stmt_sh_idx = SH_PREV_IDX(stmt_sh_idx);
  }

  if (!found)
    return FALSE;

  forall_list_idx = IR_IDX_R(SH_IR_IDX(stmt_sh_idx));
  index_idx = IL_IDX(forall_list_idx);

  if (IL_FLD(index_idx) == AT_Tbl_Idx){
    index_idx = IL_IDX(index_idx);
    ir_idx = IL_IDX(ir_idx);
    if (AT_ATTR_LINK(index_idx) == ir_idx)
      return TRUE;
  }
  return FALSE;
}
static int ir_contains_variable_subscript(int ir_idx, int pos)
{
  int ret_idx = NULL_IDX;
  int attr_bd_idx;

  if (IR_OPR(ir_idx) == Subscript_Opr)
  {
    int arg_idx = IR_IDX_R(ir_idx);
    for (int index = 1; index < pos; index++)
      arg_idx = IL_NEXT_LIST_IDX(arg_idx);
    if (IL_FLD(arg_idx) == AT_Tbl_Idx){
      int array_idx = IR_IDX_L(ir_idx);
      if (IR_FLD_L(ir_idx) == AT_Tbl_Idx &&
          is_loop_index_of_forall_loop(arg_idx)){
        attr_bd_idx =  ATD_ARRAY_IDX(array_idx);
        if (BD_LB_FLD(attr_bd_idx, pos) == CN_Tbl_Idx &&
          BD_UB_FLD(attr_bd_idx, pos) == CN_Tbl_Idx &&
          BD_SM_FLD(attr_bd_idx, pos) == CN_Tbl_Idx)
          return ir_idx;
      }
    }
  }
  else{
    if (IR_FLD_L(ir_idx) == IR_Tbl_Idx){
      ret_idx = ir_contains_variable_subscript(IR_IDX_L(ir_idx), pos);
      if (ret_idx != NULL_IDX)
        return ret_idx;
     }

    if (IR_FLD_R(ir_idx) == IR_Tbl_Idx){
      ret_idx = ir_contains_variable_subscript(IR_IDX_R(ir_idx), pos);
      if (ret_idx != NULL_IDX)
        return ret_idx;
    }
  }
  return ret_idx;
}
static void change_extent(opnd_type          *result_opnd)
{
  int subscript_idx, list_idx_11, list_idx_12, list_idx_13,list_idx_14, list_idx_15, list_idx_16, maxval_idx, arg_idx, triplet_idx, attr_bd_idx, i, line, col;

  i = 1;
  line = OPND_LINE_NUM((*result_opnd));
  col = OPND_COL_NUM((*result_opnd));
  subscript_idx = NULL_IDX;
  if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx)
    subscript_idx = ir_contains_variable_subscript(OPND_IDX((*result_opnd)),i);
  if (subscript_idx != NULL_IDX)
  {

    NTR_IR_LIST_TBL(list_idx_11);
    maxval_idx = gen_ir(IL_Tbl_Idx, list_idx_11, Maxval_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, NO_Tbl_Idx, NULL_IDX);
    IR_RANK(maxval_idx) = 0;
    IR_LIST_CNT_L(maxval_idx) = 3;
    IR_LIST_CNT_R(maxval_idx) = 0;

    IL_FLD(list_idx_11) = IR_Tbl_Idx;
    IL_ARG_DESC_VARIANT(list_idx_11) = TRUE;
    IL_LINE_NUM(list_idx_11) = line;
    IL_COL_NUM(list_idx_11)  = col;
    IL_IDX(list_idx_11) = OPND_IDX((*result_opnd));

    IR_OPR(subscript_idx) = Whole_Subscript_Opr;
    arg_idx = IR_IDX_R(subscript_idx);
    for (int index = 1; index < i; index++)
      arg_idx = IL_NEXT_LIST_IDX(arg_idx);

    attr_bd_idx =  ATD_ARRAY_IDX(IR_IDX_L(subscript_idx));

    NTR_IR_LIST_TBL(list_idx_14);
    triplet_idx = gen_ir(IL_Tbl_Idx, list_idx_14, Triplet_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, NO_Tbl_Idx, NULL_IDX);
    IR_LIST_CNT_L(triplet_idx) = 3;

    IL_FLD(arg_idx) = IR_Tbl_Idx;
    IL_IDX(arg_idx) = triplet_idx;
    IL_LINE_NUM(arg_idx) = line;
    IL_COL_NUM(arg_idx)  = col;

    IL_ARG_DESC_VARIANT(list_idx_14) = TRUE;
    IL_LINE_NUM(list_idx_14) = line;
    IL_COL_NUM(list_idx_14)  = col;
    IL_FLD(list_idx_14) = BD_LB_FLD(attr_bd_idx, i);
    IL_IDX(list_idx_14) = BD_LB_IDX(attr_bd_idx, i);

    NTR_IR_LIST_TBL(list_idx_15);
    IL_ARG_DESC_VARIANT(list_idx_15) = TRUE;
    IL_LINE_NUM(list_idx_15) = line;
    IL_COL_NUM(list_idx_15)  = col;
    IL_FLD(list_idx_15) = BD_UB_FLD(attr_bd_idx, i);
    IL_IDX(list_idx_15) = BD_UB_IDX(attr_bd_idx, i);
    IL_NEXT_LIST_IDX(list_idx_14) = list_idx_15;
                       
    NTR_IR_LIST_TBL(list_idx_16);
    IL_ARG_DESC_VARIANT(list_idx_16) = TRUE;
    IL_LINE_NUM(list_idx_16) = line;
    IL_COL_NUM(list_idx_16)  = col;
    IL_FLD(list_idx_16) = BD_XT_FLD(attr_bd_idx, i);
    IL_IDX(list_idx_16) = C_INT_TO_CN(SA_INTEGER_DEFAULT_TYPE, CN_INT_TO_C(BD_UB_IDX(attr_bd_idx,i))/CN_INT_TO_C(BD_XT_IDX(attr_bd_idx,i)));
    IL_NEXT_LIST_IDX(list_idx_15) = list_idx_16;
                       
    IL_NEXT_LIST_IDX(list_idx_16) = NULL_IDX;

    NTR_IR_LIST_TBL(list_idx_12);
    IL_FLD(list_idx_12) = CN_Tbl_Idx;
    IL_IDX(list_idx_12) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i);;
    IL_ARG_DESC_VARIANT(list_idx_12) = TRUE;
    IL_LINE_NUM(list_idx_12) = line;
    IL_COL_NUM(list_idx_12)  = col;
    IL_NEXT_LIST_IDX(list_idx_11) = list_idx_12;

    NTR_IR_LIST_TBL(list_idx_13);
    IL_FLD(list_idx_13) = NO_Tbl_Idx;
    IL_LINE_NUM(list_idx_13) = line;
    IL_COL_NUM(list_idx_13)  = col;
    IL_ARG_DESC_VARIANT(list_idx_13) = TRUE;
    IL_NEXT_LIST_IDX(list_idx_12) = list_idx_13;
    IL_NEXT_LIST_IDX(list_idx_13) = NULL_IDX;
                      
    OPND_IDX((*result_opnd)) = maxval_idx;
  }
}
#endif
/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Create the expression for the extent of an array section.             *|
|*                        *|
|* Input parameters:                    *|
|*      list_idx - IL_Tbl_Idx, points to start value, linked to end and stride*|
|*                        *|
|* Output parameters:                   *|
|*  opnd - opnd_type, this is the result expression.                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

void  make_triplet_extent_tree(opnd_type  *opnd,
         int    list_idx)

{
   int           col;
   int           div_idx;
   expr_arg_type       exp_desc;
   boolean         foldable = TRUE;
   int           line;
   int           plus_idx;
   int           list_idx2;
   int                 max_idx;
   expr_mode_type      save_expr_mode;
   cif_usage_code_type save_xref_state;
   int           sub_idx;
   opnd_type         topnd;
   boolean             unused;
   boolean         will_fold_later = TRUE;


   TRACE (Func_Entry, "make_triplet_extent_tree", NULL);

   find_opnd_line_and_column(opnd, &line, &col);

   NTR_IR_TBL(plus_idx);
   IR_OPR(plus_idx)   = Plus_Opr;
   IR_TYPE_IDX(plus_idx)  = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(plus_idx)        = line;
   IR_COL_NUM(plus_idx)         = col;

   NTR_IR_TBL(div_idx);
   IR_OPR(div_idx)    = Div_Opr;
   IR_TYPE_IDX(div_idx)   = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(div_idx)         = line;
   IR_COL_NUM(div_idx)          = col;

   NTR_IR_TBL(sub_idx);
   IR_OPR(sub_idx)    = Minus_Opr;
   IR_TYPE_IDX(sub_idx)   = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(sub_idx)         = line;
   IR_COL_NUM(sub_idx)          = col;

   NTR_IR_TBL(max_idx);
   IR_OPR(max_idx)              = Max_Opr;
   IR_TYPE_IDX(max_idx)         = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(max_idx)         = line;
   IR_COL_NUM(max_idx)          = col;

   
   OPND_FLD((*opnd))    = IR_Tbl_Idx;
   OPND_IDX((*opnd))    = max_idx;

   NTR_IR_LIST_TBL(list_idx2);
   IR_FLD_L(max_idx)    = IL_Tbl_Idx;
   IR_LIST_CNT_L(max_idx) = 2;
   IR_IDX_L(max_idx)    = list_idx2;

   IL_FLD(list_idx2)             = IR_Tbl_Idx;
   IL_IDX(list_idx2)             = div_idx;

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
   list_idx2 = IL_NEXT_LIST_IDX(list_idx2);

   IL_FLD(list_idx2)    = CN_Tbl_Idx;
   IL_IDX(list_idx2)      = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx2) = line;
   IL_COL_NUM(list_idx2)  = col;

   IR_FLD_L(div_idx)            = IR_Tbl_Idx;
   IR_IDX_L(div_idx)            = plus_idx;

   IR_FLD_L(plus_idx)   = IR_Tbl_Idx;
   IR_IDX_L(plus_idx)   = sub_idx;
   
   /* start */
   COPY_OPND(topnd, IL_OPND(list_idx));
   copy_subtree(&topnd, &topnd);
   COPY_OPND(IR_OPND_R(sub_idx), topnd);

   foldable = foldable && (IL_FLD(list_idx) == CN_Tbl_Idx ||
                           SHAPE_FOLDABLE(IL_OPND(list_idx)));
   will_fold_later = will_fold_later && 
                     SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx));

   list_idx = IL_NEXT_LIST_IDX(list_idx);

   /* end */
   COPY_OPND(topnd, IL_OPND(list_idx));
   copy_subtree(&topnd, &topnd);
// Bug 2364
# ifdef KEY
   change_extent(&topnd);
# endif
   COPY_OPND(IR_OPND_L(sub_idx), topnd);

   foldable = foldable && (IL_FLD(list_idx) == CN_Tbl_Idx ||
                           SHAPE_FOLDABLE(IL_OPND(list_idx)));
   will_fold_later = will_fold_later && 
                     SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx));

   list_idx = IL_NEXT_LIST_IDX(list_idx);

   /* stride */
   COPY_OPND(topnd, IL_OPND(list_idx));
   copy_subtree(&topnd, &topnd);
   COPY_OPND(IR_OPND_R(div_idx), topnd);

   COPY_OPND(topnd, IL_OPND(list_idx));
   copy_subtree(&topnd, &topnd);
   COPY_OPND(IR_OPND_R(plus_idx), topnd);

   foldable = foldable && (IL_FLD(list_idx) == CN_Tbl_Idx ||
                           SHAPE_FOLDABLE(IL_OPND(list_idx)));
   will_fold_later = will_fold_later && 
                     SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx));

   if (foldable) {
      save_xref_state = xref_state;
      xref_state      = CIF_No_Usage_Rec;
      save_expr_mode  = expr_mode;
      expr_mode       = Regular_Expr;

      exp_desc.rank   = 0;
      unused = expr_semantics(opnd, &exp_desc);
      xref_state = save_xref_state;
      expr_mode  = save_expr_mode;

      SHAPE_FOLDABLE((*opnd))         = exp_desc.foldable;
      SHAPE_WILL_FOLD_LATER((*opnd))  = exp_desc.will_fold_later;
   }
   else {
      SHAPE_FOLDABLE((*opnd))         = foldable;
      SHAPE_WILL_FOLD_LATER((*opnd))  = will_fold_later;
   }


   TRACE (Func_Exit, "make_triplet_extent_tree", NULL);

   return;

}  /* make_triplet_extent_tree */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  This routine provides an interface into the assignment semantics      *|
|*      table. It is provided for parameter and data stmt semantic checking.  *|
|*      The "right hand side" is assumed to be a constant. Rank is not checked*|
|*      If the types and aux types combination is allowed TRUE is returned,   *|
|*      else FALSE.                                                           *|
|*                        *|
|* Input parameters:                    *|
|*  l_type    type index of left hand side.                         *|
|*  r_type    type index of right hand side.                        *|
|*      line, col       line and col to use for messages.                     *|
|*                      if line == -1, don't issue message.                   *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  TRUE if assignment is allowed, FALSE otherwise.                       *|
|*                        *|
\******************************************************************************/

boolean check_asg_semantics(int   l_new_type_idx,
                            int   r_new_type_idx,
                            int   line,
                            int   col)

{
   boolean    correct   = TRUE;
   linear_type_type exp_idx_l;
   linear_type_type exp_idx_r;


   TRACE (Func_Entry, "check_asg_semantics", NULL);

   exp_idx_l = TYP_LINEAR(l_new_type_idx);
   exp_idx_r = TYP_LINEAR(r_new_type_idx);

   if (TYP_TYPE(r_new_type_idx) == Character &&
       compare_cn_and_value(TYP_IDX(r_new_type_idx),
                            MAX_CHARS_IN_TYPELESS, 
                            Le_Opr)) {
      exp_idx_r = Short_Char_Const;
   }

   if (ASG_TYPE(exp_idx_l, exp_idx_r) == Err_Res) {
      correct = FALSE;
   }
   else if (ASG_TYPE(exp_idx_l, exp_idx_r) == Structure_Type &&
            !compare_derived_types(l_new_type_idx, r_new_type_idx)) {
      correct = FALSE;
   }

   if (correct                               &&
       ASG_EXTN(exp_idx_l, exp_idx_r)        &&
       TYP_TYPE(r_new_type_idx) == Character &&
       line != -1)                           {

      PRINTMSG(line, 161, Ansi, col);
   }

   TRACE (Func_Exit, "check_asg_semantics", NULL);

   return(correct);

}  /* check_asg_semantics */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Creates a whole dope vector copy for pointer assignment from a pointer*|
|*                        *|
|* Input parameters:                    *|
|*  l_opnd - left hand side of ptr assignment.                            *|
|*      r_opnd - right hand side of ptr assignment.                           *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

void ptr_assign_from_ptr(opnd_type  *l_opnd,
             opnd_type  *r_opnd)

{
   int            column;
   int      dv_idx;
   int            line;
   sh_position_type location;
   opnd_type      opnd;


   TRACE (Func_Entry, "ptr_assign_from_ptr", NULL);

   location = (SH_LABELED(curr_stmt_sh_idx)) ? After : Before;


   /**********************************\
   |* VECTOR COPY WHOLE DOPE VECTOR. *|
   \**********************************/

   NTR_IR_TBL(dv_idx);

   IR_OPR(dv_idx) = Dv_Whole_Copy_Opr;
   IR_TYPE_IDX(dv_idx) = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(dv_idx) = stmt_start_line;
   IR_COL_NUM(dv_idx)  = stmt_start_col;

   COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

   COPY_OPND(opnd, (*r_opnd));

   if (OPND_FLD(opnd) == IR_Tbl_Idx) {

      while (OPND_FLD(opnd) == IR_Tbl_Idx) {
         if (IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) {
            break;
         }
         COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
      }

      if (OPND_FLD(opnd)         != IR_Tbl_Idx ||
          IR_OPR(OPND_IDX(opnd)) != Dv_Deref_Opr) {
         find_opnd_line_and_column(&opnd, &line, &column);
         PRINTMSG(line, 976, Internal, column);
      }
      else {
         COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
      }
   }
   else {
      find_opnd_line_and_column(&opnd, &line, &column);
      PRINTMSG(line, 977, Internal, column);
   }

   COPY_OPND(IR_OPND_R(dv_idx), opnd);

   gen_sh(location, Assignment_Stmt, stmt_start_line,
          stmt_start_col, FALSE, FALSE, TRUE);

   if (location == Before) {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
   }
   else {
      SH_IR_IDX(curr_stmt_sh_idx) = dv_idx;
   }


   /*************************************\
   |* SET FLAGS BACK TO ORIGINAL VALUES *|
   \*************************************/

   NTR_IR_TBL(dv_idx);
   IR_OPR(dv_idx) = Dv_Set_P_Or_A;
   IR_TYPE_IDX(dv_idx) = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(dv_idx) = stmt_start_line;
   IR_COL_NUM(dv_idx)  = stmt_start_col;

   COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

   IR_FLD_R(dv_idx) = CN_Tbl_Idx;
   IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
   IR_LINE_NUM_R(dv_idx) = stmt_start_line;
   IR_COL_NUM_R(dv_idx)  = stmt_start_col;
   
   gen_sh(location, Assignment_Stmt, stmt_start_line,
          stmt_start_col, FALSE, FALSE, TRUE);

   if (location == Before) {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
   }
   else {
      SH_IR_IDX(curr_stmt_sh_idx) = dv_idx;
   }

   TRACE (Func_Exit, "ptr_assign_from_ptr", NULL);

   return;

}  /* ptr_assign_from_ptr */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Create the length (max(0,length)) operand for substring oprs.         *|
|*                        *|
|* Input parameters:                    *|
|*  sub_idx - IR_Tbl_Idx for substring opr.                               *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

void  add_substring_length(int  sub_idx)

{
   int           col;
   int           end_idx;
   expr_arg_type       exp_desc;
   boolean             foldit;
   int           line;
   int           list_idx;
   int           list2_idx;
   int           max_idx;
   int           minus_idx;
   boolean             ok;
   opnd_type           opnd;
   int           plus_idx;
   expr_mode_type      save_expr_mode;
   cif_usage_code_type save_xref_state;
   int           start_idx;


   TRACE (Func_Entry, "add_substring_length", NULL);

   start_idx = IR_IDX_R(sub_idx);
   end_idx   = IL_NEXT_LIST_IDX(start_idx);

   if (IL_FLD(start_idx) == NO_Tbl_Idx ||
       IL_FLD(end_idx)   == NO_Tbl_Idx) {

      goto EXIT;
   }

   foldit = (IL_FLD(start_idx) == CN_Tbl_Idx) &&
            (IL_FLD(end_idx)   == CN_Tbl_Idx);

   line      = IR_LINE_NUM(sub_idx);
   col       = IR_COL_NUM(sub_idx);

   save_expr_mode = expr_mode;

   NTR_IR_LIST_TBL(list_idx);
   IL_PREV_LIST_IDX(list_idx) = end_idx;
   IL_NEXT_LIST_IDX(end_idx)  = list_idx;
   IR_LIST_CNT_R(sub_idx)++;

   NTR_IR_TBL(max_idx);
   IR_OPR(max_idx)    = Max_Opr;
   IR_TYPE_IDX(max_idx)   = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(max_idx)   = line;
   IR_COL_NUM(max_idx)    = col;

   IL_FLD(list_idx) = IR_Tbl_Idx;
#ifdef KEY /* Bug 11922 */
   /*
    * When the -i8 option is on, what should be the type of the integer
    * lengths of character data? Throughout the front end, the assumption is
    * that the lengths are Integer_4 (e.g. in the extra integer arguments
    * passed to a procedure with character*(*) dummy arguments.) And the
    * code below this comment consistently uses CG_INTEGER_DEFAULT_TYPE, which
    * remains Integer_4 even under -i8.
    *
    * However, under -i8 the subscripts of this expression are likely to be
    * Integer_8, and they will force all the Integer_4 stuff to be converted
    * upward. If we do not generate an explicit conversion back to Integer_4,
    * then procedure calls, string comparison intrinsics, etc will fail under
    * -i8 -m32 because they expect Integer_4.
    */
   if (cmd_line_flags.s_integer8) {
     int convert_idx = gen_ir(IR_Tbl_Idx, max_idx, Cvrt_Opr,
       CG_INTEGER_DEFAULT_TYPE, line, col, NO_Tbl_Idx, NULL_IDX);
     IL_IDX(list_idx) = convert_idx;
   }
   else
#endif /* KEY Bug 11922 */
     IL_IDX(list_idx) = max_idx;

   NTR_IR_LIST_TBL(list2_idx);
   IR_FLD_L(max_idx) = IL_Tbl_Idx;
   IR_LIST_CNT_L(max_idx) = 2;
   IR_IDX_L(max_idx) = list2_idx;

   IL_FLD(list2_idx) = CN_Tbl_Idx;
   IL_IDX(list2_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list2_idx) = line;
   IL_COL_NUM(list2_idx)  = col;

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
   list2_idx = IL_NEXT_LIST_IDX(list2_idx);

   NTR_IR_TBL(plus_idx);
   IR_OPR(plus_idx) = Plus_Opr;
   IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(plus_idx) = line;
   IR_COL_NUM(plus_idx)  = col;

   IL_FLD(list2_idx) = IR_Tbl_Idx;
   IL_IDX(list2_idx) = plus_idx;

   NTR_IR_TBL(minus_idx);
   IR_OPR(minus_idx) = Minus_Opr;
   IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(minus_idx) = line;
   IR_COL_NUM(minus_idx)  = col;

   IR_FLD_R(plus_idx) = IR_Tbl_Idx;
   IR_IDX_R(plus_idx) = minus_idx;

   COPY_OPND(opnd, IL_OPND(start_idx));
   copy_subtree(&opnd, &opnd);
   COPY_OPND(IR_OPND_R(minus_idx), opnd);

   COPY_OPND(opnd, IL_OPND(end_idx));
   copy_subtree(&opnd, &opnd);
   COPY_OPND(IR_OPND_L(plus_idx), opnd);

   IR_FLD_L(minus_idx) = CN_Tbl_Idx;
   IR_IDX_L(minus_idx) = CN_INTEGER_ONE_IDX;
   IR_LINE_NUM_L(minus_idx) = line;
   IR_COL_NUM_L(minus_idx)  = col;

   if (foldit) {
      expr_mode = Regular_Expr;
      save_xref_state = xref_state;
      xref_state      = CIF_No_Usage_Rec;
      COPY_OPND(opnd, IL_OPND(list_idx));
      exp_desc.rank = 0;
      ok = expr_semantics(&opnd, &exp_desc);
      COPY_OPND(IL_OPND(list_idx), opnd);

      expr_mode  = save_expr_mode;
      xref_state = save_xref_state;
   }

EXIT:

   TRACE (Func_Exit, "add_substring_length", NULL);

   return;

}  /* add_substring_length */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Do semantic checks for array constructor implied do's                 *|
|*                        *|
|* Input parameters:                    *|
|*  top_opnd - opnd pointing to IL_Tbl_Idx.                               *|
|*                        *|
|* Output parameters:                   *|
|*      exp_desc - exp_desc for array constructor.                            *|
|*                        *|
|* Returns:                     *|
|*  TRUE if no errors.                                                    *|
|*                        *|
\******************************************************************************/

static boolean array_construct_semantics(opnd_type      *top_opnd,
                 expr_arg_type  *exp_desc)

{
   int      column;
   boolean    constant_trip = TRUE;
#ifdef KEY /* Bug 10177 */
   int      do_var_idx = 0;
#else /* KEY Bug 10177 */
   int      do_var_idx;
#endif /* KEY Bug 10177 */
   boolean              do_var_ok;
   boolean              first_item = TRUE;
   int      line;
   expr_arg_type        loc_exp_desc;
   opnd_type    initial_opnd;
#ifdef KEY /* Bug 10177 */
   int                  list_idx = 0;
   int                  list2_idx;
   int      new_do_var_idx = 0;
#else /* KEY Bug 10177 */
   int                  list_idx;
   int                  list2_idx;
   int      new_do_var_idx;
#endif /* KEY Bug 10177 */
   opnd_type            opnd;
   boolean              ok    = TRUE;
   expr_mode_type save_expr_mode;
   boolean              save_in_implied_do;
   cif_usage_code_type  save_xref_state;
   long_type    the_constant[MAX_WORDS_FOR_NUMERIC];
   int      type_idx;


   TRACE (Func_Entry, "array_construct_semantics", NULL);

   if (OPND_FLD((*top_opnd)) == NO_Tbl_Idx) {
      goto EXIT;
   }
   if (OPND_FLD((*top_opnd)) == IL_Tbl_Idx) {
      list_idx = OPND_IDX((*top_opnd));
   }
   else {
      find_opnd_line_and_column(top_opnd, &line, &column);
      PRINTMSG(line, 978, Internal, column);
   }

#ifdef KEY /* Bug 8004 */
   boolean needs_char_padding = FALSE;
#endif /* KEY Bug 8004 */
   while (list_idx != NULL_IDX) {

      IL_HAS_FUNCTIONS(list_idx) = FALSE;

      constant_trip = TRUE;

      if (IL_FLD(list_idx)         == IR_Tbl_Idx      &&
          IR_OPR(IL_IDX(list_idx)) == Implied_Do_Opr) {

         list2_idx = IL_NEXT_LIST_IDX(IR_IDX_R(IL_IDX(list_idx)));

         /* skip do variable processing until the control values are done. */

         /***********************\
         |* do do initial value *|
         \***********************/

         COPY_OPND(initial_opnd, IL_OPND(list2_idx));
         loc_exp_desc.rank = 0;
         number_of_functions = 0;
         save_xref_state     = xref_state;
         xref_state          = CIF_Symbol_Reference;
         ok = expr_sem(&initial_opnd, &loc_exp_desc) && ok;
         COPY_OPND(IL_OPND(list2_idx), initial_opnd);
         xref_state          = save_xref_state;

         IL_ARG_DESC_VARIANT(list2_idx) = TRUE;

         /* save exp_desc */
         arg_info_list_base      = arg_info_list_top;
         arg_info_list_top       = arg_info_list_base + 1;

         if (arg_info_list_top >= arg_info_list_size) {
            enlarge_info_list_table();
         }

         IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top;
         arg_info_list[arg_info_list_top]    = init_arg_info;
         arg_info_list[arg_info_list_top].ed = loc_exp_desc;

         constant_trip = loc_exp_desc.foldable ||
                         loc_exp_desc.will_fold_later;

         if (number_of_functions > 0) {
            IL_HAS_FUNCTIONS(list2_idx) = TRUE;
            IL_HAS_FUNCTIONS(list_idx)  = TRUE;
         }
         else {
            IL_HAS_FUNCTIONS(list2_idx) = FALSE;
         }

         if (loc_exp_desc.rank != 0) {
            find_opnd_line_and_column(&initial_opnd, &line, &column);
            PRINTMSG(line, 476, Error, column);
            ok = FALSE;
         }

         if (loc_exp_desc.linear_type == Long_Typeless) {
            find_opnd_line_and_column(&initial_opnd, &line, &column);
            PRINTMSG(line, 1133, Error, column);
            ok = FALSE;
         }
         else if (loc_exp_desc.type != Integer   &&
                  loc_exp_desc.type != Typeless) {
            find_opnd_line_and_column(&initial_opnd, &line, &column);
            PRINTMSG(line, 962, Error, column);
            ok = FALSE;
         }
         else if (loc_exp_desc.linear_type == Short_Typeless_Const) {
            find_opnd_line_and_column(&initial_opnd, &line, &column);
            IL_IDX(list2_idx) = cast_typeless_constant(IL_IDX(list2_idx),
                   INTEGER_DEFAULT_TYPE,
                   line,
                   column);
            loc_exp_desc.type_idx    = INTEGER_DEFAULT_TYPE;
            loc_exp_desc.type        = Integer;
            loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
            COPY_OPND(initial_opnd, IL_OPND(list2_idx));
         }

         list2_idx = IL_NEXT_LIST_IDX(list2_idx);

         /************************\
         |* do do terminal value *|
         \************************/

         COPY_OPND(opnd, IL_OPND(list2_idx));
         loc_exp_desc.rank = 0;
         number_of_functions = 0;
         save_xref_state     = xref_state;
         xref_state          = CIF_Symbol_Reference;
         ok = expr_sem(&opnd, &loc_exp_desc) && ok;
         COPY_OPND(IL_OPND(list2_idx), opnd);
         xref_state          = save_xref_state;

         IL_ARG_DESC_VARIANT(list2_idx) = TRUE;

         /* save exp_desc */
         arg_info_list_base      = arg_info_list_top;
         arg_info_list_top       = arg_info_list_base + 1;

         if (arg_info_list_top >= arg_info_list_size) {
            enlarge_info_list_table();
         }

         IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top;
         arg_info_list[arg_info_list_top]    = init_arg_info;
         arg_info_list[arg_info_list_top].ed = loc_exp_desc;

         constant_trip &= loc_exp_desc.foldable ||
                         loc_exp_desc.will_fold_later;

         if (number_of_functions > 0) {
            IL_HAS_FUNCTIONS(list2_idx) = TRUE;
            IL_HAS_FUNCTIONS(list_idx)  = TRUE;
         }
         else {
            IL_HAS_FUNCTIONS(list2_idx) = FALSE;
         }

         if (loc_exp_desc.rank != 0) {
            find_opnd_line_and_column(&opnd, &line, &column);
            PRINTMSG(line, 476, Error, column);
            ok = FALSE;
         }

         if (loc_exp_desc.linear_type == Long_Typeless) {
            find_opnd_line_and_column(&opnd, &line, &column);
            PRINTMSG(line, 1133, Error, column);
            ok = FALSE;
         }
         else if (loc_exp_desc.type != Integer   &&
                  loc_exp_desc.type != Typeless) {

            find_opnd_line_and_column(&opnd, &line, &column);
            PRINTMSG(line, 962, Error, column);
            ok = FALSE;
         }
         else if (loc_exp_desc.linear_type == Short_Typeless_Const) {
            find_opnd_line_and_column(&opnd, &line, &column);
            IL_IDX(list2_idx) = cast_typeless_constant(IL_IDX(list2_idx),
                                                       INTEGER_DEFAULT_TYPE,
                                                       line,
                                                       column);
            loc_exp_desc.type_idx    = INTEGER_DEFAULT_TYPE;
            loc_exp_desc.type        = Integer;
            loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
         }


         /********************************\
         |* do do stride if there is one *|
         \********************************/

         if (IL_NEXT_LIST_IDX(list2_idx) != NULL_IDX) {
            list2_idx = IL_NEXT_LIST_IDX(list2_idx);
            COPY_OPND(opnd, IL_OPND(list2_idx));
            loc_exp_desc.rank = 0;
            number_of_functions = 0;
            save_xref_state     = xref_state;
            xref_state          = CIF_Symbol_Reference;
            ok = expr_sem(&opnd, &loc_exp_desc) && ok;
            COPY_OPND(IL_OPND(list2_idx), opnd);
            xref_state          = save_xref_state;

            find_opnd_line_and_column(&opnd, &line, &column);

            IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
   
            /* save exp_desc */
            arg_info_list_base      = arg_info_list_top;
            arg_info_list_top       = arg_info_list_base + 1;

            if (arg_info_list_top >= arg_info_list_size) {
               enlarge_info_list_table();
            }

            IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top;
            arg_info_list[arg_info_list_top]    = init_arg_info;
            arg_info_list[arg_info_list_top].ed = loc_exp_desc;

            constant_trip &= loc_exp_desc.foldable ||
                         loc_exp_desc.will_fold_later;

            if (number_of_functions > 0) {
               IL_HAS_FUNCTIONS(list2_idx) = TRUE;
               IL_HAS_FUNCTIONS(list_idx)  = TRUE;
            }
            else {
               IL_HAS_FUNCTIONS(list2_idx) = FALSE;
            }

            if (loc_exp_desc.rank != 0) {
               PRINTMSG(line, 476, Error, column);
               ok = FALSE;
            }

            if (loc_exp_desc.linear_type == Long_Typeless) {
               PRINTMSG(line, 1133, Error, column);
               ok = FALSE;
            }
            else if (loc_exp_desc.type != Integer   &&
                     loc_exp_desc.type != Typeless) {

               PRINTMSG(line, 962, Error, column);
               ok = FALSE;
            }
            else if (loc_exp_desc.linear_type == Short_Typeless_Const) {
               IL_IDX(list2_idx) = cast_typeless_constant(IL_IDX(list2_idx),
                                                          INTEGER_DEFAULT_TYPE,
                                                          line,
                                                          column);
               loc_exp_desc.type_idx    = INTEGER_DEFAULT_TYPE;
               loc_exp_desc.type        = Integer;
               loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
            }

            if (ok &&
                OPND_FLD(opnd) == CN_Tbl_Idx) {

               type_idx = CG_LOGICAL_DEFAULT_TYPE;

               ok &= folder_driver((char *)&CN_CONST(OPND_IDX(opnd)),
                                 loc_exp_desc.type_idx,
                                 (char *)&CN_CONST(CN_INTEGER_ZERO_IDX),
                                 CG_INTEGER_DEFAULT_TYPE,
                                 the_constant,
                                 &type_idx,
                                 line,
                                 column,
                                 2,
                                 Eq_Opr);

               if (THIS_IS_TRUE(the_constant, type_idx)) {
                  PRINTMSG(line, 1084, Error, column);
                  ok = FALSE;
               }
            }
         }
         else {
            /* fill in default stride here */
            NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
            list2_idx = IL_NEXT_LIST_IDX(list2_idx);
            IR_LIST_CNT_R(IL_IDX(list_idx))++;
            IL_FLD(list2_idx) = CN_Tbl_Idx;
            IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX;
            IL_LINE_NUM(list2_idx) = stmt_start_line;
            IL_COL_NUM(list2_idx)  = stmt_start_col;
            IL_ARG_DESC_VARIANT(list2_idx) = TRUE;

            /* save exp_desc */
            arg_info_list_base      = arg_info_list_top;
            arg_info_list_top       = arg_info_list_base + 1;

            if (arg_info_list_top >= arg_info_list_size) {
               enlarge_info_list_table();
            }

            IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top;
            arg_info_list[arg_info_list_top]     = init_arg_info;
            arg_info_list[arg_info_list_top].ed.constant = TRUE;
            arg_info_list[arg_info_list_top].ed.foldable = TRUE;
            arg_info_list[arg_info_list_top].ed.type   = Integer;
            arg_info_list[arg_info_list_top].ed.type_idx = 
                                                       CG_INTEGER_DEFAULT_TYPE;
            arg_info_list[arg_info_list_top].ed.linear_type = 
                                                       CG_INTEGER_DEFAULT_TYPE;
         }

         /**************************\
         |* do do control variable *|
         \**************************/

         list2_idx = IR_IDX_R(IL_IDX(list_idx));

         do_var_ok = TRUE;
         COPY_OPND(opnd, IL_OPND(list2_idx));
         loc_exp_desc.rank   = 0;
         number_of_functions = 0;
         save_xref_state     = xref_state;
         xref_state          = CIF_No_Usage_Rec;
         save_in_implied_do = in_implied_do;
         in_implied_do      = FALSE;
         save_expr_mode = expr_mode;
         expr_mode = Regular_Expr;
         do_var_ok = expr_sem(&opnd, &loc_exp_desc);
         COPY_OPND(IL_OPND(list2_idx), opnd);
         expr_mode     = save_expr_mode;
         in_implied_do = save_in_implied_do;
         xref_state    = save_xref_state;

         if (number_of_functions > 0) {
            IL_HAS_FUNCTIONS(list2_idx) = TRUE;
            IL_HAS_FUNCTIONS(list_idx)  = TRUE;
         }
         else {
            IL_HAS_FUNCTIONS(list2_idx) = FALSE;
         }

/* BHJ JLS LRR ... need interpretation for this one. imp do var must be */
/* "named" scalar variable, not sub-object.                             */
         if (!loc_exp_desc.reference) {
            find_opnd_line_and_column(&opnd, &line, &column);
            PRINTMSG(line, 481, Error, column);
            do_var_ok = FALSE;
         }
         else {

            if (loc_exp_desc.type != Integer) {
               find_opnd_line_and_column(&opnd, &line, &column);
               PRINTMSG(line, 675, Error, column);
               do_var_ok = FALSE;
            }

            if (OPND_FLD(opnd) == IR_Tbl_Idx                   &&
                IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
               COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            }

            if (OPND_FLD(opnd) == IR_Tbl_Idx            &&
                IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) {
               COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            }

            if (do_var_ok                     &&
                OPND_FLD(opnd) != AT_Tbl_Idx) {
               find_opnd_line_and_column(&opnd, &line, &column);
               PRINTMSG(line, 530, Error, column);
               do_var_ok = FALSE;
            }
            else {
               do_var_idx = OPND_IDX(opnd);
            }

            if (do_var_ok          &&
                loc_exp_desc.rank) {
               find_opnd_line_and_column(&opnd, &line, &column);
               PRINTMSG(line, 837, Ansi, column);
            }

         }

         if (do_var_ok) {

            if (AT_ATTR_LINK(do_var_idx)) {
               find_opnd_line_and_column(&opnd, &line, &column);
               PRINTMSG(line, 533, Error, column,
                        AT_OBJ_NAME_PTR(do_var_idx));
               do_var_ok = FALSE;
            }
            else {
               find_opnd_line_and_column(&opnd, &line, &column);
               new_do_var_idx = gen_compiler_tmp(line, column, Priv, TRUE);
               AT_SEMANTICS_DONE(new_do_var_idx)= TRUE;
               ATD_TYPE_IDX(new_do_var_idx) = ATD_TYPE_IDX(do_var_idx);
               ATD_STOR_BLK_IDX(new_do_var_idx) =
                                              SCP_SB_STACK_IDX(curr_scp_idx);

               /* change name to original name */
               AT_NAME_IDX(new_do_var_idx) = AT_NAME_IDX(do_var_idx);
               AT_NAME_LEN(new_do_var_idx) = AT_NAME_LEN(do_var_idx);

               ATD_TMP_IDX(new_do_var_idx)      = constructor_level;
               AT_ATTR_LINK(do_var_idx)         = new_do_var_idx;
               AT_IGNORE_ATTR_LINK(do_var_idx)  = TRUE;

               ATD_IMP_DO_LCV(new_do_var_idx)   = TRUE;
               ATD_LCV_IS_CONST(new_do_var_idx) = constant_trip;
               ATD_TMP_NEEDS_CIF(new_do_var_idx) = TRUE;

               IL_FLD(list2_idx) = AT_Tbl_Idx;
               IL_IDX(list2_idx) = new_do_var_idx;
               IL_LINE_NUM(list2_idx) = line;
               IL_COL_NUM(list2_idx)  = column;

               /* issue a usage rec if needed */
               if ((cif_flags & XREF_RECS) != 0) {
                  cif_usage_rec(new_do_var_idx, AT_Tbl_Idx, line, column, 
                                CIF_Symbol_Modification);
               }

            }
         }

         ok = ok && do_var_ok;

         /***********************\
         |* do list of io items *|
         \***********************/

         in_implied_do = TRUE;
         COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx)));
         number_of_functions = 0;
         ok = array_construct_semantics(&opnd, &loc_exp_desc) && ok;
         COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), opnd);

         if (number_of_functions > 0) {
            IL_HAS_FUNCTIONS(list_idx)  = TRUE;
         }

         IR_TYPE_IDX(IL_IDX(list_idx))  = loc_exp_desc.type_idx;

         if (do_var_ok) {
            /* clear the AT_ATTR_LINK field of the old do var attr */
            AT_ATTR_LINK(do_var_idx)        = NULL_IDX;
            AT_IGNORE_ATTR_LINK(do_var_idx) = FALSE;

            /* clear the ATD_TMP_IDX on new_do_var_idx. */
            /* it held the constructor_level.           */
            ATD_TMP_IDX(new_do_var_idx) = NULL_IDX;

            /* now set the initial opnd on the tmp_idx field */
            ATD_FLD(new_do_var_idx) = OPND_FLD(initial_opnd);
            ATD_TMP_IDX(new_do_var_idx) = OPND_IDX(initial_opnd);
         }

         in_implied_do = save_in_implied_do;
      }
      else {

         loc_exp_desc.rank = 0;
         COPY_OPND(opnd, IL_OPND(list_idx));
         number_of_functions = 0;

         save_xref_state = xref_state;
         xref_state = CIF_Symbol_Reference;

         ok = expr_sem(&opnd, &loc_exp_desc) && ok;

         xref_state = save_xref_state;

         if (loc_exp_desc.linear_type == Short_Typeless_Const) {
            find_opnd_line_and_column((opnd_type *) &opnd, &line, &column);
            OPND_IDX(opnd) = cast_typeless_constant(OPND_IDX(opnd),
                                                    INTEGER_DEFAULT_TYPE,
                                                    line,
                                                    column);

            loc_exp_desc.type_idx = INTEGER_DEFAULT_TYPE;
            loc_exp_desc.type = Integer;
            loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
         }

         COPY_OPND(IL_OPND(list_idx), opnd);
                                                    
         IL_ARG_DESC_VARIANT(list_idx) = TRUE;

         /* save exp_desc */
         arg_info_list_base      = arg_info_list_top;
         arg_info_list_top       = arg_info_list_base + 1;

         if (arg_info_list_top >= arg_info_list_size) {
            enlarge_info_list_table();
         }

         IL_ARG_DESC_IDX(list_idx) = arg_info_list_top;
         arg_info_list[arg_info_list_top]    = init_arg_info;
         arg_info_list[arg_info_list_top].ed = loc_exp_desc;

         if (number_of_functions > 0) {
            IL_HAS_FUNCTIONS(list_idx)  = TRUE;
         }

      }

      if (first_item) {
         if (loc_exp_desc.linear_type == Typeless_4 ||
             loc_exp_desc.linear_type == Typeless_8) {
            exp_desc->type_idx    = INTEGER_DEFAULT_TYPE; 
            exp_desc->type        = Integer;
            exp_desc->linear_type = INTEGER_DEFAULT_TYPE;
         }
         else {
            exp_desc->type        = loc_exp_desc.type;
            exp_desc->type_idx    = loc_exp_desc.type_idx;
            exp_desc->linear_type = loc_exp_desc.linear_type;
         }

         COPY_OPND((exp_desc->char_len), (loc_exp_desc.char_len));
         exp_desc->constant = loc_exp_desc.constant;
         exp_desc->foldable = loc_exp_desc.foldable && constant_trip;
         exp_desc->will_fold_later = (loc_exp_desc.will_fold_later ||
                                      loc_exp_desc.foldable) && constant_trip;
         exp_desc->has_symbolic = loc_exp_desc.has_symbolic;
         first_item  = FALSE;
      }
      else {
      
         if ((loc_exp_desc.linear_type == Typeless_4 ||
              loc_exp_desc.linear_type == Typeless_8) &&
             exp_desc->linear_type == INTEGER_DEFAULT_TYPE) {

            /* intentionally blank */
         }
         else if (exp_desc->type != loc_exp_desc.type) {

            find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
                                      &line, &column);
            PRINTMSG(line, 829, Error, column);
            ok = FALSE;
         }
         else if (exp_desc->type == Structure &&
                 !compare_derived_types(exp_desc->type_idx,
                                        loc_exp_desc.type_idx)) {
            find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
                                      &line, &column);
            PRINTMSG(line, 829, Error, column);
            ok = FALSE;
         }
         else if (exp_desc->type == Character) {

            if (loc_exp_desc.char_len.fld == CN_Tbl_Idx) {

               if (exp_desc->char_len.fld == CN_Tbl_Idx) {

               if (
#ifdef KEY /* Bug 8004 */
    /*
     * F95 requires that all char lengths inside an array ctor
     * be the same, but doesn't state that as a numbered
     * constraint, so this Ansi message isn't strictly needed.
     * F2003 requires they be the same unless there's an explicit
     * type-spec inside the constructor brackets, but still
     * doesn't state that as a numbered constraint. Due to
     * this change, our behavior is more generous than even
     * F2003: we use the max of the lengths if there is
     * no explicit type-spec. When we add parsing for the
     * explicit type-spec, that will impact the following code.
     */
                on_off_flags.issue_ansi_messages &&
#endif /* KEY Bug 8004 */
                  fold_relationals(loc_exp_desc.char_len.idx,
                                       exp_desc->char_len.idx,
                                       Ne_Opr)) {
                     find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
                                               &line, &column);
#ifdef KEY /* Bug 8004 */
                     PRINTMSG(line, 838, Ansi, column);
#else /* KEY Bug 8004 */
                     PRINTMSG(line, 838, Error, column);
                     ok = FALSE;
#endif /* KEY Bug 8004 */
                  }
/* KEY Bug 8004 # if 0 */
                  /* if we ever extend the above constraint, */
                  /* then include this code.                 */

                  if (fold_relationals(loc_exp_desc.char_len.idx,
                                       exp_desc->char_len.idx,
                                       Gt_Opr)) {

                     COPY_OPND((exp_desc->char_len), (loc_exp_desc.char_len));
#ifdef KEY /* Bug 8004 */
                     exp_desc->type_idx = loc_exp_desc.type_idx;
         needs_char_padding =
           (loc_exp_desc.char_len.fld == CN_Tbl_Idx);
#endif /* KEY Bug 8004 */
                  }
/* KEY Bug 8004 # endif */
               }
               else {
                  /* replace the char_len with the simpler length */
                  COPY_OPND((exp_desc->char_len), (loc_exp_desc.char_len));
               }
            }
         }
         else if (exp_desc->linear_type != loc_exp_desc.linear_type) {
            find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
                                      &line, &column);
            PRINTMSG(line, 829, Error, column);
            ok = FALSE;
         }

         exp_desc->has_symbolic |= loc_exp_desc.has_symbolic;
         exp_desc->constant &= loc_exp_desc.constant;
         exp_desc->foldable &= loc_exp_desc.foldable && constant_trip;
         exp_desc->will_fold_later &= (loc_exp_desc.will_fold_later ||
                                      loc_exp_desc.foldable) &&
                                       constant_trip;
      }
             
      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }

#ifdef KEY /* Bug 8004 */
   /* We now allow a character constructor to have elements of differing
    * lengths. For variables and for constructors used to initialize
    * fixed-length character types, enabling the change above (which existed
    * in the original Open64 distribution but was disabled) suffices. For
    * a constructor used to initialize a "character*(*), parameter"
    * however, we need to make each element be the correct size (the
    * alternative was more extensive surgery on interpret_constructor and
    * interpret_array_construct_opr in s_cnstrct.c.)
    */
   if (needs_char_padding && exp_desc->constant &&
      exp_desc->char_len.fld == CN_Tbl_Idx) {
      long desired_length = CN_CONST(exp_desc->char_len.idx);
      for (list_idx = OPND_IDX((*top_opnd)); list_idx != NULL_IDX; 
   list_idx = IL_NEXT_LIST_IDX(list_idx)) {
   opnd_type opnd = IL_OPND(list_idx);
   long actual_length = 0;
   if (opnd.fld == CN_Tbl_Idx && desired_length !=
     (actual_length = CN_CONST(TYP_IDX(CN_TYPE_IDX(opnd.idx))))) {
     int char_idx = ntr_const_tbl(exp_desc->type_idx, TRUE, NULL);
     char *char_ptr = (char *) &CN_CONST(char_idx);
     memset(char_ptr, ' ', desired_length);
     memcpy(char_ptr, (char *) &CN_CONST(opnd.idx), actual_length);
     IL_OPND(list_idx).idx = char_idx;
   }
      }
   }
#endif /* KEY Bug 8004 */


EXIT:

   TRACE (Func_Exit, "array_construct_semantics", NULL);

   return(ok);

}  /* array_construct_semantics */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Do semantic checks on the stmt function definition.                   *|
|*                        *|
|* Input parameters:                    *|
|*  stmt_func_idx - attr idx for stmt function.                           *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  TRUE if no errors.                                                    *|
|*                        *|
\******************************************************************************/

boolean stmt_func_semantics(int                 stmt_func_idx)

{
   expr_arg_type        exp_desc;
   int                  i;
   linear_type_type     linear_type;
   boolean              ok              = TRUE;
   opnd_type            opnd;
   expr_mode_type       save_expr_mode;
   boolean              save_no_func_expansion;
   boolean    save_parallel_region;
   cif_usage_code_type  save_xref_state;
   int                  sn_idx;


   TRACE (Func_Entry, "stmt_func_semantics", NULL);

#ifdef KEY /* Bug 4232 */
   defining_stmt_func = TRUE;
#endif /* KEY Bug 4232 */

   ATS_SF_SEMANTICS_DONE(stmt_func_idx) = TRUE;

   /* clear the ATD_SF_DARG flag */

   sn_idx = ATP_FIRST_IDX(stmt_func_idx);

   for (i = 0; i < ATP_NUM_DARGS(stmt_func_idx); i++) {
      ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = FALSE;
      sn_idx++;
   }

   OPND_FLD(opnd) = (fld_type) ATS_SF_FLD(stmt_func_idx);
   OPND_IDX(opnd) = ATS_SF_IDX(stmt_func_idx);
   copy_subtree(&opnd, &opnd);

   ATS_SF_ACTIVE(stmt_func_idx) = TRUE;

   save_parallel_region = cdir_switches.parallel_region;
   cdir_switches.parallel_region = FALSE;
   save_no_func_expansion       = no_func_expansion;
   no_func_expansion            = TRUE;
   save_xref_state              = xref_state;
   xref_state                   = CIF_Symbol_Reference;
   save_expr_mode               = expr_mode;
   expr_mode                    = Stmt_Func_Expr;

   ok                           &= expr_semantics(&opnd, &exp_desc);

   expr_mode                    = save_expr_mode;
   xref_state                   = save_xref_state;
   no_func_expansion            = save_no_func_expansion;
   cdir_switches.parallel_region = save_parallel_region;
   ATS_SF_ACTIVE(stmt_func_idx) = FALSE;

   /* set the ATD_SF_DARG flag */

   sn_idx = ATP_FIRST_IDX(stmt_func_idx);

   for (i = 0; i < ATP_NUM_DARGS(stmt_func_idx); i++) {
      ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = TRUE;
      sn_idx++;
   }


   if (exp_desc.rank != 0) {

      /* stmt func must be rank zero */

      PRINTMSG(AT_DEF_LINE(stmt_func_idx), 755, Error,
               AT_DEF_COLUMN(stmt_func_idx),
               AT_OBJ_NAME_PTR(stmt_func_idx));
      ok = FALSE;
      AT_DCL_ERR(stmt_func_idx) = TRUE;
   }

   linear_type = TYP_LINEAR(ATD_TYPE_IDX(stmt_func_idx));

   if (ASG_TYPE(linear_type, exp_desc.linear_type) == Err_Res) {
      PRINTMSG(AT_DEF_LINE(stmt_func_idx), 756, Error,
               AT_DEF_COLUMN(stmt_func_idx),
               AT_OBJ_NAME_PTR(stmt_func_idx));
      ok = FALSE;
      AT_DCL_ERR(stmt_func_idx) = TRUE;
   }
   else if (ASG_TYPE(linear_type, exp_desc.linear_type) == Structure_Type) {

      if (!compare_derived_types(ATD_TYPE_IDX(stmt_func_idx),
                                 exp_desc.type_idx)) {
         PRINTMSG(AT_DEF_LINE(stmt_func_idx), 756, Error,
                  AT_DEF_COLUMN(stmt_func_idx),
                  AT_OBJ_NAME_PTR(stmt_func_idx));
         ok = FALSE;
         AT_DCL_ERR(stmt_func_idx) = TRUE;
      }
   }

#ifdef KEY /* Bug 4232 */
   defining_stmt_func = FALSE;
#endif /* KEY Bug 4232 */

   TRACE (Func_Exit, "stmt_func_semantics", NULL);

   return(ok);

}  /* stmt_func_semantics */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Do conformance checks for array syntax operators. Also determine      *|
|*      "shape" opnd to pass on for the operation based on analysis of        *|
|*      the right and left shape.                                             *|
|*                        *|
|* Input parameters:                    *|
|*  exp_desc_l - expression descriptor for left operand.                  *|
|*      exp_desc_r - expression descriptor for right operand.                 *|
|*      line, col  - line and column to use for messages.                     *|
|*                        *|
|* Output parameters:                   *|
|*  exp_desc - fills in the result shape in this descriptor.              *|
|*                        *|
|* Returns:                     *|
|*  TRUE if no errors.                                                    *|
|*                        *|
\******************************************************************************/

static boolean bin_array_syntax_check(expr_arg_type *exp_desc_l,
              expr_arg_type *exp_desc_r,
              expr_arg_type *exp_desc,
              int    line,
              int    col)

{
   int      i;
   boolean    ok = TRUE;

   TRACE (Func_Entry, "bin_array_syntax_check", NULL);

   if (exp_desc_r->rank == exp_desc_l->rank) {
      /* conformance check here */

      exp_desc->rank = exp_desc_r->rank;

      for (i = 0; i < exp_desc_r->rank; i++) {

         if (OPND_FLD(exp_desc_l->shape[i]) == CN_Tbl_Idx &&
             OPND_FLD(exp_desc_r->shape[i]) == CN_Tbl_Idx) {

            if (fold_relationals(OPND_IDX(exp_desc_l->shape[i]),
                                 OPND_IDX(exp_desc_r->shape[i]),
                                 Ne_Opr)) {

               /* non conforming array syntax */
               PRINTMSG(line, 252, Error, col);
               ok = FALSE;
               exp_desc->rank = exp_desc_r->rank;
               COPY_SHAPE(exp_desc->shape,exp_desc_r->shape,
                          exp_desc_r->rank);
               break;
            }
            else {
               COPY_OPND(exp_desc->shape[i], exp_desc_l->shape[i]);
            }
         }
         else if (SHAPE_FOLDABLE(exp_desc_l->shape[i])) {
            COPY_OPND(exp_desc->shape[i], exp_desc_l->shape[i]);
         }
         else if (SHAPE_FOLDABLE(exp_desc_r->shape[i])) {
            COPY_OPND(exp_desc->shape[i], exp_desc_r->shape[i]);
         }
         else if (SHAPE_WILL_FOLD_LATER(exp_desc_l->shape[i])) {
            COPY_OPND(exp_desc->shape[i], exp_desc_l->shape[i]);
         }
         else {
            COPY_OPND(exp_desc->shape[i], exp_desc_r->shape[i]);
         }
      }
   }
   else if (exp_desc_r->rank > exp_desc_l->rank) {
      exp_desc->rank = exp_desc_r->rank;
      COPY_SHAPE(exp_desc->shape,exp_desc_r->shape,
                 exp_desc_r->rank);
   }
   else {
      exp_desc->rank = exp_desc_l->rank;
      COPY_SHAPE(exp_desc->shape,exp_desc_l->shape,
                 exp_desc_l->rank);
   }


   TRACE (Func_Exit, "bin_array_syntax_check", NULL);

   return(ok);

}  /* bin_array_syntax_check */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Looks for real division and replaces the div_opr with                 *|
|*      Real_Div_To_Int_Opr if on_off_flags.round_integer_divide is TRUE.     *|
|*      This routine is used when the real division is changed to integer     *|
|*      later (ie. in an assignment).                                         *|
|*                        *|
|* Input parameters:                    *|
|*  opnd - top of tree.                                                   *|
|*                        *|
|* Output parameters:                   *|
|*  opnd - the modified tree.                                             *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

void look_for_real_div(opnd_type *opnd)

{
   int    list_idx;
   opnd_type  lopnd;

   TRACE (Func_Entry, "look_for_real_div", NULL);

   switch (OPND_FLD((*opnd))) {
      case IR_Tbl_Idx:

         if (IR_OPR(OPND_IDX((*opnd))) == Div_Opr &&
             TYP_TYPE(IR_TYPE_IDX(OPND_IDX((*opnd)))) == Real) {

            if (on_off_flags.round_integer_divide) {
               IR_OPR(OPND_IDX((*opnd))) = Real_Div_To_Int_Opr;
            }
            else {
               PRINTMSG(IR_LINE_NUM(OPND_IDX((*opnd))), 938, Caution,
                        IR_COL_NUM(OPND_IDX((*opnd))));
            }
         }

         COPY_OPND(lopnd, IR_OPND_L(OPND_IDX((*opnd))));
         look_for_real_div(&lopnd);
         COPY_OPND(IR_OPND_L(OPND_IDX((*opnd))), lopnd);

         COPY_OPND(lopnd, IR_OPND_R(OPND_IDX((*opnd))));
         look_for_real_div(&lopnd);
         COPY_OPND(IR_OPND_R(OPND_IDX((*opnd))), lopnd);

         break;

      case IL_Tbl_Idx:

         list_idx = OPND_IDX((*opnd));

         while (list_idx) {
            COPY_OPND(lopnd, IL_OPND(list_idx));
            look_for_real_div(&lopnd);
            COPY_OPND(IL_OPND(list_idx), lopnd);
            list_idx = IL_NEXT_LIST_IDX(list_idx);
         }
         break;
   }

   TRACE (Func_Exit, "look_for_real_div", NULL);

   return;

}  /* look_for_real_div */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  Creates a logical array tmp thats necessary for zero length character *|
|*      logical operations. (.eq. ....) We must fold these expressions.       *|
|*                        *|
|* Input parameters:                    *|
|*  top_opnd -  the logical constant to put in array. (scalar)            *|
|*                        *|
|* Output parameters:                   *|
|*  top_opnd - the array ref result.                                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static void make_logical_array_tmp(opnd_type    *top_opnd,
                                   expr_arg_type  *exp_desc)

{
   int      col;
   boolean    constant_shape = TRUE;
   int      i;
   opnd_type    l_opnd;
   int      line;
   expr_arg_type  loc_exp_desc;
   boolean    ok;
   opnd_type    r_opnd;
   boolean    save_check_type_conversion;
   int      save_target_array_idx;
   opnd_type    save_init_target_opnd;
   int      save_target_type_idx;
   int      unused;

   TRACE (Func_Entry, "make_logical_array_tmp", NULL);

   find_opnd_line_and_column(top_opnd, &line, &col);

   for (i = 0; i < exp_desc->rank; i++) {

      if (! SHAPE_FOLDABLE(exp_desc->shape[i])) {
         constant_shape = FALSE;
         break;
      }
   }

   if (constant_shape) {
      save_check_type_conversion = check_type_conversion;
      save_target_array_idx      = target_array_idx;
      save_target_type_idx       = target_type_idx;
      COPY_OPND(save_init_target_opnd, init_target_opnd);

      target_array_idx = create_bd_ntry_for_const(exp_desc, line, col);

      check_type_conversion = TRUE;
      target_type_idx = exp_desc->type_idx;
      init_target_opnd = null_opnd;

      loc_exp_desc.type = exp_desc->type;
      loc_exp_desc.linear_type = exp_desc->linear_type;
      loc_exp_desc.type_idx = exp_desc->type_idx;
      
      ok = fold_aggragate_expression(top_opnd,
                                    &loc_exp_desc,
                                     FALSE);

      check_type_conversion        = save_check_type_conversion;
      COPY_OPND(init_target_opnd, save_init_target_opnd);
      target_type_idx              = save_target_type_idx;
      target_array_idx             = save_target_array_idx;

      exp_desc->tmp_reference = TRUE;
      exp_desc->foldable = TRUE;
   }
   else {

      COPY_OPND(r_opnd, (*top_opnd));
      unused = create_tmp_asg(&r_opnd,
                               exp_desc,
                               &l_opnd,
             Intent_In,
                               FALSE,
                               FALSE);
      COPY_OPND((*top_opnd), l_opnd);
   }

   TRACE (Func_Exit, "make_logical_array_tmp", NULL);

   return;

}  /* make_logical_array_tmp */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  In strange variable function result size calculation, a character     *|
|*      substring reference may involve nested substrings. This routine       *|
|*      folds them into one substring. It is not intended for any other       *|
|*      situation.                                                            *|
|*                        *|
|* Input parameters:                    *|
|*  ir_idx  - IR_Tbl_Idx to the upper Substring_Opr                 *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static void fold_nested_substrings(int  ir_idx)

{
   int      col;
   opnd_type    end_opnd;
   expr_arg_type  exp_desc;
   int      line;
   int      list_idx;
   int      minus_idx;
   boolean    ok;
   opnd_type    opnd;
   int      plus_idx;
   expr_mode_type       save_expr_mode;
   cif_usage_code_type  save_xref_state;
   opnd_type    start_opnd;


   TRACE (Func_Entry, "fold_nested_substrings", NULL);

   if (IR_OPR(IR_IDX_L(ir_idx)) == Whole_Substring_Opr) {
      /* just get rid of the substring opr */
      COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx)));
      goto EXIT;
   }

   list_idx = IR_IDX_R(IR_IDX_L(ir_idx));
   COPY_OPND(start_opnd, IL_OPND(list_idx));

   list_idx = IL_NEXT_LIST_IDX(list_idx);

   COPY_OPND(end_opnd, IL_OPND(list_idx));  /*BRIANJ - end_opnd is not used */

   /* do the start expression */

   list_idx = IR_IDX_R(ir_idx);
   find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), &line, &col);

   NTR_IR_TBL(plus_idx);
   IR_OPR(plus_idx) = Plus_Opr;
   IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(plus_idx) = line;
   IR_COL_NUM(plus_idx) = col;

   COPY_OPND(IR_OPND_L(plus_idx), start_opnd);
   COPY_OPND(IR_OPND_R(plus_idx), IL_OPND(list_idx));
   
   NTR_IR_TBL(minus_idx);
   IR_OPR(minus_idx) = Minus_Opr;
   IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(minus_idx) = line;
   IR_COL_NUM(minus_idx) = col;

   IR_FLD_L(minus_idx) = IR_Tbl_Idx;
   IR_IDX_L(minus_idx) = plus_idx;
   IR_FLD_R(minus_idx) = CN_Tbl_Idx;
   IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX;
   IR_LINE_NUM_R(minus_idx) = line;
   IR_COL_NUM_R(minus_idx) = col;

   OPND_FLD(opnd) = IR_Tbl_Idx;
   OPND_IDX(opnd) = minus_idx;

   /* fold */
   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;
   exp_desc.rank = 0;
   ok = expr_semantics(&opnd, &exp_desc);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;


   COPY_OPND(IL_OPND(list_idx), opnd);


   /* now do the end expression */

   list_idx = IL_NEXT_LIST_IDX(list_idx);

   find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), &line, &col);

   NTR_IR_TBL(plus_idx);
   IR_OPR(plus_idx) = Plus_Opr;
   IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(plus_idx) = line;
   IR_COL_NUM(plus_idx) = col;

   COPY_OPND(IR_OPND_L(plus_idx), start_opnd);
   COPY_OPND(IR_OPND_R(plus_idx), IL_OPND(list_idx));

   NTR_IR_TBL(minus_idx);
   IR_OPR(minus_idx) = Minus_Opr;
   IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(minus_idx) = line;
   IR_COL_NUM(minus_idx) = col;

   IR_FLD_L(minus_idx) = IR_Tbl_Idx;
   IR_IDX_L(minus_idx) = plus_idx;
   IR_FLD_R(minus_idx) = CN_Tbl_Idx;
   IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX;
   IR_LINE_NUM_R(minus_idx) = line;
   IR_COL_NUM_R(minus_idx) = col;

   OPND_FLD(opnd) = IR_Tbl_Idx;
   OPND_IDX(opnd) = minus_idx;

   /* fold */
   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;
   exp_desc.rank = 0;
   ok = expr_semantics(&opnd, &exp_desc);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;

   COPY_OPND(IL_OPND(list_idx), opnd);

   /* the length remains unchanged */

   /* now get rid of lower substring */

   COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx)));

EXIT:

   TRACE (Func_Exit, "fold_nested_substrings", NULL);

   return;

}  /* fold_nested_substrings */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  semantic handler for the Uplus_Opr and Uminus_Opr.                    *|
|*                        *|
|* Input parameters:                    *|
|*  NONE                      *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static boolean uplus_opr_handler(opnd_type    *result_opnd,
         expr_arg_type    *exp_desc)

{
   int      col;
   expr_arg_type  exp_desc_l;
   expr_arg_type  exp_desc_r;
   long_type    folded_const[MAX_WORDS_FOR_NUMERIC];
   int      ir_idx;
   int      line;
   boolean    ok = TRUE;
   opnd_type    opnd;
   int      opnd_col;
   int      opnd_line;
   boolean    save_in_call_list;
   int      type_idx;


   TRACE (Func_Entry, "uplus_opr_handler" , NULL);

   ir_idx = OPND_IDX((*result_opnd));
   line   = IR_LINE_NUM(ir_idx);
   col    = IR_COL_NUM(ir_idx);
   save_in_call_list = in_call_list;
   in_call_list = FALSE;

   COPY_OPND(opnd, IR_OPND_L(ir_idx));
   exp_desc_l.rank = 0;
   ok = expr_sem(&opnd, &exp_desc_l);
   COPY_OPND(IR_OPND_L(ir_idx), opnd);

   if (!ok) {
      goto EXIT;
   }

   exp_desc->has_constructor = exp_desc_l.has_constructor;
   exp_desc->has_symbolic = exp_desc_l.has_symbolic;

   exp_desc->linear_type = UN_PLUS_TYPE(exp_desc_l.linear_type);

   if (exp_desc->linear_type != Err_Res) {

      if (UN_PLUS_EXTN(exp_desc_l.linear_type)) {
         /* check for defined operator */
         if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list,
                             FALSE,
                             &ok,
                             &exp_desc_l, &exp_desc_r)) {

            (*exp_desc) = exp_desc_l;

            goto EXIT;
         }
         else if (exp_desc_l.type == Character ||
                  exp_desc_l.linear_type == Short_Typeless_Const) {
            find_opnd_line_and_column((opnd_type *)
                                      &IR_OPND_L(ir_idx),
                                      &opnd_line,
                                      &opnd_col);
            if (exp_desc_l.type == Character) {
               PRINTMSG(opnd_line, 161, Ansi, opnd_col);
            }

            IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx),
                                                      exp_desc->linear_type,
                                                      opnd_line,
                                                      opnd_col);

            exp_desc_l.type_idx    = exp_desc->linear_type;
            exp_desc_l.type        = TYP_TYPE(exp_desc->linear_type);
            exp_desc_l.linear_type = exp_desc->linear_type;
            exp_desc->linear_type = UN_PLUS_TYPE(exp_desc_l.linear_type);
         }

      }

      exp_desc->type_idx = exp_desc->linear_type;
      exp_desc->type     = TYP_TYPE(exp_desc->linear_type);
      exp_desc->rank     = exp_desc_l.rank;
      exp_desc->has_symbolic = exp_desc_l.has_symbolic;
      exp_desc->constant = exp_desc_l.constant;
      exp_desc->foldable = exp_desc_l.foldable;
      exp_desc->will_fold_later = exp_desc_l.will_fold_later;

      if (exp_desc->linear_type == Integer_8) {
         /* check whether it should be 'default' typed */

         if (exp_desc_l.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_l.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_l.type_idx;
         }
      }

      COPY_SHAPE(exp_desc->shape,exp_desc_l.shape,exp_desc_l.rank);

      if (IR_OPR(ir_idx) == Uplus_Opr) {
         COPY_OPND((*result_opnd), IR_OPND_L(ir_idx));
      }
      else if (opt_flags.ieeeconform &&
               ! comp_gen_expr       &&
               (exp_desc_l.type == Real ||
                exp_desc_l.type == Complex)) {

         /* don't fold real arithmatic under ieeeconform */

         exp_desc->foldable = FALSE;
         exp_desc->will_fold_later = FALSE;
      }
      else if (exp_desc_l.rank == 0 &&
               exp_desc_l.foldable &&
               IR_FLD_L(ir_idx) == CN_Tbl_Idx) {

         type_idx = exp_desc->type_idx;

         if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)),
                            exp_desc_l.type_idx,
                            NULL,
                            NULL_IDX,
                            folded_const,
                           &type_idx,
                            line,
                            col,
                            1,
                            IR_OPR(ir_idx))) {

            exp_desc->type_idx    = type_idx;
            OPND_FLD((*result_opnd)) = CN_Tbl_Idx;

            if (CN_BOZ_CONSTANT(IR_IDX_L(ir_idx))) {
               OPND_IDX((*result_opnd)) =
                           ntr_boz_const_tbl(type_idx, folded_const);
            }
            else {
               OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx,
                                                        FALSE,
                                                        folded_const);
            }

            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
            OPND_LINE_NUM((*result_opnd)) = line;
            OPND_COL_NUM((*result_opnd))  = col;
         }
         else {
            ok = FALSE;
         }
      }
   }
   else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list,
                            (exp_desc->linear_type == Err_Res),
                            &ok,
                            &exp_desc_l, &exp_desc_r)) {

      (*exp_desc) = exp_desc_l;

      goto EXIT;
   }
   else {
      ok = FALSE;
   }

   IR_TYPE_IDX(ir_idx)      = exp_desc->type_idx;
   IR_RANK(ir_idx)          = exp_desc->rank;

   if (IR_RANK(ir_idx)) {
      IR_ARRAY_SYNTAX(ir_idx) = TRUE;
   }

EXIT:

   TRACE (Func_Exit, "uplus_opr_handler", NULL);

   return(ok);

}  /* uplus_opr_handler */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  semantic handler for the Power_Opr.                                   *|
|*                        *|
|* Input parameters:                    *|
|*  NONE                      *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static boolean power_opr_handler(opnd_type    *result_opnd,
         expr_arg_type    *exp_desc)

{
   int      col;
   expr_arg_type  exp_desc_l;
   expr_arg_type  exp_desc_r;
   long_type    folded_const[MAX_WORDS_FOR_NUMERIC];
   int      ir_idx;
   int      line;
   boolean    ok = TRUE;
   opnd_type    opnd;
   int      opnd_col;
   int      opnd_line;
   boolean    save_in_call_list;
   int      type_idx;


   TRACE (Func_Entry, "power_opr_handler" , NULL);

   ir_idx = OPND_IDX((*result_opnd));
   line   = IR_LINE_NUM(ir_idx);
   col    = IR_COL_NUM(ir_idx);
   save_in_call_list = in_call_list;
   in_call_list = FALSE;

   COPY_OPND(opnd, IR_OPND_L(ir_idx));
   exp_desc_l.rank = 0;
   ok = expr_sem(&opnd, &exp_desc_l);
   COPY_OPND(IR_OPND_L(ir_idx), opnd);

   COPY_OPND(opnd, IR_OPND_R(ir_idx));
   exp_desc_r.rank = 0;
   ok &= expr_sem(&opnd, &exp_desc_r);
   COPY_OPND(IR_OPND_R(ir_idx), opnd);

   if (!ok) {
      goto EXIT;
   }

   exp_desc->has_constructor = exp_desc_l.has_constructor ||
                               exp_desc_r.has_constructor;

   exp_desc->linear_type = POWER_TYPE(exp_desc_l.linear_type,
                                      exp_desc_r.linear_type);
   exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic;

   if (exp_desc->linear_type != Err_Res &&
       (exp_desc_l.rank == exp_desc_r.rank ||
        exp_desc_l.rank * exp_desc_r.rank == 0))    {

      if (POWER_EXTN(exp_desc_l.linear_type,
                     exp_desc_r.linear_type)) {
         /* check for defined operator */
         if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list,
                             FALSE,
                             &ok,
                             &exp_desc_l, &exp_desc_r)) {

            (*exp_desc) = exp_desc_l;

            goto EXIT;
         }
         else {
            if (exp_desc_l.type == Character ||
                exp_desc_l.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_L(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_l.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_l.type_idx    = exp_desc->linear_type;
               exp_desc_l.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_l.linear_type = exp_desc->linear_type;
            }

            if (exp_desc_r.type == Character ||
                exp_desc_r.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_R(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_r.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_r.type_idx    = exp_desc->linear_type;
               exp_desc_r.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_r.linear_type = exp_desc->linear_type;
            }

            /* reset the linear type to reflect any changes above */
            exp_desc->linear_type = POWER_TYPE(exp_desc_l.linear_type,
                                               exp_desc_r.linear_type);

         }
      }

      exp_desc->type_idx    = exp_desc->linear_type;
      exp_desc->type        = TYP_TYPE(exp_desc->linear_type);

      if (exp_desc->linear_type == Integer_8) {
         /* check whether it should be 'default' typed */

         if (exp_desc_l.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_l.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_l.type_idx;
         }
         else if (exp_desc_r.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_r.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_r.type_idx;
         }
      }

      /* can't have negative real raised to real power */

      if (exp_desc_l.foldable                          &&
          exp_desc_l.type == Real                      &&
          exp_desc_r.type == Real                      &&
          IR_FLD_L(ir_idx) == CN_Tbl_Idx) {

          if (fold_relationals(IR_IDX_L(ir_idx),
                               CN_INTEGER_ZERO_IDX,
                               Lt_Opr)) {

            PRINTMSG(line, 538, Error, col);
            ok = FALSE;
         }
      }

      if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r,
                                   exp_desc, line, col))     {
         ok = FALSE;
      }

      exp_desc->constant = exp_desc_l.constant &&
                             exp_desc_r.constant;
      exp_desc->foldable = exp_desc_l.foldable &&
                             exp_desc_r.foldable;

      exp_desc->will_fold_later = (exp_desc_l.will_fold_later &
                                   exp_desc_r.will_fold_later)  |
                                  (exp_desc_l.will_fold_later &
                                   exp_desc_r.foldable)         |
                                  (exp_desc_l.foldable &
                                   exp_desc_r.will_fold_later);


      if (opt_flags.ieeeconform &&
          ! comp_gen_expr       &&
          (exp_desc_l.type == Real ||
           exp_desc_l.type == Complex ||
           exp_desc_r.type == Real ||
           exp_desc_r.type == Complex)) {

         /* don't fold real arithmatic under ieeeconform */

         exp_desc->foldable = FALSE;
         exp_desc->will_fold_later = FALSE;
      }
      else if (exp_desc->rank != 0) {
         /* don't do any folding yet */
      }
      else if (exp_desc->foldable    &&
               IR_FLD_L(ir_idx) == CN_Tbl_Idx &&
               IR_FLD_R(ir_idx) == CN_Tbl_Idx &&
               ok) {

         if (expr_mode == Initialization_Expr &&
             exp_desc_r.type != Integer)      {

            /* must have integer exponent for init expr */

            PRINTMSG(IR_LINE_NUM_R(ir_idx), 206, Error,
                     IR_COL_NUM_R(ir_idx));
            ok = FALSE;
         }


         type_idx = exp_desc->type_idx;

         if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)),
                            exp_desc_l.type_idx,
                           (char *)&CN_CONST(IR_IDX_R(ir_idx)),
                            exp_desc_r.type_idx,
                            folded_const,
                           &type_idx,
                            line,
                            col,
                            2, IR_OPR(ir_idx))) {

            exp_desc->type_idx    = type_idx;
            OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
            OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx,
                                                     FALSE,
                                                     folded_const);

            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
            OPND_LINE_NUM((*result_opnd)) = line;
            OPND_COL_NUM((*result_opnd))  = col;
         }
         else {
            ok = FALSE;
         }
      }
   }
   else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list,
                            (exp_desc->linear_type == Err_Res),
                            &ok,
                            &exp_desc_l, &exp_desc_r)) {

      (*exp_desc) = exp_desc_l;

      goto EXIT;
   }
   else {
      ok = FALSE;
   }

   if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
       IR_OPR(OPND_IDX((*result_opnd))) == Power_Opr) {

      /* exponentiation must be pulled off io lists */
      io_item_must_flatten = TRUE;

      IR_TYPE_IDX(ir_idx)      = exp_desc->type_idx;
      IR_RANK(ir_idx)          = exp_desc->rank;

      if (IR_RANK(ir_idx)) {
         IR_ARRAY_SYNTAX(ir_idx) = TRUE;
      }
   }

EXIT:

   TRACE (Func_Exit, "power_opr_handler", NULL);

   return(ok);

}  /* power_opr_handler */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  semantic handler for the Mult_Opr and Div_Opr.                        *|
|*                        *|
|* Input parameters:                    *|
|*  NONE                      *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static boolean mult_opr_handler(opnd_type   *result_opnd,
              expr_arg_type   *exp_desc)

{
   int      col;
   expr_arg_type  exp_desc_l;
   expr_arg_type  exp_desc_r;
   long_type    folded_const[MAX_WORDS_FOR_NUMERIC];
   int      ir_idx;
   int      line;
   boolean    ok = TRUE;
   opnd_type    opnd;
   int      opnd_col;
   int      opnd_line;
   boolean    save_in_call_list;
   int      type_idx;


   TRACE (Func_Entry, "mult_opr_handler" , NULL);

   ir_idx = OPND_IDX((*result_opnd));
   line   = IR_LINE_NUM(ir_idx);
   col    = IR_COL_NUM(ir_idx);
   save_in_call_list = in_call_list;
   in_call_list = FALSE;

   COPY_OPND(opnd, IR_OPND_L(ir_idx));
   exp_desc_l.rank = 0;
   ok = expr_sem(&opnd, &exp_desc_l);
   COPY_OPND(IR_OPND_L(ir_idx), opnd);

   COPY_OPND(opnd, IR_OPND_R(ir_idx));
   exp_desc_r.rank = 0;
   ok &= expr_sem(&opnd, &exp_desc_r);
   COPY_OPND(IR_OPND_R(ir_idx), opnd);

   if (!ok) {
      goto EXIT;
   }

   exp_desc->has_constructor = exp_desc_l.has_constructor ||
                               exp_desc_r.has_constructor;

   exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic;

   exp_desc->linear_type = MULT_DIV_TYPE(exp_desc_l.linear_type,
                                         exp_desc_r.linear_type);

   if (exp_desc->linear_type != Err_Res &&
       (exp_desc_l.rank == exp_desc_r.rank ||
        exp_desc_l.rank * exp_desc_r.rank == 0))    {

      if (MULT_DIV_EXTN(exp_desc_l.linear_type,
                        exp_desc_r.linear_type)) {
         /* check for defined operator */
         if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list,
                             FALSE,
                             &ok,
                             &exp_desc_l, &exp_desc_r)) {

            (*exp_desc) = exp_desc_l;

            goto EXIT;
         }
         else { /* aggragate constant problem here BHJ */

            if (exp_desc_l.type == Character ||
                exp_desc_l.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_L(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_l.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_l.type_idx    = exp_desc->linear_type;
               exp_desc_l.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_l.linear_type = exp_desc->linear_type;
            }

            if (exp_desc_r.type == Character ||
                exp_desc_r.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_R(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_r.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_r.type_idx    = exp_desc->linear_type;
               exp_desc_r.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_r.linear_type = exp_desc->linear_type;
            }

            /* reset the linear type to reflect any changes above */
            exp_desc->linear_type = MULT_DIV_TYPE(exp_desc_l.linear_type,
                                                  exp_desc_r.linear_type);
         }
      }

      exp_desc->type_idx = exp_desc->linear_type;
      exp_desc->type     = TYP_TYPE(exp_desc->linear_type);

      if (exp_desc->linear_type == Integer_8) {
         /* check whether it should be 'default' typed */

         if (exp_desc_l.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_l.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_l.type_idx;
         }
         else if (exp_desc_r.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_r.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_r.type_idx;
         }
      }
          

      if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r,
                                   exp_desc, line, col))     {
         ok = FALSE;
      }

      exp_desc->constant = exp_desc_l.constant &&
                             exp_desc_r.constant;
      exp_desc->foldable = exp_desc_l.foldable &&
                             exp_desc_r.foldable;

      exp_desc->will_fold_later = (exp_desc_l.will_fold_later &
                                   exp_desc_r.will_fold_later)  |
                                  (exp_desc_l.will_fold_later &
                                   exp_desc_r.foldable)         |
                                  (exp_desc_l.foldable &
                                   exp_desc_r.will_fold_later);


      if ((! target_ieee          ||
           exp_desc->type == Integer)           &&
          exp_desc_r.rank            == 0       &&
          IR_OPR(ir_idx)             == Div_Opr &&
          IR_FLD_R(ir_idx)           == CN_Tbl_Idx) {

          if (fold_relationals(IR_IDX_R(ir_idx),
                               CN_INTEGER_ZERO_IDX,
                               Eq_Opr)) {

            /* division by zero */

            if (comp_gen_expr) {
               PRINTMSG(IR_LINE_NUM_R(ir_idx), 721, Error,
                        IR_COL_NUM_R(ir_idx));
               ok = FALSE;
            }
            else {
               PRINTMSG(IR_LINE_NUM_R(ir_idx), 1649, Warning,
                        IR_COL_NUM_R(ir_idx));
               exp_desc->foldable = FALSE;
               exp_desc->will_fold_later = FALSE;
            }
         }
      }

      if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
          IR_OPR(OPND_IDX((*result_opnd))) == Div_Opr &&
          exp_desc->type == Real                      &&
          on_off_flags.round_integer_divide)          {

         IR_OPR(OPND_IDX((*result_opnd))) = Real_Div_To_Int_Opr;
      }

      if (! ok) {
         /* intentionally blank */
      }
      else if (opt_flags.ieeeconform &&
               ! comp_gen_expr       &&
               (exp_desc_l.type == Real ||
                exp_desc_l.type == Complex ||
                exp_desc_r.type == Real ||
                exp_desc_r.type == Complex)) {

         /* don't fold real arithmatic under ieeeconform */

         exp_desc->foldable = FALSE;
         exp_desc->will_fold_later = FALSE;
      }
      else if (exp_desc->rank != 0) {
         /* don't do any folding yet */
      }
      else if (exp_desc->foldable             &&
               IR_FLD_L(ir_idx) == CN_Tbl_Idx &&
               IR_FLD_R(ir_idx) == CN_Tbl_Idx) {

         type_idx = exp_desc->type_idx;

         if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)),
                            exp_desc_l.type_idx,
                           (char *)&CN_CONST(IR_IDX_R(ir_idx)),
                            exp_desc_r.type_idx,
                            folded_const,
                           &type_idx,
                            line,
                            col,
                            2,
                            IR_OPR(ir_idx))) {

            exp_desc->type_idx    = type_idx;
            OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
            OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx,
                                                     FALSE,
                                                     folded_const);

            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
            OPND_LINE_NUM((*result_opnd)) = line;
            OPND_COL_NUM((*result_opnd))  = col;
         }
         else {
            ok = FALSE;
         }
      }
      else if (exp_desc_l.foldable             &&
               IR_FLD_L(ir_idx) == CN_Tbl_Idx) {

         if (exp_desc_l.type   == Integer            &&
             exp_desc_l.type_idx == exp_desc_r.type_idx) {

            if (compare_cn_and_value(IR_IDX_L(ir_idx), 0, Eq_Opr)) {
               /* fold 0 * i or 0 / i => 0 */
               COPY_OPND((*result_opnd), IR_OPND_L(ir_idx));
               exp_desc->constant = TRUE;
               exp_desc->foldable = TRUE;
            }
            else if (compare_cn_and_value(IR_IDX_L(ir_idx), 1, Eq_Opr) &&
                     IR_OPR(ir_idx)             == Mult_Opr) {
               /* fold 1 * i => i */
               COPY_OPND((*result_opnd), IR_OPND_R(ir_idx));
            }
         }
      }
      else if (exp_desc_r.foldable             &&
               IR_FLD_R(ir_idx) == CN_Tbl_Idx) {

         if (exp_desc_l.type == Integer &&
             exp_desc_l.type_idx == exp_desc_r.type_idx) {

            if (compare_cn_and_value(IR_IDX_R(ir_idx), 1, Eq_Opr)) {
               /* fold i * 1 or i / 1 => i */
               COPY_OPND((*result_opnd), IR_OPND_L(ir_idx));
            }
            else if (compare_cn_and_value(IR_IDX_R(ir_idx), 0, Eq_Opr) &&
                     IR_OPR(ir_idx)             == Mult_Opr) {
               /* fold i * 0 => 0 */
               COPY_OPND((*result_opnd), IR_OPND_R(ir_idx));
               exp_desc->constant = TRUE;
               exp_desc->foldable = TRUE;
            }
         }
      }
   }
   else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list,
                            (exp_desc->linear_type == Err_Res),
                            &ok,
                            &exp_desc_l, &exp_desc_r)) {

      (*exp_desc) = exp_desc_l;

      goto EXIT;
   }
   else {
      ok = FALSE;
   }

   IR_TYPE_IDX(ir_idx)      = exp_desc->type_idx;
   IR_RANK(ir_idx)          = exp_desc->rank;

   if (IR_RANK(ir_idx)) {
      IR_ARRAY_SYNTAX(ir_idx) = TRUE;
   }

EXIT:

   TRACE (Func_Exit, "mult_opr_handler", NULL);

   return(ok);

}  /* mult_opr_handler */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  semantic handler for the Minus_Opr.                                   *|
|*                        *|
|* Input parameters:                    *|
|*  NONE                      *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static boolean minus_opr_handler(opnd_type    *result_opnd,
         expr_arg_type    *exp_desc)

{
   int      col;
   expr_arg_type  exp_desc_l;
   expr_arg_type  exp_desc_r;
   long_type    folded_const[MAX_WORDS_FOR_NUMERIC];
   int      ir_idx;
   int      line;
   boolean    ok = TRUE;
   opnd_type    opnd;
   int      opnd_col;
   int      opnd_line;
   boolean    save_in_call_list;
   int      type_idx;


   TRACE (Func_Entry, "minus_opr_handler" , NULL);

   ir_idx = OPND_IDX((*result_opnd));
   line   = IR_LINE_NUM(ir_idx);
   col    = IR_COL_NUM(ir_idx);
   save_in_call_list = in_call_list;
   in_call_list = FALSE;
   
   COPY_OPND(opnd, IR_OPND_L(ir_idx));
   exp_desc_l.rank = 0;
   ok = expr_sem(&opnd, &exp_desc_l);
   COPY_OPND(IR_OPND_L(ir_idx), opnd);

   COPY_OPND(opnd, IR_OPND_R(ir_idx));
   exp_desc_r.rank = 0;
   ok &= expr_sem(&opnd, &exp_desc_r);
   COPY_OPND(IR_OPND_R(ir_idx), opnd);

   if (!ok) {
      goto EXIT;
   }

   exp_desc->has_constructor = exp_desc_l.has_constructor ||
                               exp_desc_r.has_constructor;

   exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic;

   exp_desc->linear_type = BIN_SUB_TYPE(exp_desc_l.linear_type,
                                        exp_desc_r.linear_type);

   if (exp_desc->linear_type != Err_Res &&
       (exp_desc_l.rank == exp_desc_r.rank ||
        exp_desc_l.rank * exp_desc_r.rank == 0))   {

      if (BIN_SUB_EXTN(exp_desc_l.linear_type,
                       exp_desc_r.linear_type)) {
         /* check for defined operator */
         if (resolve_ext_opr(result_opnd,  FALSE, save_in_call_list,
                             FALSE,
                             &ok,
                             &exp_desc_l, &exp_desc_r)) {

            (*exp_desc) = exp_desc_l;

            goto EXIT;
         }
         else {
            if (exp_desc_l.type == Character ||
                exp_desc_l.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_L(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_l.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_l.type_idx    = exp_desc->linear_type;
               exp_desc_l.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_l.linear_type = exp_desc->linear_type;
            }

            if (exp_desc_r.type == Character ||
                exp_desc_r.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_R(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_r.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_r.type_idx    = exp_desc->linear_type;
               exp_desc_r.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_r.linear_type = exp_desc->linear_type;
            }

            /* reset the linear type to reflect any changes above */
            exp_desc->linear_type = BIN_SUB_TYPE(exp_desc_l.linear_type,
                                                 exp_desc_r.linear_type);
         }
      }

      exp_desc->type_idx    = exp_desc->linear_type;
      exp_desc->type        = TYP_TYPE(exp_desc->type_idx);

      if (exp_desc->linear_type == Integer_8) {
         /* check whether it should be 'default' typed */

         if (exp_desc_l.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_l.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_l.type_idx;
         }
         else if (exp_desc_r.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_r.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_r.type_idx;
         }
      }

      if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r,
                                   exp_desc, line, col))     {
         ok = FALSE;
      }

      exp_desc->constant = exp_desc_l.constant &&
                             exp_desc_r.constant;
      exp_desc->foldable = exp_desc_l.foldable &&
                             exp_desc_r.foldable;

      exp_desc->will_fold_later = (exp_desc_l.will_fold_later &
                                   exp_desc_r.will_fold_later)  |
                                  (exp_desc_l.will_fold_later &
                                   exp_desc_r.foldable)         |
                                  (exp_desc_l.foldable &
                                   exp_desc_r.will_fold_later);

      if (opt_flags.ieeeconform &&
          ! comp_gen_expr       &&
          (exp_desc_l.type == Real ||
           exp_desc_l.type == Complex ||
           exp_desc_r.type == Real ||
           exp_desc_r.type == Complex)) {

         /* don't fold real arithmatic under ieeeconform */

         exp_desc->foldable = FALSE;
         exp_desc->will_fold_later = FALSE;
      }
      else if (exp_desc->rank != 0) {
         /* don't do any folding yet */
      }
      else if (exp_desc->foldable             &&
               IR_FLD_L(ir_idx) == CN_Tbl_Idx &&
               IR_FLD_R(ir_idx) == CN_Tbl_Idx) {

         type_idx = exp_desc->type_idx;

         if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)),
                            exp_desc_l.type_idx,
                           (char *)&CN_CONST(IR_IDX_R(ir_idx)),
                            exp_desc_r.type_idx,
                            folded_const,
                           &type_idx,
                            line,
                            col,
                            2,
                            IR_OPR(ir_idx))) {

            exp_desc->type_idx    = type_idx;
            OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
            OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx,
                                                     FALSE,
                                                     folded_const);

            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
            OPND_LINE_NUM((*result_opnd)) = line;
            OPND_COL_NUM((*result_opnd))  = col;
         }
         else {
            ok = FALSE;
         }
      }
      else if (exp_desc_r.foldable            &&
               IR_FLD_R(ir_idx) == CN_Tbl_Idx) {

         if (exp_desc_l.type   == Integer            &&
             exp_desc_l.type_idx == exp_desc_r.type_idx) {

            if (compare_cn_and_value(IR_IDX_R(ir_idx), 0, Eq_Opr)) {
               /* fold i + 0 or i - 0 => i */
               COPY_OPND((*result_opnd), IR_OPND_L(ir_idx));
            }
         }
      }
   }
   else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list,
                            (exp_desc->linear_type == Err_Res),
                            &ok,
                            &exp_desc_l, &exp_desc_r)) {

      (*exp_desc) = exp_desc_l;

      goto EXIT;
   }
   else {
      ok = FALSE;
   }

   IR_TYPE_IDX(ir_idx)      = exp_desc->type_idx;
   IR_RANK(ir_idx)          = exp_desc->rank;

   if (IR_RANK(ir_idx)) {
      IR_ARRAY_SYNTAX(ir_idx) = TRUE;
   }

EXIT:

   TRACE (Func_Exit, "minus_opr_handler", NULL);

   return(ok);

}  /* minus_opr_handler */

/******************************************************************************\
|*                        *|
|* Description:                     *|
|*  semantic handler for the Plus_Opr.                                    *|
|*                        *|
|* Input parameters:                    *|
|*  NONE                      *|
|*                        *|
|* Output parameters:                   *|
|*  NONE                      *|
|*                        *|
|* Returns:                     *|
|*  NOTHING                     *|
|*                        *|
\******************************************************************************/

static boolean plus_opr_handler(opnd_type   *result_opnd,
              expr_arg_type   *exp_desc)

{
   int      col;
   expr_arg_type  exp_desc_l;
   expr_arg_type  exp_desc_r;
   long_type    folded_const[MAX_WORDS_FOR_NUMERIC];
   int      ir_idx;
   int      line;
   boolean    ok = TRUE;
   opnd_type    opnd;
   int      opnd_col;
   int      opnd_line;
   boolean    save_in_call_list;
   int      type_idx;


   TRACE (Func_Entry, "plus_opr_handler" , NULL);

   ir_idx = OPND_IDX((*result_opnd));
   line   = IR_LINE_NUM(ir_idx);
   col    = IR_COL_NUM(ir_idx);
   save_in_call_list = in_call_list;
   in_call_list = FALSE;
   
   COPY_OPND(opnd, IR_OPND_L(ir_idx));
   exp_desc_l.rank = 0;
   ok = expr_sem(&opnd, &exp_desc_l);
   COPY_OPND(IR_OPND_L(ir_idx), opnd);

   COPY_OPND(opnd, IR_OPND_R(ir_idx));
   exp_desc_r.rank = 0;
   ok &= expr_sem(&opnd, &exp_desc_r);
   COPY_OPND(IR_OPND_R(ir_idx), opnd);

   if (!ok) {
      goto EXIT;
   }

   exp_desc->has_constructor = exp_desc_l.has_constructor ||
                               exp_desc_r.has_constructor;

   exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic;

   exp_desc->linear_type = BIN_ADD_TYPE(exp_desc_l.linear_type,
                                        exp_desc_r.linear_type);
   if (exp_desc->linear_type != Err_Res &&
       (exp_desc_l.rank == exp_desc_r.rank ||
        exp_desc_l.rank * exp_desc_r.rank == 0))   {

      if (BIN_ADD_EXTN(exp_desc_l.linear_type,
                       exp_desc_r.linear_type)) {
         /* check for defined operator */
         if (resolve_ext_opr(result_opnd,  FALSE, save_in_call_list,
                             FALSE,
                             &ok,
                             &exp_desc_l, &exp_desc_r)) {

            (*exp_desc) = exp_desc_l;

            goto EXIT;
         }
         else {
            if (exp_desc_l.type == Character ||
                exp_desc_l.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_L(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_l.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_l.type_idx    = exp_desc->linear_type;
               exp_desc_l.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_l.linear_type = exp_desc->linear_type;
            }

            if (exp_desc_r.type == Character ||
                exp_desc_r.linear_type == Short_Typeless_Const) {

               find_opnd_line_and_column((opnd_type *)
                                         &IR_OPND_R(ir_idx),
                                         &opnd_line,
                                         &opnd_col);

               if (exp_desc_r.type == Character) {
                  PRINTMSG(opnd_line, 161, Ansi, opnd_col);
               }

               IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx),
                                                         exp_desc->linear_type,
                                                         opnd_line,
                                                         opnd_col);

               exp_desc_r.type_idx    = exp_desc->linear_type;
               exp_desc_r.type        = TYP_TYPE(exp_desc->linear_type);
               exp_desc_r.linear_type = exp_desc->linear_type;
            }

            /* reset the linear type to reflect any changes above */
            exp_desc->linear_type = BIN_ADD_TYPE(exp_desc_l.linear_type,
                                                 exp_desc_r.linear_type);
         }
      }

      exp_desc->type_idx    = exp_desc->linear_type;
      exp_desc->type        = TYP_TYPE(exp_desc->type_idx);

      if (exp_desc->linear_type == Integer_8) {
         /* check whether it should be 'default' typed */

         if (exp_desc_l.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_l.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_l.type_idx;
         }
         else if (exp_desc_r.linear_type == Integer_8 &&
             TYP_DESC(exp_desc_r.type_idx) != Default_Typed) {
            exp_desc->type_idx = exp_desc_r.type_idx;
         }
      }

      if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r,
                                   exp_desc, line, col))     {
         ok = FALSE;
      }

      exp_desc->constant = exp_desc_l.constant &&
                             exp_desc_r.constant;
      exp_desc->foldable = exp_desc_l.foldable &&
                             exp_desc_r.foldable;

      exp_desc->will_fold_later = (exp_desc_l.will_fold_later &
                                   exp_desc_r.will_fold_later)  |
                                  (exp_desc_l.will_fold_later &
                                   exp_desc_r.foldable)         |
                                  (exp_desc_l.foldable &
                                   exp_desc_r.will_fold_later);

      if (opt_flags.ieeeconform &&
          ! comp_gen_expr       &&
          (exp_desc_l.type == Real ||
           exp_desc_l.type == Complex ||
           exp_desc_r.type == Real ||
           exp_desc_r.type == Complex)) {

         /* don't fold real arithmatic under ieeeconform */

         exp_desc->foldable = FALSE;
         exp_desc->will_fold_later = FALSE;
      }
      else if (exp_desc->rank != 0) {
         /* don't do any folding yet */
      }
      else if (exp_desc->foldable             &&
               IR_FLD_L(ir_idx) == CN_Tbl_Idx &&
               IR_FLD_R(ir_idx) == CN_Tbl_Idx) {


         type_idx = exp_desc->type_idx;

         if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)),
                            exp_desc_l.type_idx,
                           (char *)&CN_CONST(IR_IDX_R(ir_idx)),
                            exp_desc_r.type_idx,
                            folded_const,
                           &type_idx,
                            line,
                            col,
                            2,
                            IR_OPR(ir_idx))) {

            exp_desc->type_idx    = type_idx;
            OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
            OPND_IDX((*result_opnd)) = ntr_const_tbl(
                                                 exp_desc->type_idx,
                                                 FALSE,
                                                 folded_const);

            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
            OPND_LINE_NUM((*result_opnd)) = line;
            OPND_COL_NUM((*result_opnd))  = col;
         }
         else {
            ok = FALSE;
         }
      }
      else if (exp_desc_l.foldable             &&
               IR_FLD_L(ir_idx) == CN_Tbl_Idx) {

         if (exp_desc_l.type   == Integer            &&
             exp_desc_l.type_idx == exp_desc_r.type_idx) {

            if (compare_cn_and_value(IR_IDX_L(ir_idx), 0, Eq_Opr)) {
               /* fold 0 + i => i */
               COPY_OPND((*result_opnd), IR_OPND_R(ir_idx));
            }
         }
      }
      else if (exp_desc_r.foldable             &&