/*
 * Copyright (C) 2008. PathScale, LLC. All Rights Reserved.
 */

/*
 *  Copyright (C) 2006. QLogic Corporation. All Rights Reserved.
 */

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

/*

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

   Path64 is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   Path64 is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
   or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
   License for more details.

   You should have received a copy of the GNU General Public License
   along with Path64; see the file COPYING.  If not, write to the Free
   Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
   02110-1301, USA.

   Special thanks goes to SGI for their continued support to open source

*/



/* ====================================================================
 * ====================================================================
 *
 * Module: cwh_stmt
 * $Revision: 1.21 $
 * $Date: 05/10/03 14:30:58-07:00 $
 * $Author: scorrell@soapstone.internal.keyresearch.com $
 *
 * Revision history:
 *  dd-mmm-95 - Original Version
 *
 * Description: contains routines to convert statements
 *              from Cray IR to WHIRL. Entry points from
 *              PDGCS layer are
 * 
 *             fei_stmt - start of new statement.
 *	       fei_user_code_start - begin of user statements
 *             fei_object_ref - reference to object
 *             fei_seg_ref - reference to segment
 *             fei_namelist_ref - reference to namelist
 *             fei_member_ref   - reference to derived type component.
 *             fei_constant     - reference to constant.
 *             fei_push_arith_con - reference to constant.
 *             fei_push_pattern_con - reference to string or byte string
 *             fei_function_ref - reference to procedure for call.
 *             fei_label_ref - reference to a a label 
 *
 *             these routines generally push an ST/WN/STR item on the
 *             stack for later processing. Statement level operations are
 *   
 *             fei_store - save rhs in lhs.
 *             fei_non_conform_store - save 1d object in nd, or vice versa.
 *             fei_call - make a procedure call
 *             fei_arg_addr - make an address for a procedure argument.
 *             feI_fcd  - turn cray pointer ref into strinfg reference
 *             fei_addr_con - generate the address of a constant
 *             fei_entry_pt - generate an alternate entry point
 *             fei_goto  - create a goto.
 *             fei_arith_goto  - create arithmetic IF gotos.
 *             fei_label_addr - create index for assign stmt.
 *             fei_indirect_goto - use table for assign and computed goto.
 *             fei_new_select - create a select case
 *             fei_label_def_named - define a label within the code.
 *             fei_brtrue - create a branch on TRUE
 *             fei_where - the WHERE statement, TRUE only.
 *             fei_return - a return statement
 *             fei_concat - create an OPC_CASSIGNMENT for concatenation
 *             fei_doloop - create an DOLOOP statemnet
 *             fei_dowhile - create an DOWHILE statement
 *             fei_doforever - create an DOWHILE TRUE  statement
 *             fei_enddo - back to parent block at end of DO loop.
 *             fei_allocate - the (DE) ALLOCATE statement.
 *
 *
 * ====================================================================
 * ====================================================================
 */

static const char *source_file = __FILE__;


/* sgi includes */

#include "defs.h"
#include "glob.h"  
#include "stab.h"
#include "strtab.h"
#include "errors.h"
#include "targ_const.h"
#include "config_targ.h"  
#include "config_debug.h"  
#include "const.h"
#include "pu_info.h"
#include "wn.h"
#include "wn_util.h"
#include "f90_utils.h"
#include "targ_sim.h"
#ifdef KEY /* Bug 4260 */
#include "../../../clibinc/cray/io_byteswap.h"
#endif /* KEY Bug 4260 */

/* FE includes */

#include "i_cvrt.h"

/* conversion includes */

#include "cwh_defines.h"
#include "cwh_addr.h"
#include "cwh_block.h"
#include "cwh_expr.h"
#include "cwh_stk.h"
#include "cwh_types.h"
#include "cwh_preg.h"
#include "cwh_stab.h"
#include "cwh_auxst.h"
#include "cwh_intrin.h"
#include "cwh_stmt.h"
#include "cwh_dst.h"
#include "cwh_directive.h"
#include "cwh_preg.h"
#include "sgi_cmd_line.h"
#ifdef KEY /* Bug 7443 */
#include "cwh_io.h"
#endif /* Bug 7443 */

#include "cwh_stmt.i"

#include <libgen.h>	/* for dirname */


/*===============================================
 *
 * fei_stmt
 *
 * Initialize data structures for WHIRL conversion
 * at the start of each statement.
 *
 * Set the current line number.
 *
 *===============================================
 */ 
/*ARGSUSED*/
extern void
fei_stmt(INT32  lineno,
	 INT32  stmt_character_flag )
{

  if (lineno) {

    cwh_stmt_init_srcpos(lineno);

    /* Insert any deferred statements */

    cwh_block_append_given(Defer_Block);
   } 
}

/*===============================================
 *
 * fei_user_code_start
 *
 * Marks the beginning of user statements & end
 * of FE generated preamble (ie: saves to temps
 * for decls). Add whirl built for declaration 
 * or pragma processing processing.  
 *
 *===============================================
 */ 
extern void
fei_user_code_start(void)
{
  still_in_preamble = FALSE;
  cwh_block_append_given(Preamble_Block);
  cwh_stmt_add_pragma(WN_PRAGMA_PREAMBLE_END);
  cwh_block_append_given(First_Block);
  (void) cwh_block_toggle_debug(TRUE) ;

  cwh_stk_verify_empty();
}

/*===============================================
 *
 * fei_object_ref
 *
 * Push a reference to an object (an ST) 
 * on the expression stack. It may be an
 * lvalue, so don't fetch it.
 *
 *===============================================
 */ 
/*ARGSUSED*/
extern void
fei_object_ref (INTPTR  sym_idx,
		INT32	whole_array,
		INT32	whole_substring )
{
  STB_pkt *p ;

  p = cast_to_STB(sym_idx);
  DevAssert((p->form == is_ST),("Odd object ref"));

  ST * st = cast_to_ST(p->item);
  DevAssert((st),("null st"));

  if (whole_array) {
    cwh_stk_push(st,ST_item_whole_array) ;
  } else {
    cwh_stk_push(st,ST_item) ;
  }
}

/*===============================================
 *
 * fei_seg_ref
 *
 * Push a reference to an segment (eg. common block) (an ST) 
 * on the expression stack. 
 *
 *===============================================
 */ 
extern void
fei_seg_ref (INT32   sym_idx )
{
  STB_pkt *p ;

  p = cast_to_STB(sym_idx);
  DevAssert((p->form == is_ST),("Odd seg ref"));

  ST * st = cast_to_ST(p->item);
  DevAssert((st),("null st"));

  cwh_stk_push(st,ST_item) ;
}

/*===============================================
 *
 * fei_namelist_ref
 *
 * Push a reference to a namelist item (an ST) 
 * on the expression stack. 
 *
 *===============================================
 */ 
void
fei_namelist_ref (INTPTR   sym_idx )
{
  fei_object_ref(sym_idx, 0, 0);
}

/*===============================================
 *
 * fei_member_ref
 *
 * Push a reference to an derived type
 * component on the expression stack. The
 * object (variable) will be TOS, or under other
 * FLD_items.
 *
 *===============================================
 */ 
extern void
fei_member_ref (INT32   sym_idx )
{

  cwh_stk_push(cast_to_void(sym_idx),FLD_item) ;
}

/*===============================================
 *
 * fei_constant
 *
 * Push a reference to a constant on the 
 * expression stack.
 *
 * If it's an Arith_con, then the value is passed
 * just create the ST, push a WN on the stack and
 * pass back the WN for later use. If it's an 
 * integral type, there couldn't be an ST, so a
 * WN was created instead. The result will be in
 * a packet.
 * 
 * For a string(pattern) const we push the size
 * too and make it into a STR_item. PCONST_items 
 * are bit strings used for initialization, mostly.
 * Just push those.
 *
 *===============================================
 */ 
extern INTPTR
fei_constant ( TYPE            type,
               INT32           Class,
               char           *start,
               INT64           bitsize )

{
  WN   * wn  ;  
  WN   * wc  ;    
  TY_IDX ty  ;  
  INTPTR cn   ;
  ST *st;
#ifdef KEY /* Bug 10177 */
  STB_pkt *p = 0;
#else /* KEY Bug 10177 */
  STB_pkt *p ;
#endif /* KEY Bug 10177 */
  
  switch ((CONSTANT_CLASS)Class) {
  case Arith_Const:

    cn = fei_arith_con(type,(SLONG *)start) ;
    p  = cast_to_STB(cn);

    if (p->form == is_WN)
      wn = cast_to_WN(p->item);
    else 
      wn = cwh_stab_const(cast_to_ST(p->item));
    
    wc = WN_COPY_Tree(wn);
    wn = WN_COPY_Tree(wn);
    ty = cast_to_TY(t_TY(type));
    cwh_stk_push_typed(cast_to_void(wn),WN_item,ty) ;  
    p = cwh_stab_packet_typed(wc,is_WN,ty);

    break;

  case Pattern_Const:

    cn = fei_pattern_con(type,start,bitsize);

    if (type.basic_type == Char_Fortran) {

       st = (ST *) cast_to_void(cn);
       wn = WN_CreateIntconst (OPC_U4INTCONST,TY_size(ST_type(st)));
       cwh_stk_push_STR(wn,st,ST_type(st),ST_item);
       p = cwh_stab_packet(cast_to_void(cn),is_SCONST);

    } else {
       cwh_stk_push(cast_to_void(cn),PCONST_item);
       p = cwh_stab_packet(cast_to_void(cn),is_PCONST);
    }
    
    break;

  default:	
    DevAssert((0), ("Unimplemented constant"));
    break ;
  }
  
  return(cast_to_int(p));
}

/*===============================================
 *
 * fei_push_arith_con
 *
 * Push a reference to a constant on the 
 * expression stack. Copy the WN passed in.
 * for logical constants, we have have a TY.
 * 
 *===============================================
 */ 
extern void 
fei_push_arith_con ( INTPTR cdx )
{
  WN   * wn  ;
  TY_IDX ty  ;
  STB_pkt *p;

  p  = cast_to_STB(cdx);
  wn = WN_COPY_Tree((WN *) p->item);
  ty = p->ty;

  if (ty != 0)
    cwh_stk_push_typed(cast_to_void(wn),WN_item,ty) ;
  else
    cwh_stk_push(cast_to_void(wn),WN_item) ;
}

/*===============================================
 *
 * fei_push_pattern_con
 * 
 * Push a reference to a string or aggregate 
 * expression stack. Make the ST passed into
 * STR_item or an ST reference.
 *
 *===============================================
 */ 
extern void 
fei_push_pattern_con ( INTPTR cdx )
{
   ST *st;
   TY_IDX ty;
   WN *wn;
   STB_pkt *p;

   p = cast_to_STB(cdx);

   /* called with the ST of a pattern constant */
   st = (ST *) p->item;

   if (p->form == is_SCONST) {
      ty = ST_type(st);
      wn = WN_CreateIntconst (OPC_U4INTCONST,TY_size(ty));
      cwh_stk_push_STR(wn,st,ty,ST_item);

   } else {
      cwh_stk_push(st,PCONST_item);
   }
}
#ifdef KEY /* Bug 4602 */
/*===============================================
 *
 * fei_arg_by_value
 *
 * If the tos is an array, generate a LOAD for it.
 * Used to implement %val() for an actual argument
 * which is an array element
 *
 *===============================================
 */ 
extern void
fei_array_element_by_value() {
  TY_IDX save_type = cwh_stk_get_TY();
  enum item_class save_class = cwh_stk_get_class();
  WN *wn = cwh_stk_pop_WN();

  if (wn != NULL && cwh_addr_is_array(wn)) {
    wn = cwh_addr_load_WN(wn, 0, save_type);
    }
  cwh_stk_push_typed(wn, save_class, save_type);
  }
#endif /* KEY Bug 4602 */


/*===============================================
 *
 * fei_store
 *
 * Generate a store. The rhs will be on
 * top of the stack, and the lhs symbol
 * ST or address WN will be below. 
 *
 * On the lhs we add an OPC_ARRAYEXP to 
 * describe the iterations, if its an 
 * array section address 
 * 
 * Sometimes a NULL WN is on top because WHIRL
 * wants (say) an intrinsic call, or a store
 * has already been done. The FE doesn't know
 * so fei_store is called & the stack cleared.
 *
 *===============================================
 */ 
/*ARGSUSED*/
extern void
fei_store ( TYPE result_type )
{
  WN   * rhs  ;
  WN   * wn   ;
  ST   * st   ;
  ST   * rhs_st;
  TY_IDX  ty;
  TY_IDX  ts;
  
  FLD_det det ;

  if (cwh_stk_get_class() == STR_item) {

    cwh_stmt_character_store(result_type);

  } else if (cwh_stk_get_class() == PCONST_item) {

     rhs_st = cwh_stk_pop_PCONST();
     ty  = ST_type(rhs_st);
     rhs = cwh_addr_address_ST(rhs_st,0);
     rhs = cwh_addr_mload(rhs,0,ty,NULL);
     wn  = cwh_expr_address(f_NONE);
     wn  = cwh_addr_mstore(wn,0,ty,rhs) ;
     cwh_block_append(wn) ;

  } else {

    rhs = cwh_expr_operand(NULL);

    if (rhs == NULL) {
      cwh_stk_pop_whatever() ;
      return ;
    }

    switch(cwh_stk_get_class()) {
    case WN_item:
    case WN_item_whole_array:
      ts = cwh_stk_get_TY();
      wn = cwh_expr_address(f_NONE);
      wn = F90_Wrap_ARREXP(wn) ;
      cwh_addr_store_WN(wn,0,ts,rhs);
      break  ;

    case DEREF_item:
      ts = cwh_stk_get_TY();
      if (ts) {
	 /* Get the type of the item stored from the dope vector */
	 ts = TY_pointed(FLD_type(TY_fld(Ty_Table[ts])));
      }
      wn = cwh_expr_address(f_NONE);
      wn = F90_Wrap_ARREXP(wn) ;
      cwh_addr_store_WN(wn,0,ts,rhs);
      break  ;

    case ST_item:
    case ST_item_whole_array:
      st = cwh_stk_pop_ST();
      cwh_addr_store_ST(st,0,0,rhs);
      break ;

    case FLD_item:
      det = cwh_addr_offset();

      if (cwh_stk_get_class() == ST_item || 
	  cwh_stk_get_class() == ST_item_whole_array) {

	st  = cwh_stk_pop_ST();
	cwh_addr_store_ST(st,det.off,det.type,rhs);

      } else {

	wn = cwh_stk_pop_WHIRL();
	wn = cwh_expr_bincalc(OPR_ADD,wn,WN_Intconst(Pointer_Mtype,det.off));
	wn = F90_Wrap_ARREXP(wn);
	cwh_addr_store_WN(wn,0,det.type,rhs);
      }
      break;

    default:
      DevAssert((0),("odd store LHS"));
    }
  }  
}

/*===============================================
 *
 * fei_non_conform_store
 *
 * Used when a 1d a temp is assigned to an nd 
 * destination or vice-versa. Used in constructors.
 *
 * The OPC_ARRSECTION of the temp is replaced 
 * with one which describes  the same shape as 
 * The destination. hen the items are pushd back 
 * onto the stack and fei_store called. There is
 * an assumption(assertion) that the temp is a
 * contiguous object.
 *
 *===============================================
 */ 
/*ARGSUSED*/
extern void
fei_non_conform_store( TYPE result_type )
{
  WN *wd  ;
  WN *wdl ;
  TY_IDX td  ;  
  TY_IDX ts1 ;
  TY_IDX ts2 ;

  WN *wt  ;
  WN *wtl ;
  TY_IDX tt  ;

  FLD_HANDLE f1 ;
  FLD_HANDLE f2 ;
  FLD_det d1 ;
  FLD_det d2 ;

  switch(cwh_stk_get_class()) {
  case STR_item:
    cwh_stk_pop_STR();
    wtl = cwh_stk_pop_WN();  
    ts1 = cwh_stk_get_TY();
    wt  = cwh_stk_pop_WN();  
    wt = cwh_expr_extract_arrayexp(wt,DELETE_ARRAYEXP_WN);

    cwh_stk_pop_STR();
    wdl = cwh_stk_pop_WN();  
    ts2 = cwh_stk_get_TY();
    wd  = cwh_stk_pop_WN();
    wd = cwh_expr_extract_arrayexp(wd,DELETE_ARRAYEXP_WN);

    cwh_addr_nonc_util(&wt,&wd);

    cwh_stk_push_STR(wdl,wd,ts2,WN_item);
    cwh_stk_push_STR(wtl,wt,ts1,WN_item);
    break;

  default:

    if (cwh_stk_get_class() == FLD_item) {
      d1 = cwh_addr_offset();
      f1 = cwh_types_fld_dummy(d1.off,d1.type);
    }
    tt  = cwh_stk_get_TY();
    wt  = cwh_stk_pop_WHIRL();

    if (!tt) {
       tt = cwh_types_WN_TY(wt,FALSE);
    }

    wt  = cwh_expr_extract_arrayexp(wt,DELETE_ARRAYEXP_WN);

    if (cwh_stk_get_class() == FLD_item) {
      d2 = cwh_addr_offset();
      f2 = cwh_types_fld_dummy(d2.off,d2.type);
    }
    td  = cwh_stk_get_TY();
    wd  = cwh_stk_pop_WHIRL();

    if (!td) {
       td = cwh_types_WN_TY(wd,FALSE);
    }

    wd = cwh_expr_extract_arrayexp(wd,DELETE_ARRAYEXP_WN);

    cwh_addr_nonc_util(&wt,&wd);		   

    cwh_stk_push_typed(wd,WN_item,td); 
    if (!f2.Is_Null ())
      cwh_stk_push((void *)f2.Idx (),FLD_item);

    cwh_stk_push_typed(wt,WN_item,tt); 
    if (!f1.Is_Null ())
      cwh_stk_push((void *)f1.Idx(),FLD_item);

  }

  fei_store(result_type);
}

/*===============================================
 *
 * cwh_stmt_character_store.
 *
 * two str items are on the stack. Pop them,
 * and look to see if they are single bytes.
 * if not, call CASSIGNMENT. If so, get rid
 * of the STR items and sizes, then store.
 *
 * Could expand to two bytes etc, but would 
 * need padding and dependence checking, so 
 * better as CASSIGNMENT intrinsic optimization.
 *
 *===============================================
 */ 
static void
cwh_stmt_character_store(TYPE result_type)
{
  WN * src;

  if (cwh_stk_is_byte_STR(0) && 
      cwh_stk_is_byte_STR(1)) {

    cwh_stk_pop_STR();
    cwh_stk_pop_whatever();
    src = cwh_expr_operand(NULL);
    src = cwh_expr_dispose_of_char(src);

    cwh_stk_pop_STR();
    cwh_stk_pop_whatever();

    cwh_stk_push(src,WN_item);
    fei_store(result_type);

  } else {
    cwh_stmt_character_icall(INTRN_CASSIGNSTMT);
  }
}

/*===============================================
 *
 * fei_function_ref
 *
 * Given an ST of a function, stick it on the stack.
 * It will be popped by fei_call.
 *
 *===============================================
 */ 
extern void 
fei_function_ref(INTPTR id)
{
  STB_pkt *p;

  p = cast_to_STB(id) ;
  
  DevAssert((p->form == is_ST),("Fn ST missing"));
  DevAssert((p->item != NULL),("NULL fn imp"));

  cwh_stk_push(cast_to_ST(p->item), ST_item);
}

#ifdef KEY /* Bug 10282 */
/*
 * return struct type if t is array of struct type suitable for returning
 * by value from a function; else return -1
 */
TY_IDX array_of_struct_by_value(TY_IDX t) {
  if (TY_kind(t) == KIND_ARRAY) {
    t = cwh_types_scalar_TY(t);
    if (STRUCT_BY_VALUE(t)) {
      return t;
    }
  }
  return (TY_IDX) -1;
}
#endif /* KEY Bug 10282 */

/*===============================================
 *
 * cwh_stmt_call_helper
 *
 * Build a call stmt. For a conventional call 
 * arguments are on the stack, as ADDR_items or
 * STR_items, with the ST of the call name beneath 
 * them. For an intrinsic or library call, there 
 * may just be a value - so test for WN too.
 * OPC_PARMs are wrapped aroudn everything - ref
 * parms generally, but value parms around WNs.
 *
 * If it's a function call, then the result 
 * PREG is pushed onto the stack to be read 
 * by fei_store. If the function result is 
 * complex*32 the address of the result is the
 * first argument. Results with similar requirements
 * eg: character, derived type > 16 bytes have 
 * already been transformed into arguments by the FFE.
 *
 * Character lengths are appended to the list, 
 * unless a character function result, whn it goes
 * into the spot after the address.
 *
 * This function provides a common interface 
 * for intrinsic routines and user routines.
 * The function returns the call node, although it
 * will already be in the tree, so that flags might
 * be set on it. 
 *
 * inline_state is set to 0=normal, 1=inline, 2=noinline
 *
 *===============================================
 */ 
#include "ir_reader.h"
extern WN * 
cwh_stmt_call_helper(INT32 num_args, TY_IDX ty, INT32 inline_state, INT64 flags)
{
  WN     * wc  ;
  WN     * call_wn  ;
  WN     * wn  ;
  WN     * wa  ;  
  WN     * wt  ;
  WN    ** args;
  WN     * rhs ;
  ST     * st  ;
  ST     * rt  ;
  TY_IDX  ta  ;
  TY_IDX  ts  ;
  TY_IDX  tr  ;
  TY_IDX   ret_ty;
  INT32    nargs;  
  INT32    clen ;  
  INT32    i,k  ;
  WN *     block;
  FLD_det  det ;

  TYPE_ID   rbtype1;
  TYPE_ID   rbtype2;
  OPCODE    opc;

  BOOL        forward_barrier = FALSE;
  BOOL        backward_barrier = FALSE;
  WN * barrier_wn;
#ifdef KEY /* Bug 10282 */
  /* If an elemental function is returning an array of "small" structures,
   * we need to remember the temp which receives the function result, and
   * the base type of the result array. */
  WN *case4_array_temp = 0;
  TY_IDX case4_base_type = (TY_IDX) -1;
#endif /* KEY Bug 10282 */

  /* figure # of args, including character lengths, clear return temp ST */

  nargs  = num_args + cwh_stk_count_STRs(num_args) ; 
  clen   = nargs ;
  rt     = NULL;

  args = (WN **) malloc(nargs*sizeof(WN *));

  for (k = num_args -1 ; k >= 0  ; k --) {

    switch(cwh_stk_get_class()) {
    case STR_item:
      cwh_stk_pop_STR();
      wa = cwh_stk_pop_WN();
      wc = WN_COPY_Tree(wa); 
      args[--clen] = cwh_intrin_wrap_value_parm(wa);
      wa = cwh_stk_pop_ADDR();
      args[k] = cwh_intrin_wrap_char_parm(wa,wc);
      break ;

    case ADDR_item:
      ta = cwh_stk_get_TY();
      wa = cwh_stk_pop_ADDR();
      args[k] = cwh_intrin_wrap_ref_parm(wa,ta);
      break;

    case WN_item:
    case WN_item_whole_array:
      wa = cwh_stk_pop_WN();
      wa = cwh_intrin_wrap_value_parm(wa);

      args[k] = wa;
      break ;

    case FLD_item:
    case ST_item:
    case ST_item_whole_array:
      wa = cwh_expr_operand(NULL);
      wa = cwh_intrin_wrap_value_parm(wa);
      args[k] = wa;
      break ;

    case DEREF_item: /* 11Dec00[sos]: Handle "call sub(%val(apointer))"  */
      wa = cwh_stk_pop_DEREF();
      wa = cwh_intrin_wrap_value_parm(wa);
      args[k] = wa;
      break;

    default:
      DevAssert((0),("Odd call actual")) ; 
    }
  }

  if (cwh_stk_get_class() == FLD_item) {
    det = cwh_addr_offset();

    st = cwh_stk_pop_ST();
    ret_ty = det.type;

    tr = ts = TY_ret_type(TY_pointed(det.type));

  } else {
    st = cwh_stk_pop_ST(); 
    ts = ty;
    tr = ty;
    det.off = 0;
    ret_ty = ST_type(st);

    if (ST_class(st) != CLASS_FUNC) {  /* Must be indirect call, so ptr to */
                                       /* function. Get function type      */

      DevAssert((TY_kind(ST_type(st)) == KIND_POINTER && 
		 TY_kind(TY_pointed(ST_type(st))) == KIND_FUNCTION),
                ("Odd ST"));

      tr = TY_ret_type(TY_pointed(ST_type(st)));

      if (ST_is_value_parm(st) == 0)
	ts = tr;     /* Procedure pointer */
    }
  }

  /* Function returning character? Reorder to get   */
  /* length of function result as 2nd argument.     */
  /* Function returning struct by value? Delete     */
  /* first arg.                                     */
  /* Will not have function's TY, if via proc_imp   */
  /* so look at first arg.                          */  

  if (ST_auxst_has_rslt_tmp(st) || cwh_types_is_character(tr)) {

    tr = cwh_types_WN_TY(args[0],FALSE);

    if (cwh_types_is_character(tr)) {

      wt = args[clen];

      for (k = clen ; k > 1 ; k--) 
	args[k] = args[k-1];

      args[1] = wt;

    } else if (STRUCT_BY_VALUE(tr)) {

      DevAssert((WNOPR(args[0]) == OPR_PARM),("Odd result"));
      wt = WN_kid(args[0],0);

      DevAssert((wt != NULL),("struct w/o temp"));
      DevAssert((WNOPR(wt) == OPR_LDA),("struct w/o ADDR_item"));

      rt = WN_st(wt);
      ts = tr ;

      nargs --;

      for (i=0; i < nargs; i++) 
	args[i] = args[i+1];

    }
#ifdef KEY /* Bug 10282 */
    else if ((ST_auxst_is_elemental(st)) && (TY_mtype(tr) != MTYPE_V)) {
      case4_base_type = array_of_struct_by_value(tr);
      if (case4_base_type != (TY_IDX) -1) {
	DevAssert((WNOPR(args[0]) == OPR_PARM),("Odd result"));
	case4_array_temp = WN_kid(args[0],0);
	wt = WN_kid(case4_array_temp,0);

	DevAssert((wt != NULL),("struct w/o temp"));
	DevAssert((WNOPR(wt) == OPR_LDA),("struct w/o ADDR_item"));

	rt = WN_st(wt);
	ts = case4_base_type ;

	nargs --;

	for (i=0; i < nargs; i++) 
	  args[i] = args[i+1];
      }
    }
#endif /* KEY Bug 10282 */
  }

  /* create call (or indirect call if dummy procedure)  */

  if (WHIRL_Return_Info_On) {

    RETURN_INFO return_info = Get_Return_Info (ts, Use_Simulated);

    if (RETURN_INFO_count(return_info) <= 2 ||
        WHIRL_Return_Val_On) {

      rbtype1 = RETURN_INFO_mtype (return_info, 0);
      rbtype2 = RETURN_INFO_mtype (return_info, 1);
    }

    else
      Fail_FmtAssertion ("cwh_stmt_call_helper: more than 2 return registers");
  }

  else
    Get_Return_Mtypes(ts, Use_Simulated, &rbtype1,&rbtype2);

  i = ST_sclass(st);
  if (i != SCLASS_FORMAL && i != SCLASS_FORMAL_REF && i != SCLASS_AUTO &&
      i != SCLASS_PSTATIC && i != SCLASS_FSTATIC && i != SCLASS_COMMON) {

     opc = OPCODE_make_op(OPR_CALL,TY_mtype(ts),MTYPE_V);
     wn  = WN_Create(opc,nargs);
     WN_st_idx(wn) = ST_st_idx(st);

     /* if the name of the routine is one of mp_setlock mp_unsetlock
        or mp_barrier then set barrier flags (PV 485782) */

     if (cwh_stmt_sgi_mp_flag) {
       if (rbtype1==MTYPE_V && ST_name(st) &&
	   ST_name(st)[0]=='m' && ST_name(st)[1]=='p') {
	 if (!strcmp(&(ST_name(st)[2]),"_setlock_")) {
	   backward_barrier = TRUE;
	 } else if (!strcmp(&(ST_name(st)[2]),"_unsetlock_")) {
	   forward_barrier = TRUE;
	 } else if (!strcmp(&(ST_name(st)[2]),"_barrier_")) {
	   forward_barrier = TRUE;
	   backward_barrier = TRUE;
	 }
       }
     }

  } else {

     opc = OPCODE_make_op (OPR_ICALL,TY_mtype(ts),MTYPE_V);
     wn  = WN_Create(opc,nargs+1);
     WN_set_ty(wn,TY_pointed(ret_ty));
     WN_kid(wn,nargs) = cwh_addr_load_ST(st, det.off, ret_ty);
  }

  if (forward_barrier) {
    barrier_wn=WN_CreateBarrier ( TRUE, 0 );
    cwh_block_append(barrier_wn);
  }


  WN_Set_Call_Default_Flags(wn);  
  WN_Set_Call_Fortran_Pointer_Rule(wn);

  if (FE_Call_Never_Return &&
      test_flag(flags, FEI_CALL_DOES_NOT_RETURN)) {
    WN_Set_Call_Never_Return(wn);
  }

#ifdef KEY /* Bug 7443 */
  if (inside_io) {
    WN_Set_Call_Dont_Inline(wn);  
  }
  else
#endif /* Bug 7443 */
  if (inline_state == 1) {
    /* inline */
    WN_Set_Call_Inline(wn);
    fe_invoke_inliner = TRUE;
  } else if (inline_state == 2) {
    /* no inline */
    WN_Set_Call_Dont_Inline(wn);
  }

  call_wn = wn;

  for (i=0; i < nargs; i++) {
     WN_kid(wn,i) = args[i];
  }

  free(args);


  /* Function result - for elementals (with array arguments) whose   */ 
  /* scalar lowering returns values in registers, a statement level  */
  /* call is no good, because the f90 lowerer wants to see a store   */
  /* into an array-valued temp. So a COMMA node holds the pregs of   */
  /* the return and the call block                                   */
  
  if ((ST_auxst_is_elemental(st)) && (TY_mtype(ts) != MTYPE_V)) {

     /* ELEMENTAL functions. Build a COMMA node */

     block = cwh_block_new_and_current();
     cwh_block_append(wn);
     block = cwh_block_exchange_current(block);

#ifdef KEY /* Bug 8191, 9520, 10282 */
     // Arrange to capture anything cwh_stmt_return_scalar() appends to
     // current block
     WN *stmt_return_block = cwh_block_new_and_current();
     if (case4_base_type != ((TY_IDX) -1)) {
       wn = cwh_stmt_return_scalar(rt,NULL,case4_base_type,FALSE);
     } else {
       wn  = cwh_stmt_return_scalar(rt,NULL,ts,FALSE);
     }
     stmt_return_block = cwh_block_exchange_current(stmt_return_block);
     /* For struct by value, wn is null but rbtype1 gives type; for scalar
      * result of elemental, Get_Return_Mtypes() may have set
      * return_via_first_arg=1 and not set mtype (or, consequently, rbtype1)
      *earlier: use WN_rtype() instead */
     opc = cwh_make_typed_opcode(OPR_COMMA, (wn ? WN_rtype(wn) : rbtype1),
       MTYPE_V);

     // For the record, the unhappy code in this function handles six cases:
     // 1. scalar
     //    Cray FE calls fcn with user's arglist, assigns result
     //    SGI FE generates straightforward code: calls function, loads
     //      .preg_return_val, stores into whatever
     // 2. elemental scalar
     //    Cray FE calls fcn with user's arglist, assigns result
     //    SGI FE generates slightly tricky code: calls function, puts the
     //      call and the load of .preg_return_val into a comma operator,
     //      stores into whatever
     // 3. small structure
     //    Cray FE calls fcn, passing result as 1st argument
     //    SGI FE removes 1st argument, generates call with remaining
     //      arguments, loads .preg-return_val, stores into what was 1st
     //      argument
     // 4. elemental small ("STRUCT_BY_VALUE") structure
     //    Cray FE calls fcn, passing result as 1st argument
     //      SGI FE tries to do a combination of (2) and (3) but (prior to
     //      this fix) fails miserably
     // 5. large structure
     //    Cray FE calls fcn, passing result as 1st argument
     //    SGI FE generates straightforward code: calls function as received
     //      from FE, then array-assigns what was the 1st
     // 6. elemental large structure
     //    Cray FE calls fcn, passing result as 1st argument
     //    SGI FE generates straightforward code just like (5)
     //
     // Seems like it would have been better to make the Cray FE generate
     // (3) and (4) correctly, but perhaps there's a reason the original
     // authors didn't: anyway, that would only fix half the problem.
     //
     // In the case 4 of an elemental function returning a small structure,
     // cwh_stmt_return_scalar() appends a load and store to the block
     // that was then current. We need to capture the load for use inside
     // the comma operator, and we need to append first the comma and then
     // the store to the real block. The fix to do it at this spot is ugly,
     // but messing with cwh_stmt_return_scalar() is scary since it's used
     // in so many other places, so for now I prefer to do it here..
     if (NULL == wn) {
       WN *store = WN_first(stmt_return_block);
       WN *load = WN_kid0(store);
       wn  = WN_CreateComma(opc,block,load);
       if (case4_array_temp) {
	 cwh_stk_push_typed(case4_array_temp,WN_item,tr);
	 cwh_stk_push_typed(wn,WN_item,tr);
	 TYPE pdg_type_void = fei_descriptor(0, Basic, 0, V_oid, 0, 0);
	 fei_store(pdg_type_void);
       }
       else {
	 WN_kid0(store) = wn;
	 cwh_block_append(store);
       }
     }
     else {
       wn  = WN_CreateComma(opc,block,wn);
       cwh_stk_push_typed(wn,WN_item,ty);
     }
#else /* KEY Bug 8191, 9520, 10282 */
     wn  = cwh_stmt_return_scalar(rt,NULL,ts,FALSE);
     opc = cwh_make_typed_opcode(OPR_COMMA,rbtype1,MTYPE_V);
     wn  = WN_CreateComma(opc,block,wn);
     cwh_stk_push_typed(wn,WN_item,ty);
#endif /* KEY Bug 8191, 9520, 10282 */
     
  } else {
    
    /* put ARRAYEXPs underneath the parm nodes of elementals */
    
    if (ST_auxst_is_elemental(st)) {
	
      for (k = 0; k < nargs; k ++) {
	WN_kid0(WN_kid(wn,k)) = F90_Wrap_ARREXP(WN_kid0(WN_kid(wn,k)));
      }
    }
    cwh_block_append(wn);
    
    
    /* scalar (in registers) function result?      */
    /* Push read of pregs on stack, unless struct  */
    /* by value when read of temp..                */
    
    if (TY_mtype(ts) != MTYPE_V) {

      wn = cwh_stmt_return_scalar(rt,NULL,ts,FALSE);

      if (wn != NULL)
	cwh_stk_push(wn,WN_item);
    }
  }
  
  if (backward_barrier) {
    barrier_wn=WN_CreateBarrier ( FALSE, 0 );
    cwh_block_append(barrier_wn);
  }

  return (call_wn);
}

/*===============================================
 *
 * fei_call
 *
 * Build a call stmt. For a conventional call 
 * arguments are on the stack, as ADDR_items or
 * STR_items, with the ST of the call name beneath 
 * them. For an intrinsic or library call, a WN may
 * be passed by value.
 *
 * OPC_PARMs are wrapped around everything - ref
 * parms generally, but value parms around WNs.
 *
 * see cwh_stmt_call_helper.
 *
 *===============================================
 */ 
/*ARGSUSED*/
extern void 
fei_call(INT32      num_args,
	 TYPE       result_type,
	 INT32      call_type,
	 INT32      alt_return_flag,
	 INT32      inline_setting,
         INT64      flags)
    
{
   TY_IDX ty;
   ty = cast_to_TY(t_TY(result_type));
   (void) cwh_stmt_call_helper(num_args,ty,inline_setting,flags);
}

/*===============================================
 *
 * fei_arg_addr
 *
 * Build an address and push it back on
 * the stack. These were PARM nodes, but
 * ALOCs were required for some other items
 * so PARMS are deferred to fei_call.
 *
 * For FLD items we need to save the FLD type,
 * so find out the TY, address the FLD, then
 * push a typed ADDR_item on the stack, so later
 * fei_call (say) can put the correct TY in a PARM.
 *
 *===============================================
 */ 
/*ARGSUSED*/
extern void 
fei_arg_addr(TYPE type)
{
  WN  * wn ;
  WN  * wa ;
  TY_IDX ty ;
  TY_IDX ts ;
  FLD_HANDLE  fld;
  FLD_det det;

  switch(cwh_stk_get_class()) {
  case STR_item:
    cwh_stk_pop_STR();
    wn = cwh_stk_pop_WN();
    ts = cwh_stk_get_TY();
    wa = cwh_expr_address(f_T_PASSED);
    cwh_stk_push_STR(wn,wa,ts,ADDR_item);
    break;

  case FLD_item:
    det = cwh_addr_offset();
    fld = cwh_types_fld_dummy(det.off,det.type);
    cwh_stk_push((void *)fld.Idx (),FLD_item);
    wa  = cwh_expr_address(f_T_PASSED);
    cwh_stk_push_typed(wa,ADDR_item, cwh_types_make_pointer_type(det.type, FALSE));
    break;

  case WN_item_whole_array:
    wa = cwh_expr_address(f_T_PASSED);
    DevAssert ((WNOPR(wa) == OPR_ARRAY), ("Whole array isnt an ARRAY"));
    wa = WN_kid0(wa);	/* the base */
    ty = cwh_types_WN_TY(wa,FALSE);
    ty = cwh_types_make_pointer_type(ty, FALSE);
    cwh_stk_push_typed(wa,ADDR_item,ty);
    break;

  default:
    wa = cwh_expr_address(f_T_PASSED);
    if (WNOPR(wa) == OPR_ARRAY) {
      ty = cwh_types_WN_TY(wa,FALSE);
      ty = cwh_types_array_TY(ty);
      ty = cwh_types_scalar_TY(ty);
      ty = cwh_types_make_pointer_type(ty, FALSE);
      cwh_stk_push_typed(wa,ADDR_item,ty);

    } else
      cwh_stk_push(wa,ADDR_item);
    break;
  }
}

/*===============================================
 *
 * fei_fcd
 *
 * A reference via a cray character pointer is
 * on the stack. Make it into a STR_item and
 * & push it. The address should look as though 
 * it came from fei_arg_addr ie: an ADDR_item.
 *
 *===============================================
 */ 
/*ARGSUSED*/
void
fei_fcd(TYPE result_type)
{
#ifdef KEY /* Bug 10177 */
  WN *wn = 0;
#else /* KEY Bug 10177 */
  WN *wn ;
#endif /* KEY Bug 10177 */
  WN *ad ;
  WN *ln ;
  TY_IDX ts ;

  ts = cwh_stk_get_TY();
  ad = cwh_stk_pop_WHIRL();  
  ln = cwh_stk_pop_WHIRL();

  if (WNOPR(ad) == OPR_INTCONST) {

    wn = WN_Intconst(Pointer_Mtype,WN_const_val(ad));

    WN_DELETE_Tree(ad);
    ad = wn;
    
  }
  if (ts == 0)
    ts = cwh_types_WN_TY(wn,FALSE);

  cwh_stk_push_STR(ln,ad,ts,ADDR_item);

}
/*===============================================
 *
 * fei_addr_con
 *
 * A constant as an actual argument. Find or
 * make (integers) the constant's ST, make an
 * address & push the address.
 *
 *===============================================
 */ 
extern void 
fei_addr_con(TYPE type)
{
  WN * wn;
  WN * wt;
  ST * st;
  TY_IDX  ty;

  TCON tc  ;
  TYPE_ID bt ;


  switch (cwh_stk_get_class()) {
  case STR_item:
    cwh_stk_pop_STR();
    wn = cwh_stk_pop_WN();
    ty = cwh_stk_get_TY();
    wt = cwh_expr_address(f_T_PASSED);
    cwh_stk_push_STR(wn,wt,ty,ADDR_item);
    break;

  default:
    ty = cwh_stk_get_TY();
    wn = cwh_stk_pop_WN();
    
    if (WNOPR(wn) == OPR_INTCONST)  {
      
      if (ty == 0) {
	bt = WNRTY(wn);
      } else {
	bt = TY_mtype(ty);
      }
      tc = Host_To_Targ (bt,WN_const_val(wn));
      st = New_Const_Sym(Enter_tcon (tc), Be_Type_Tbl(bt));

    } else 
      st = WN_st(wn);
    
    wt = cwh_addr_address_ST(st,0);
    cwh_stk_push(wt,ADDR_item);
  }
}

/*===============================================
 *
 * fei_entry_pt
 *
 * Generate an OPC_ALTENTRY and tack the dummy
 * argument list on. Idx is the ST of the entry.
 *
 *===============================================
 */ 
extern void 
fei_entry_pt(INTPTR idx)
{
  ST    *st ;
  ST   **ap ;
  WN    *wn ;
  STB_pkt *p ;
  
  INT16 nkids,i ;
  
  p  = cast_to_STB(idx);
  st = cast_to_ST(p->item);
  
  nkids = cwh_auxst_num_dummies(st);
  ap    = cwh_auxst_arglist(st);

  wn = WN_Create (OPC_ALTENTRY, nkids);
  WN_st_idx(wn) = ST_st_idx(st);
  
  for (i = 0 ; i < nkids ; i ++) 
    WN_kid(wn,i) = WN_CreateIdname ( 0, *ap++);

  cwh_block_append(wn) ;
  (void) cwh_block_toggle_debug(FALSE) ;
}     

/*===============================================
 *
 * fei_goto
 *
 * Generate a GOTO to the label whose ST is provided.
 *
 *===============================================
 */ 
extern void 
fei_goto(INT32 lbl_idx)
{
  LABEL_IDX lb ;

  lb = cast_to_LB(lbl_idx);
  cwh_stmt_goto(lb);
}

/*===============================================
 *
 * fei_arith_goto
 *
 * Handles the Fortran arithmetic goto statement. 
 * 
 * The expression used for computing the goto is on
 * the stack.
 * If all three labels are equal, a single goto is
 * generated. If any two labels are equal, the labels
 * are combined into two labels. The expression is
 * compared against zero and branches are generated
 * to the right labels.
 *
 *===============================================
 */

extern void
fei_arith_goto(INT32 eq_lbl,
               INT32 gt_lbl,
               INT32 lt_lbl )
{
  WN *expr;
  WN *val1, *val2;
  WN *wn;
  LABEL_IDX lb ;
  TY_IDX ty;
  OPCODE opc;
  OPERATOR opr;
  INT32 true_lbl;
  INT32 false_lbl;


  if (lt_lbl == eq_lbl && gt_lbl == eq_lbl) {

    /* All three labels are the same */

    cwh_stmt_goto(cast_to_LB(eq_lbl));
    expr = cwh_expr_operand(NULL);

  } else {

    expr = cwh_expr_operand(NULL);
    ty   = Be_Type_Tbl(WN_rtype(expr));

    if ( WN_operator(expr) == OPR_SUB ) {
      val1 = WN_kid0(expr);
      val2 = WN_kid1(expr);
    } else {
      val1 = expr;
      if (MTYPE_is_integral(TY_mtype(ty))) {
        opc = cwh_make_typed_opcode(OPR_INTCONST, TY_mtype(ty), MTYPE_V);
        val2 = WN_CreateIntconst ( opc, 0 );
      } else {
        val2 = Make_Zerocon ( TY_mtype(ty) );
      }
    }
 
    if (eq_lbl != lt_lbl &&
	eq_lbl != gt_lbl &&
	lt_lbl != gt_lbl ) {
       /* All three labels are different.
	* Nothing much can be done in this case.
	*/
      lb = cast_to_LB(lt_lbl);

      wn = cwh_stmt_truebr(WN_COPY_Tree(val1), WN_COPY_Tree(val2), ty, OPR_LT,lb);
      cwh_block_append(wn);

      lb = cast_to_LB(gt_lbl);
      wn = cwh_stmt_truebr(WN_COPY_Tree(val1), WN_COPY_Tree(val2), ty, OPR_GT,lb);
      cwh_block_append(wn);
      cwh_stmt_goto(cast_to_LB(eq_lbl));


    } else {
      /* Two of the labels are the same.
       * Figure out how to combine these two.
       */
      if (eq_lbl == lt_lbl) {
         opr = OPR_LE;
	 true_lbl  = eq_lbl;
	 false_lbl = gt_lbl;

      } else if (eq_lbl == gt_lbl) {
         opr = OPR_GE;
	 true_lbl  = eq_lbl;
	 false_lbl = lt_lbl;

      } else {
         opr = OPR_NE;
	 true_lbl  = gt_lbl;
	 false_lbl = eq_lbl;
      }

      lb = cast_to_LB(true_lbl);
      wn = cwh_stmt_truebr(WN_COPY_Tree(val1), WN_COPY_Tree(val2), ty, opr,lb);
      cwh_block_append(wn);
      cwh_stmt_goto(cast_to_LB(false_lbl));
    }
  }
}

/*===============================================
 *
 * fei_label_ref
 *
 * Places a label on the stack. 
 *
 *===============================================
 */
extern void
fei_label_ref(INT32   lbl_idx)
{
  LABEL_IDX lb;
  lb = cast_to_LB(lbl_idx);
  cwh_stk_push(cast_to_void(lb),LB_item);
}

/*===============================================
 *
 * fei_label_addr
 *
 * Used with Fortran Assign statement. 
 * 
 * Increments the index into the table that has all
 * the assigned goto labels. This is only done if the 
 * label hasn't been seen before, in which case the assign_id
 * field in the AUXST will be -1. Creates an INTCONST out
 * of this index and pushes it on the stack. This node
 * ends up getting stored into the location of the ASSIGN 
 * var later.
 *
 *===============================================
 */
/*ARGSUSED*/
extern void
fei_label_addr(INT32 lbl_idx)
{
  WN *wn;
  INT32 *assign_id;

  assign_id = cwh_auxst_assign_id(CURRENT_SYMTAB, LABEL_IDX_index((LABEL_IDX)lbl_idx));

  if (*assign_id == -1)
     *assign_id = cwh_assign_label_id++;

  wn = WN_CreateIntconst (OPC_I4INTCONST, *assign_id);
  cwh_stk_push(wn, WN_item);
}

/*===============================================
 *
 * cwh_stmt_computed_goto
 *
 * Handle the Fortran computed goto statement.
 *
 * Labels referenced are pushed on the stack via fei_label_ref.
 * Below the labels is the expression that controls
 * the computed goto.
 * If there are more than 6 distinct labels in the list of labels
 * the routine just generates a COMPGOTO, otherwise, it converts
 * this into the appropriate TRUE and FALSE branches.
 *
 *===============================================
 */

static void
cwh_stmt_computed_goto(INT32 num_labels)
{
  LABEL_IDX *label_list;
  LABEL_IDX  default_label_num = 0;
  WN *parent_block;
  WN *wn;
  WN *default_label;
  WN *expr;
  OPERATOR opr;
  LABEL_IDX lb;
  LABEL_IDX last_label=0;
  INT32 sequences=0;
  INT32 count;
  INT32 i;

  label_list = (LABEL_IDX *) malloc(num_labels*sizeof(LABEL_IDX));

  for(i=num_labels-1; i>=0; i--) {
    label_list[i] = cwh_stk_pop_LB();
    if (label_list[i] != last_label) {
      sequences++;
      last_label = label_list[i];
    }
  }   

  expr = cwh_expr_operand(NULL);

  if (num_labels == 1) {

    cwh_stmt_append_truebr(WN_COPY_Tree(expr),1, OPR_EQ, label_list[0]);

  } else if ( sequences == 1 && num_labels >= 2) {

    (void) New_LABEL (CURRENT_SYMTAB, default_label_num);

    cwh_stmt_append_truebr(WN_COPY_Tree(expr),1, OPR_LT,default_label_num);
    cwh_stmt_append_truebr(WN_COPY_Tree(expr),num_labels, OPR_LE,label_list[0]);

  } else if ( num_labels <= COMPGOTO_IF_ELSE) {

    for(i=0; i<num_labels; i++) {
      cwh_stmt_append_truebr(WN_COPY_Tree(expr),i+1,OPR_EQ,label_list[i]);
    }

  } else if (sequences <= COMPGOTO_IF_ELSE) {

    (void) New_LABEL (CURRENT_SYMTAB, default_label_num);
    cwh_stmt_append_truebr(WN_COPY_Tree(expr),1,OPR_LT,default_label_num);

    last_label = label_list[0];
    count = 0;

    for(i=0; i<num_labels; i++) {
       if (label_list[i] == last_label) {
	  count++;
       } else {
	  lb  = last_label;
	  if (count == 1) 
	    opr = OPR_EQ;
          else 
	    opr = OPR_LE;
	  cwh_stmt_append_truebr(WN_COPY_Tree(expr),i,opr,lb);
	  count = 1;      
	  last_label = label_list[i];
       }
    }

    if (count == 1) 
      opr = OPR_EQ;
    else 
      opr = OPR_LE;

    cwh_stmt_append_truebr(WN_COPY_Tree(expr),num_labels,opr,last_label);      

  } else {

    parent_block = cwh_block_new_and_current();
    (void) New_LABEL (CURRENT_SYMTAB, default_label_num);
    cwh_stmt_goto(default_label_num);

    for(i=0; i<num_labels; i++) {
      cwh_stmt_goto(label_list[i]);
    } 

    default_label = WN_CreateGoto (default_label_num);
    wn = WN_CreateCompgoto (num_labels+1, expr, cwh_block_current(), default_label, 0);
    cwh_block_set_current(parent_block);
    cwh_block_append(wn);

  }
  
  if (default_label_num) {
     wn = WN_CreateLabel(default_label_num, 0,NULL);
     cwh_block_append(wn);
  }
}
  
/*===============================================
 *
 * cwh_stmt_assigned_goto
 *
 * Handle the Fortran Assigned goto statement.
 * All the labels that have appeared in an ASSIGN
 * statement are on the stack in the order they appeared
 * in the source. The VAR that controls the assigned
 * goto is below those labels. The labels are popped and stored
 * into the array cwh_assign_label_array. VAR at this point has
 * a value (from fei_label_addr) that can be used to index the
 * array cwh_assign_label_array to get the corresponding label.
 *
 *===============================================
 */

static void
cwh_stmt_assigned_goto(INT32 num_labels)
{
  INT32 i;
  LABEL_IDX default_label_num = 0;
  WN *expr;
  WN *parent_block;
  WN *wn;
  WN *default_label;
  LABEL_IDX lb;
  LABEL_IDX *cwh_assign_label_array=NULL;

  cwh_assign_label_array = (LABEL_IDX *) malloc (sizeof(LABEL_IDX *) * num_labels);
  
  for(i=0; i<num_labels; i++) 
    cwh_assign_label_array[i] = cwh_stk_pop_LB();

  expr = cwh_expr_operand(NULL);

  if (num_labels <= COMPGOTO_IF_ELSE) {

    for(i=0; i<num_labels; i++ ) {
      lb = cwh_assign_label_array [i];
      cwh_stmt_append_truebr(WN_COPY_Tree(expr),i,OPR_EQ,lb);
    }

  } else {

    parent_block = cwh_block_new_and_current();
    (void) New_LABEL (CURRENT_SYMTAB, default_label_num);
    default_label = WN_CreateGoto (default_label_num);
  
    for(i=0; i<num_labels; i++ ) {
      cwh_stmt_goto(cwh_assign_label_array [i]);
    }
  
    wn = WN_CreateCompgoto (num_labels, expr, cwh_block_current(), default_label, 0);
    cwh_block_set_current(parent_block);
    cwh_block_append(wn);
    wn = WN_CreateLabel(default_label_num, 0,NULL);
    cwh_block_append(wn);
  }
}


/*===============================================
 *
 * cwh_stmt_truebr
 *
 * Utility to generate a OPC_TRUEBR given an
 * expression, val, label and operator. Does
 * not append the WN, but returns it.
 *
 *===============================================
 */
static WN * 
cwh_stmt_truebr(WN *expr, WN *val, TY_IDX ty, OPERATOR opr, INT32 label_no)
{
  WN * wn;
  WN * test;

  OPCODE opc;

  opc  = cwh_make_typed_opcode(opr, MTYPE_I4, Mtype_comparison(TY_mtype(ty)));
  test = WN_CreateExp2 ( opc, expr, val);
  wn   = WN_CreateTruebr (label_no, test );

  return wn;
}

/*===============================================
 *
 * cwh_stmt_append_truebr
 *
 * Utility to generate a OPC_TRUEBR given an
 * integer constant, label and operator & append it
 * to the current block.
 *
 *===============================================
 */
static void
cwh_stmt_append_truebr(WN *expr, INT64 con, OPERATOR opr, INT32 label_no)
{
  WN * wn;
  WN * val;
  TY_IDX ty;
  OPCODE opc;

  ty  = Be_Type_Tbl(WN_rtype(expr));
  opc = cwh_make_typed_opcode(OPR_INTCONST, TY_mtype(ty), MTYPE_V);

  val = WN_CreateIntconst (opc,con);
  wn  = cwh_stmt_truebr(expr,val,ty,opr,label_no) ;
  cwh_block_append(wn);
}

/*===============================================
 *
 * cwh_stmt_falsebr
 *
 * Utility to generate a OPC_FALSEBR given an
 * expression, val, label and operator.Does
 * not append the WN, but returns it.
 *
 *===============================================
 */
static WN * 
cwh_stmt_falsebr(WN *expr, WN *val, TY_IDX ty, OPERATOR opr, INT32 label_no)
{
  WN * wn;
  WN * test;

  OPCODE opc;

  opc  = cwh_make_typed_opcode(opr, MTYPE_I4, Mtype_comparison(TY_mtype(ty)));
  test = WN_CreateExp2 ( opc, expr, val);
  wn   = WN_CreateFalsebr (label_no, test );

  return wn;
}

/*===============================================
 *
 * cwh_stmt_goto
 *
 * Utility to generate an OPC_GOTO the label.
 * Appends it to the current block. 
 *
 *===============================================
 */
static void
cwh_stmt_goto(LABEL_IDX label)
{
  WN * wn;
  wn = WN_CreateGoto(label);
  cwh_block_append(wn) ;
}

/*===============================================
 *
 * fei_indirect_goto
 *
 * Handle computed goto and assigned goto. A zero
 * value for assign_goto_flag indicates that this 
 * is a call for computed goto; a non-zero value
 * indicates that the call is for an assigned goto.
 *
 *===============================================
 */
extern void
fei_indirect_goto(INT32 num_labels,
                  INT32 assign_goto_flag )
{

  if (assign_goto_flag == 0)
     cwh_stmt_computed_goto(num_labels);
  else 
     cwh_stmt_assigned_goto(num_labels);
}


/*===============================================
 *
 * cwh_stmt_select_char
 *
 * Handles the fortran 90 select statement when the controlling expression
 * is a character expression. The expression controlling the select is on 
 * top of the stack. The two args to the routine are:
 * 1. Number of SELECT cases.
 * 2. Symbol table index for default label.
 *
 * The routine just builds a whirl node that contains the goto to the
 * default label. 'last_node' remembers the position where the last whirl
 * node was appended in the current block. This position is used to emit 
 * the IF's to handle the individual cases of the SELECT statement later.
 *
 * Before exit, the routine will push the following items back on 
 * the stack:
 * 1. num_cases
 * 2. Whirl node that conatins the goto to the default label
 * 3. The select expression
 * 4. last_node
 *
 *===============================================      

 */
static void
cwh_stmt_select_char(INT32 num_cases,
               INT32 default_label_idx )
{
  WN *wn1;
  W_node expr[2];
  WN *default_label;
  WN *last_node;
  LABEL_IDX lb;

  cwh_expr_str_operand(expr);
  
  if (num_cases > 0) {

    last_node = WN_last(cwh_block_current());

    lb = cast_to_LB(default_label_idx);
    default_label = WN_CreateGoto (lb);

    /* Now push num_cases, default_label, expr and last_node back on the stack */

    wn1 = WN_CreateIntconst(OPC_I4INTCONST, num_cases);
    cwh_stk_push(wn1, WN_item);
    cwh_stk_push(default_label, WN_item);
    cwh_stk_push_STR(W_wn(expr[0]), W_wn(expr[1]),W_ty(expr[1]), WN_item);
    cwh_stk_push(last_node, WN_item);

  } else {  /* empty select */

    WN_DELETE_Tree(W_wn(expr[0]));
    WN_DELETE_Tree(W_wn(expr[1]));

  }
}

/*===============================================
 *
 * cwh_stmt_select_case_char
 *
 * Handle individual cases in a select statement controlled by a character
 * expression. On entry, the stack holds the following items, starting from 
 * the top:
 * 1. high_range if present
 * 2. low_range if present
 * 3. Label to branch to
 * 4. last_node, position within current block where to generate the IF's.
 * 5. The select expression
 * 6. whirl node containing goto to the default label
 * 7. Remaining cases to be handled for this select
 *
 * The args to the routine are:
 * 1. flag to indicate low range present
 * 2. flag to indicate high range present
 * 3. flag to indicate if this is followed by a case which needs a branch to
 *    the same label; eg. case (-1, 0), will come as case(-1) and
 *    case(0) and for case(-1) this flag will be true, because case(0)
 *    requires a branch to the same label.
 * 
 * The routine copies the expr and the range items back on the stack and calls
 * cwh_expr_compare to do a character comparison. Depending on the outcome,
 * a branch is generated to the appropriate label.
 *
 * On exit, the routine is expected to push the following items back on 
 * the stack, if there are any remaining cases for this SELECT:
 * 1. If case_follows is TRUE, push the label back.
 * 2. remaining cases
 * 3. Whirl node that contains the goto to the default label
 * 4. The select expr.
 * 5. last_node
 *
 *
 *===============================================
 */

static void
cwh_stmt_select_case_char(INT32 low_value_pres,
                          INT32 high_value_pres,
                          INT32 case_follows)
{
  W_node val[2];
  W_node high_val[2];
  W_node expr[2];

  WN *copy[2];
#ifdef KEY /* Bug 10177 */
  copy[0] = copy[1] = 0;
#endif /* KEY Bug 10177 */
  WN *wn1;

  WN *last_node;
  WN *default_label;
  LABEL_IDX label;
  INT32 remaining_cases;
  LABEL_IDX new_label_num=0;
  OPERATOR opr;

  if (low_value_pres && high_value_pres)
    cwh_expr_str_operand(high_val);
  
  cwh_expr_str_operand(val);
  label     = cwh_stk_pop_LB();
  last_node = cwh_expr_operand(NULL);
  cwh_expr_str_operand(expr);
  default_label = cwh_expr_operand(NULL);
  remaining_cases = WN_const_val(cwh_expr_operand(NULL));
  (void) New_LABEL (CURRENT_SYMTAB, new_label_num);
  
  if (remaining_cases > 0) {
    copy[0] = WN_COPY_Tree(W_wn(expr[0]));
    copy[1] = WN_COPY_Tree(W_wn(expr[1]));
  }
  
  if (low_value_pres && high_value_pres) {

    WN *cpy[2];

    cpy[0] = WN_COPY_Tree(W_wn(expr[0]));
    cpy[1] = WN_COPY_Tree(W_wn(expr[1]));

    last_node = cwh_stmt_str_falsebr_util(OPR_GE,
					  expr,
					  val,
					  new_label_num,
					  last_node);

    W_wn(expr[0]) = cpy[0];
    W_wn(expr[1]) = cpy[1];

    last_node = cwh_stmt_str_falsebr_util(OPR_LE,
					  expr,
					  high_val,
					  new_label_num,
					  last_node);
  } else {
    
    if (low_value_pres) 
      opr = OPR_GE;
    else if (high_value_pres) 
      opr = OPR_LE;
    else
      opr = OPR_EQ;
    
    last_node = cwh_stmt_str_falsebr_util(opr,
					  expr,
					  val,
					  new_label_num,
					  last_node);
  }    
  
  wn1 = WN_CreateGoto(label);
  cwh_block_insert_after(last_node, wn1);
  last_node = wn1;
  
  wn1 = WN_CreateLabel(new_label_num,  0,NULL);
  cwh_block_insert_after(last_node, wn1);
  last_node = wn1;
  
  remaining_cases = remaining_cases - 1;

  if (remaining_cases != 0) {

    wn1 = WN_CreateIntconst(OPC_I4INTCONST, remaining_cases);
    cwh_stk_push(wn1, WN_item);
    cwh_stk_push(default_label, WN_item);
    cwh_stk_push_STR(copy[0], copy[1],W_ty(expr[1]),WN_item);       
    cwh_stk_push(last_node, WN_item);

    if (case_follows)
      cwh_stk_push(cast_to_void(label), LB_item);

  } else {

    cwh_block_insert_after(last_node, default_label);
  }
}

/*===============================================
 *
 * cwh_stmt_select_falsebr_util
 *
 * Utility function for cwh_stmt_select_case_char.
 * Sets up a comparison between the two operands,
 * and adds a Falsebr on the result to label. 
 *
 * Doesn't add to current block, but to a deferred 
 * list of WNs.
 * 
 *===============================================
 */
static WN *
cwh_stmt_str_falsebr_util(OPERATOR opr, 
			  W_node expr[2], 
			  W_node val[2], 
			  INT32 label,
			  WN *last_node)
{
  WN * test;
  WN * wn1 ;

  cwh_stk_push_STR(W_wn(expr[0]),W_wn(expr[1]),W_ty(expr[1]),WN_item);
  cwh_stk_push_STR(W_wn(val[0]), W_wn(val[1]), W_ty(val[1]), WN_item);

  cwh_expr_compare(opr,W_ty(expr[0]));

  test = cwh_expr_operand(NULL);
  wn1  = WN_CreateFalsebr(label, test);
  cwh_block_insert_after(last_node, wn1);

  return wn1 ;
}

/*===============================================
 *
 * fei_new_select
 *
 * Handles the fortran 90 select statement. The expression
 * controlling the select is on top of the stack. The two args
 * to the routine are:
 * 1. Number of SELECT cases.
 * 2. Symbol table index for default label.
 * Case statements such as " case(10:20,31) are split into
 * case(10:20) and case(31) when counting # of SELECT case statements.
 *
 * The select is lowered into an OPC_SWITCH. A block is generated
 * where fei_new_select_case later emits the CASEGOTO's. Also, to
 * handle ranges, the routine first stores the select expression
 * into a a temp and remembers this position in 'last_node', so
 * that later in fei_new_select_case it knows where to emit the code
 * to handle ranges. 
 * 
 * Before exit, the routine will push the following items back on 
 * the stack:
 * 1. num_cases
 * 2. Block where the case goto's will be emitted
 * 3. Temp which holds the select expression
 * 4. last node, position within current block, where the
 *    store to the temp was done.
 *
 *===============================================
 */

void
fei_new_select(INT32 num_cases,
#ifdef KEY /* Bug 12319 */
               INT32 last_label_idx,
#endif /* KEY Bug 12319 */
               INT32 default_label_idx )
{
  WN *parent_block;
  WN *wn;
  WN *wn1;
  WN *expr;
  WN *default_label;
  WN *last_node;
  LABEL_IDX lb;
  ST *tmp_st;
  TY_IDX ty;

  if (cwh_stk_get_class() == STR_item) {

     cwh_stmt_select_char(num_cases, default_label_idx);

  } else {
     
     expr = cwh_expr_operand(NULL);

     if ( num_cases > 0) {

       ty = Be_Type_Tbl(WN_rtype(expr));
       tmp_st = cwh_stab_temp_ST(ty, "select_expr");
       cwh_addr_store_ST(tmp_st, 0, ty, WN_COPY_Tree(expr));
       expr = cwh_addr_load_ST(tmp_st, 0, 0);
       last_node = WN_last(cwh_block_current());
       
       /* Create a new block; this is where the CASEGOTO's will be emitted */
   
       parent_block = cwh_block_new_and_current();
   
       lb = cast_to_LB(default_label_idx);
       default_label = WN_CreateGoto (lb);
       wn = WN_CreateSwitch (num_cases, expr, cwh_block_current(), default_label, 0);
   
       /* Now push num_cases, the block that will contain the */ 
       /* case goto's, expr and last_node back on the stack   */
	
       wn1 = WN_CreateIntconst(OPC_I4INTCONST, num_cases);
       cwh_stk_push(wn1, WN_item);
       cwh_stk_push(cwh_block_current(), WN_item);
       cwh_stk_push(expr, WN_item);
       cwh_stk_push(last_node, WN_item);
       
       /* Now get back to parent block and append the OPC_SWITCH */
       
       cwh_block_set_current(parent_block);
       cwh_block_append(wn);
#ifdef KEY /* Bug 12319 */
       LABEL_IDX last_lb = cast_to_LB(last_label_idx);
       WN_last_label(wn) = last_lb;
#endif /* KEY Bug 12319 */

     } else {  /* empty select */

       WN_DELETE_Tree(expr);
     }
   }
}

/*===============================================
 *
 * fei_new_select_case
 *
 * Handle individual cases in a select statement. On entry,
 * the stack holds the following items, starting from the top:
 * 1. high_range if present
 * 2. low_range if present
 * 3. Label to branch to
 * 4. last_node, position within current block where to emit code to
 *    handle ranges
 * 5. temp that holds the select expression
 * 6. Block where the CASEGOTO's will be emitted
 * 7. Remaining cases to be handled for this select
 *
 * The args to the routine are:
 * 1. flag to indicate low range present
 * 2. flag to indicate high range present
 * 3. flag to indicate if this is followed by a case which needs a branch to
 *    the same label; eg. case (-1, 0), will come as case(-1) and
 *    case(0) and for case(-1) this flag will be true, because case(0)
 *    requires a branch to the same label.
 * 
 * The case is converted into a CASEGOTO. If a range is present, a 
 * comparison is generated between the temp that holds the select expr
 * and the range, and if satisfied, the temp is set to to the lower bound
 * of the range if present, else it is set to the upper bound. The value
 * that the temp is set to is then used in the CASEGOTO. 
 *
 * On exit, the routine is expected to push the following items back on 
 * the stack, if there are any remaining cases for this SELECT:
 * 1. If case_follows is TRUE, push the label back.
 * 2. remaining cases
 * 3. Block that holds the CASEGOTO's
 * 4. temp that holds the select expr.
 * 5. last_node, position within current block where the code to handle
 *    ranges is emitted
 *
 *
 *===============================================
 */

void
fei_new_select_case(INT64 low_value_pres,
                    INT64 high_value_pres,
                    INT32 case_follows)
{
  WN *o_val;
#ifdef KEY /* Bug 10177 */
  WN *high_val = 0;
#else /* KEY Bug 10177 */
  WN *high_val;
#endif /* KEY Bug 10177 */
  WN *casegoto_block;
  WN *wn;
  WN *wn1;
  WN *expr;
  WN *last_node;
  LABEL_IDX label;
  TY_IDX ty;
  INT32 remaining_cases;
  LABEL_IDX new_label_num=0;

  if (cwh_stk_get_class() == STR_item) {
     
     cwh_stmt_select_case_char(low_value_pres, high_value_pres, 
			       case_follows);

   } else {

     if (low_value_pres && high_value_pres) 
       high_val = cwh_expr_operand(NULL);

     o_val = cwh_expr_operand(NULL);    
     label = cwh_stk_pop_LB();

     last_node = cwh_expr_operand(NULL);
     expr = cwh_expr_operand(NULL);
     casegoto_block  = cwh_expr_operand(NULL);
     remaining_cases = WN_const_val(cwh_expr_operand(NULL));

     if (low_value_pres ||  high_value_pres) {      /* if not empty or default case */

       ty = Be_Type_Tbl(WN_rtype(expr));
       (void) New_LABEL (CURRENT_SYMTAB, new_label_num);

       if (low_value_pres && high_value_pres) {

	 wn1 = cwh_stmt_falsebr(WN_COPY_Tree(expr), 
				WN_COPY_Tree(o_val), 
				ty, 
				OPR_GE, 
				new_label_num);
	 
	 cwh_block_insert_after(last_node, wn1);
	 last_node = wn1;
	 
	 wn1 = cwh_stmt_falsebr(WN_COPY_Tree(expr),
				WN_COPY_Tree(high_val), 
				ty, 
				OPR_LE, 
				new_label_num);
	 
       }  else {  /* not both, one of high & low */

	 OPERATOR opr = OPR_LE;

	 if (low_value_pres)
	   opr = OPR_GE;
	   
	 wn1 = cwh_stmt_falsebr(WN_COPY_Tree(expr), 
				WN_COPY_Tree(o_val), 
				ty, 
				opr, 
				new_label_num);
	 
       }  

       cwh_block_insert_after(last_node, wn1);
       last_node = wn1;

       wn1 = cwh_addr_stid (WN_st(expr), 0, ty, WN_COPY_Tree(o_val));
       cwh_block_insert_after(last_node, wn1);
       last_node = wn1;

       wn1 = WN_CreateLabel(new_label_num,  0,NULL);
       cwh_block_insert_after(last_node, wn1);
       last_node = wn1;

     }
     wn = WN_CreateCasegoto(WN_const_val(o_val),label);

     cwh_block_append_given_block(wn,casegoto_block);

     remaining_cases = remaining_cases - 1;

     if (remaining_cases != 0) {

       wn1 = WN_CreateIntconst(OPC_I4INTCONST, remaining_cases);
       cwh_stk_push(wn1, WN_item);
       cwh_stk_push(casegoto_block, WN_item);
       cwh_stk_push(expr, WN_item);
       cwh_stk_push(last_node,  WN_item);
       if (case_follows)
	 cwh_stk_push(cast_to_void(label), LB_item);
     }

   }
}

/*===============================================
 *
 * fei_label_def_named
 *
 * Generate an OPC_LABEL at the definition.
 * lbl_idx has the ST of the label.
 *
 * Directives may be set as flags..
 *
 *===============================================
 */ 
/*ARGSUSED*/
void fei_label_def_named(INT32         lbl_idx,
			 INT64   label_flag_word,
			 INT32         lineno,
			 INT32         sup_cnt,
			 INT32         keepme,
			 INT32         storage_seg,
			 INT32         safevl,
			 INT32         unroll_cnt,
			 char          *mark_name,
			 INT32         pipe_cnt,
			 INT32         last_argument,
			 INT32         unused1,
			 INT32         unused2,
			 INT32         unused3)
{
  WN * wn ;
  LABEL_IDX lb  ;
  WN * expr;
  

  if (!test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOT_REFERENCED)) { 
     lb = cast_to_LB(lbl_idx);
     wn = WN_CreateLabel(lb,0,NULL);
     
     if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_CASE))
	cwh_stk_push(cast_to_void(lb), LB_item);
    
     cwh_block_append(wn) ;
  }  

#ifdef _SGI_DIRS

  /* handle attached directives */

  if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_MAXCPUS)) {
 
     expr = cwh_expr_operand(NULL);
     cwh_stmt_add_xpragma(WN_PRAGMA_CRI_MAXCPUS,FALSE,expr);

  }
  if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SUPPRESS)) {
    cwh_directive_barrier_insert(NULL,sup_cnt);
  }

  if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_LOOPCHK)) {
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_PERMUTATION)) {
     /* cdir$permutation - DLAI */
     /* use KAP's ASSERT PERMUTATION for now */
     cwh_stmt_add_pragma(WN_PRAGMA_KAP_ASSERT_PERMUTATION);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_IVDEP)) {
     cwh_stmt_add_pragma(WN_PRAGMA_IVDEP);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOREDUCE)) {
     cwh_stmt_add_pragma(WN_PRAGMA_NORECURRENCE);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SHORTLOOP)) {
     cwh_stmt_add_pragma(WN_PRAGMA_CRI_SHORTLOOP,FALSE, NULL,64);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_DO_BL)) {
     cwh_stmt_add_pragma(WN_PRAGMA_CRI_BL,FALSE, NULL,1);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_CONCCALLS)) {
     cwh_stmt_add_pragma(WN_PRAGMA_KAP_ASSERT_CONCURRENT_CALL);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NEXTSCALAR)) {
     cwh_stmt_add_pragma(WN_PRAGMA_NEXT_SCALAR);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SHORTLOOP128)) {
     cwh_stmt_add_pragma(WN_PRAGMA_CRI_SHORTLOOP,FALSE, NULL,128);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SELECT_TASK)) {
     cwh_stmt_add_pragma(WN_PRAGMA_CRI_PREFERTASK);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOTASK)) {
     cwh_stmt_add_pragma(WN_PRAGMA_KAP_ASSERT_DO,FALSE, NULL,ASSERT_DO_SERIAL);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_UNROLL)) {
      /* An unroll count of 0 is the default unroll, which means no pragme is needed */
      if (unroll_cnt != 0) {
	 cwh_stmt_add_pragma(WN_PRAGMA_UNROLL,FALSE, NULL,unroll_cnt,-1);
      }
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_FISSIONABLE)) {
     cwh_stmt_add_pragma(WN_PRAGMA_FISSIONABLE);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_FUSABLE)) {
     cwh_stmt_add_pragma(WN_PRAGMA_FUSEABLE);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOFISSION)) {
     cwh_stmt_add_pragma(WN_PRAGMA_NO_FISSION);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOFUSION)) {
     cwh_stmt_add_pragma(WN_PRAGMA_NO_FUSION);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOINTERCHANGE)) {
     cwh_stmt_add_pragma(WN_PRAGMA_NO_INTERCHANGE);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOBLOCKING)) {
     cwh_stmt_add_pragma(WN_PRAGMA_NO_BLOCKING);
   }
   if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_AGGRESSIVEINNERLOOPFISSION)) {
     cwh_stmt_add_pragma(WN_PRAGMA_AGGRESSIVE_INNER_LOOP_FISSION);
   }
  }
#endif /* _SGI_DIRS */
}

/*===============================================
 *
 * fei_brtrue
 *
 * Generate an OPC_TRUEBR to the label supplied.
 * TOS has the condition as T/F. 
 *
 *===============================================
 */ 
extern void 
fei_brtrue(INT32 lbl_idx)
{
  WN *wn;
  WN *wc;
  LABEL_IDX lb ;

  lb = cast_to_LB(lbl_idx);
  wc = cwh_expr_operand(NULL);
  wn = WN_CreateTruebr(lb,wc);
  cwh_block_append(wn) ;
}

/*===============================================
 *
 * fei_where
 *
 * Generate an OPC_WHERE. The FFE has already
 * lowered WHERE blocks into WHERE statements,
 * so the ELSE clause of the WHERE is always
 * a empty block. The mask is a temp, or an 
 * lnot of a temp.
 *
 * TOS has the rhs, mask and expression. Tack
 * an OPC_ARRAYEXP around the mask. Change the
 * current block for the expression under the 
 * mask, then make an empty block, then switch 
 * back the original block to append the OPC_WHERE 
 * (and subsequent stmts) 
 *
 *===============================================
 */ 
extern void 
fei_where(INT32 defined_asg,
          INT32 inline_state)
{
  WN *msk ;
  WN *wn  ;
  WN *wl  ;
  TYPE dummy_type;
#ifdef KEY /* Bug 10177 */
  memset(&dummy_type, 0, sizeof(dummy_type));
#endif /* KEY Bug 10177 */
  INT64 flags = 0;

  msk = cwh_expr_operand(NULL);
  msk = F90_Wrap_ARREXP(msk);

  wl = cwh_block_new_and_current(); 

  wn = WN_Create(OPC_WHERE,3);
  WN_kid0(wn) = msk ;
  WN_kid1(wn) = cwh_block_current();

  if (defined_asg) {
    dummy_type = fei_descriptor(0,
                                Basic,
                                0,
                                V_oid,
                                0,
                                0);
    fei_call(2, dummy_type, By_Value_Call, FALSE, inline_state, flags);
  }
  else {
    fei_store(dummy_type);  /* It's OK for this to be uninitialized */
  }

  (void)  cwh_block_new_and_current(); 

  WN_kid2(wn) = cwh_block_current();

  cwh_block_set_current(wl);
  cwh_block_append(wn);

}

/*===============================================
 *
 * fei_stop
 * 
 * Generate a INTRIN_F90_STOP
 *
 * A scalar character stop code is on the stack.
 *
 *===============================================
 */

extern void
fei_stop( void )
{
  WN	*wa;
  WN	*wc;
  WN	*wn;
#ifdef KEY /* Bug 10177 */
  WN	*stop_code = 0;
  WN	*stop_code_len = 0;
#else /* KEY Bug 10177 */
  WN	*stop_code;
  WN	*stop_code_len;
#endif /* KEY Bug 10177 */

  if (cwh_stk_get_class() == STR_item) {
    cwh_stk_pop_STR();
    wa = cwh_stk_pop_WN();
    wc = WN_COPY_Tree(wa);
    stop_code_len = cwh_intrin_wrap_value_parm(wa);
    wa = cwh_stk_pop_ADDR();
    stop_code = cwh_intrin_wrap_char_parm(wa,wc);
  }
  else {
    DevAssert((0),("expected character stop code"));
  }

  wn = WN_Create ( OPC_VINTRINSIC_CALL, 2);
  WN_Set_Call_Default_Flags(wn);

  if (FE_Call_Never_Return)
    WN_Set_Call_Never_Return (wn);

  WN_kid0(wn) = stop_code;
  WN_kid1(wn) = stop_code_len;

  WN_intrinsic(wn) = INTRN_STOP_F90;

  cwh_block_append(wn);
}

/*===============================================
 *
 * fei_return
 *
 * Generate a return  - kind == 2 is void, so
 * just return. kind == 1 is a value, in a result
 * variable whose ST is TOS. kind =3 is an alternate
 * return whose index is a constant on the stack.
 *
 * If returning 
 *  - a scalar, in registers, then load the value
 *    and store into a preg. The exception is CQ
 *    results which have dummy arg introduced as
 *    a ref to the result.
 *
 *  - a character result, it's passed as a dummy, 
 *    but makes it here. A CASSIGNMENT has already
 *    been done, so punt.
 *
 *  - a derived type, larger than 16 bytes it's 
 *    passed as a dummy. Punt, we've done the store.
 *     Smaller than 16 bytes it's returned in regs.
 *
 * If it's an alternate entry point, we just get
 * the ST of the last entry, so ignore it. Put 
 * out a float and an integer version of the result, 
 * if both are required. 
 *
 * if an ST isn't TOS, then the WN/FLD is an 
 * expression which will be an alternate return index.
 *
 *===============================================
 */ 
/*ARGSUSED*/
extern void 
fei_return(INT return_kind, TYPE dummy)
{
  WN * wn;
  WN * ret_wn = NULL;
  ST * st;
  ST * rt;
  TY_IDX  ty;

  TYPE_ID bt;

  BOOL done_int;
  BOOL done_float;
  
  DevAssert(((return_kind >= 1) && (return_kind <= 3)),
	    (" odd return kind "));
  
  if (( return_kind == 1 ) ||
      ( return_kind == 3 )) {
    
    switch (cwh_stk_get_class()) {
    case ST_item:
    case ST_item_whole_array:
      st = cwh_stk_pop_ST();
      ty = ST_type(st);
      
      if ( WHIRL_Return_Val_On ) {

        if((ST_sclass(st) == SCLASS_FORMAL) &&
           (TY_kind(ty) == KIND_POINTER))
          ty = TY_pointed(ty);

        if ((TY_kind(ty) == KIND_SCALAR || TY_kind(ty) == KIND_STRUCT ||
	     (TY_kind(ty) == KIND_POINTER &&
	      TY_kind(TY_pointed(ty)) == KIND_FUNCTION)) &&
            (! ST_auxst_is_rslt_tmp(st)) &&
            (! cwh_types_is_character(ty))) {

          ret_wn = cwh_stmt_return_scalar(st,NULL,ST_type(st),TRUE);
        }
        else {
          /* void return */
          ret_wn = WN_CreateReturn();
        }
      }
      else {

        if (!IS_ALTENTRY_TEMP(st)) {

	  if((ST_sclass(st) == SCLASS_FORMAL) &&
	     (TY_kind(ty) == KIND_POINTER))
	    ty = TY_pointed(ty); 
      
          if ((TY_kind(ty) == KIND_SCALAR) &&
              (! ST_auxst_is_rslt_tmp(st)) &&
	      (! cwh_types_is_character(ty))) {

	    ret_wn = cwh_stmt_return_scalar(st,NULL,ST_type(st),TRUE);	

          } else if (STRUCT_BY_VALUE(ty)) {
	    (void) cwh_stmt_return_scalar(st,NULL,ST_type(st),TRUE);

	  } else {
            /* void return */
            ret_wn = WN_CreateReturn();
          }

        } else {
	
	  done_int   = FALSE;
	  done_float = FALSE;
	

	  ITEM *re = NULL;
          while ((re = cwh_auxst_next_element(ST_base(st),re,l_RETURN_TEMPS)) != NULL ) {
	    rt = I_element(re);
	    bt = TY_mtype(ST_type(rt));

	    if (MTYPE_is_float(bt)) {
	      if (! done_float) {
	        done_float = TRUE;
	        cwh_stmt_return_altentry(rt);
	      }
	    } else if (! done_int) {
	        done_int = TRUE;
	        cwh_stmt_return_altentry(rt);
	    }
	  }
        }
      }
      break;
      

    case WN_item:
    case WN_item_whole_array:
    case DEREF_item:
      wn = cwh_expr_operand(NULL);
      ty = Be_Type_Tbl(WNRTY(wn));
      ret_wn = cwh_stmt_return_scalar(NULL,wn,ty,TRUE);
      break;


    case FLD_item:
      ty = cwh_stk_get_FLD_TY();
      wn = cwh_expr_operand(NULL);
      ret_wn = cwh_stmt_return_scalar(NULL,wn,ty,TRUE);
      break;

    default:
      DevAssert((0),("Odd return"));

    }

    if ( WHIRL_Return_Val_On ) {
      if (ret_wn != NULL) {
        cwh_block_append(ret_wn);
      }
    }
    else {
      wn = WN_CreateReturn();
      cwh_block_append(wn) ;
    }
  }    
  else {
    /* void return, return_kind == 2 */
    wn = WN_CreateReturn();
    cwh_block_append(wn) ;
  }
}

/*===============================================
 *
 * cwh_stmt_return_scalar
 *
 * Utility for fei_return and fei_call. Takes a 
 * scalar ST/WN, and reads/writes the value and 
 * returns it in the correct preg. The TY is the
 * that of the result (eg: of the ST, if present)
 * 
 * If this is in a callee, the ST of the result 
 * variable is loaded, and put into a preg,
 * or if ST is NULL and a WN is present 
 * (eg: a constant), that's put into the preg
 * 
 * In a caller the result WN has a load of the preg,
 * the ST is usually NULL and the TY is that of the
 * value. If its a struct by value, then there is
 * a result temp, and a NULL is returned (don't
 * push it as there won't be an fei_store..)
 *
 * If a call the result WN has a load of the preg,
 * the ST is NULL and the TY is that of the value.
 *
 *===============================================
 */ 
extern WN *
cwh_stmt_return_scalar(ST *st, WN * rv, TY_IDX  rty, BOOL callee_return)
{
  TYPE_ID   rbtype1;
  TYPE_ID   rbtype2;
  PREG_NUM  rreg1;
  PREG_NUM  rreg2;


#ifdef KEY /* Bug 10177 */
  WN  * wn = 0;
#else /* KEY Bug 10177 */
  WN  * wn  ;
#endif /* KEY Bug 10177 */
  WN  * wn2  ;
  ST  * pr1 ;
  ST  * pr2 ;
  OFFSET_64 off;

  if (WHIRL_Return_Info_On) {

    RETURN_INFO return_info = Get_Return_Info (rty, Use_Simulated);

    if (RETURN_INFO_count(return_info) <= 2 ||
        WHIRL_Return_Val_On) {

      rbtype1 = RETURN_INFO_mtype (return_info, 0);
      rbtype2 = RETURN_INFO_mtype (return_info, 1);
      rreg1 = RETURN_INFO_preg (return_info, 0);
      rreg2 = RETURN_INFO_preg (return_info, 1);
    }

    else
      Fail_FmtAssertion ("cwh_stmt_return_scalar: more than 2 return registers");
  }

  else {
    Get_Return_Mtypes(rty, Use_Simulated, &rbtype1, &rbtype2);
    Get_Return_Pregs(rbtype1, rbtype2, &rreg1, &rreg2);
  }

  pr1 = MTYPE_To_PREG(rbtype1);
  pr2 = MTYPE_To_PREG(rbtype2);

  if (callee_return) {

    if ( WHIRL_Return_Val_On ) {
      if (st == NULL) {
        wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, rv);
        Set_PU_has_very_high_whirl (Get_Current_PU ());
      }
      else {

# ifndef ORIGINAL_SGI_CODE
        wn2 = cwh_addr_load_ST(st,0,0);
        wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn2);
# else
        if (IS_ALTENTRY_TEMP(st)) {
          wn2 = cwh_addr_ldid(ST_base(st),0,ST_type(ST_base(st)));
          wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (ST_type(ST_base(st))), MTYPE_V, wn2);
        } else {
          wn2 = cwh_addr_load_ST(st,0,NULL);
          wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn2);
        }
# endif

        Set_PU_has_very_high_whirl (Get_Current_PU ());
      }
    }
    else {
      if (st == NULL)
        cwh_addr_store_ST(pr1,rreg1,rty,rv);

      else {

        if (TY_kind(ST_type(st)) == KIND_STRUCT) {

          wn = cwh_addr_mk_ldid(st,0,rbtype1,rty);
          cwh_addr_store_ST(pr1,rreg1,Be_Type_Tbl(rbtype1),wn);

          if (rreg2 !=0) {

            off = PREG2_OFFSET(pr1,pr2);
            wn  = cwh_addr_mk_ldid(st,off,rbtype2,rty);
            cwh_addr_store_ST(pr2,rreg2,Be_Type_Tbl(rbtype2),wn);
          }

        } else if (IS_ALTENTRY_TEMP(st)) {

          wn = cwh_addr_ldid(ST_base(st),0,rty);
          cwh_addr_store_ST(pr1,rreg1,rty,wn);

        } else {

          wn = cwh_addr_load_ST(st,0,0);
          cwh_addr_store_ST(pr1,rreg1,rty,wn);
        }
      }
    }
  } else {    /* caller return */
    
    if ( WHIRL_Return_Val_On ) {
      wn = cwh_addr_mk_ldid(Return_Val_Preg,-1, TY_mtype (rty), rty);


      if (STRUCT_BY_VALUE(rty)) {

	/* result into temp that was 1st arg, & don't push result WN */

        cwh_addr_store_ST(st,0,rty,wn);
	wn = NULL;
      }
    }
    else {
      /* caller - read result in pregs - if struct return */
      /* temp store pregs into temp, return temp          */

      wn = cwh_addr_load_ST(pr1,rreg1,Be_Type_Tbl(rbtype1));

    }
  }
  
  return wn;
}

/*===============================================
 *
 * cwh_stmt_return_altentry
 *
 * Utility for fei_return to return a shared altentry
 * result temp. This contains special return values.
 *
 *===============================================
 */ 
static void
cwh_stmt_return_altentry(ST *st)
{
  TYPE_ID   rbtype1;
  TYPE_ID   rbtype2;
  TYPE_ID   bt;

  PREG_NUM  rreg1;
  PREG_NUM  rreg2;

  WN  * wn;
  WN  * wn2;
  ST  * pr;
  TY_IDX rty;
  ST  ** p;
  BOOL same;

                    
  same = ST_auxst_altentry_shareTY(ST_base(st));
  rty  = cwh_stab_altentry_TY(st,same);

  if (TY_mtype(rty) == MTYPE_CQ) {

    p  = cwh_auxst_arglist(Procedure_ST) ;
    wn = cwh_addr_load_ST(st,0,0);

    if ( WHIRL_Return_Val_On ) {
      wn2 = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn);
      cwh_block_append(wn2);
      Set_PU_has_very_high_whirl (Get_Current_PU ());
    }
    else {
      cwh_addr_store_ST(p[0],0,0,wn);
    }

  } else {
    
    if ( WHIRL_Return_Val_On ) {

      wn = cwh_addr_ldid(ST_base(st),0,rty);

      wn2 = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn);
      cwh_block_append(wn2);
      Set_PU_has_very_high_whirl (Get_Current_PU ());
    }
    else {
      if (WHIRL_Return_Info_On) {

        RETURN_INFO return_info = Get_Return_Info (rty, Use_Simulated);

        if (RETURN_INFO_count(return_info) <= 2) {

          rbtype1 = RETURN_INFO_mtype (return_info, 0);
          rbtype2 = RETURN_INFO_mtype (return_info, 1);
          rreg1 = RETURN_INFO_preg (return_info, 0);
          rreg2 = RETURN_INFO_preg (return_info, 1);
        }

        else
          Fail_FmtAssertion ("cwh_stmt_alt_entry: more than 2 return registers");
      }

      else {
        Get_Return_Mtypes(rty, Use_Simulated, &rbtype1, &rbtype2);
        Get_Return_Pregs(rbtype1, rbtype2, &rreg1, &rreg2);
      }

      pr = MTYPE_To_PREG(rbtype1);

      wn = cwh_addr_ldid(ST_base(st),0,rty);
      bt = TY_mtype(rty);

      if (MTYPE_is_float(bt) && !same) {

        if (bt == MTYPE_C4) {
          wn = WN_CreateStid (OPC_C4STID, 32, Float32_Preg,rty,wn);
          cwh_block_append(wn);
        } else if (TY_size(rty) <= TY_size(Be_Type_Tbl(MTYPE_F8)))
          cwh_addr_store_ST(pr,rreg1,rty,wn);
        else {
          wn = WN_CreateStid (OPC_FQSTID, 32, Float64_Preg, rty, wn );
          cwh_block_append(wn);
        }

      } else
        cwh_addr_store_ST(pr,rreg1,rty,wn);
    }
  }
}

/*===============================================
 *
 * fei_concat
 *
 * Generate the intrinsic for concatenation.
 * The number of operands is the number of 
 * STR_items to pop from the stack. Addresses go
 * in the first half of the argument list, lengths 
 * in the second half. 
 *
 * A destination temp is allocated here, used as
 * 0'th arg (length 1st arg) , pushed onto the 
 * stack and will be copied by fei_store.
 *
 *===============================================
 */ 
extern void 
fei_concat(INT32 numops)
{
  INT32 i,nm,k,sc;
  WN ** sz ;
  WN ** wn ;
  WN  * rsz;
  WN  * wt ;
  WN  * ae ;
  TY_IDX ty ;  
  BOOL *va ;
  WN  *wr;

  ae  = NULL ;
  sc  = numops + 1 ;
  nm  = 2 * sc ;
  sz  = (WN **) malloc(nm * sizeof(WN *)) ;
  wn  = (WN **) malloc(nm * sizeof(WN *)) ;
  va  = (BOOL *) malloc(nm * sizeof(BOOL)) ;
  rsz = WN_Zerocon(cwh_bound_int_typeid);

  for (i = sc ; i >= 2 ;  i--) {
    k = i + numops ;
    cwh_stk_pop_STR();
    wn[k] = cwh_stk_pop_WN();
    wn[i] = F90_Wrap_ARREXP(cwh_expr_address(f_T_PASSED));
    if (WNOPR(wn[i]) == OPR_ARRAYEXP)
      ae = wn[i] ;
    sz[k] = NULL;
    sz[i] = WN_COPY_Tree(wn[k]) ;
    va[k] = TRUE;
    va[i] = FALSE;
    rsz   = cwh_expr_bincalc(OPR_ADD,rsz,WN_COPY_Tree(wn[k]));
  }

  /* if an ARRAYEXP (ae) appeared it was an elemental */
  /* concat and an array valued temp is needed        */

  ty = cwh_types_mk_character_TY(WN_COPY_Tree(rsz),NULL,TRUE);

  if (ae != NULL) {
     ty = cwh_types_array_temp_TY(ae,ty) ;
     wt = cwh_expr_temp(ty,WN_COPY_Tree(rsz),f_T_PASSED);     
     wt = cwh_addr_temp_section(wt,ty);
     wr = WN_COPY_Tree(wt);
     wt = F90_Wrap_ARREXP(wt);
  } else {
     wt = cwh_expr_temp(ty,WN_Intconst(MTYPE_I4,1),f_T_PASSED);   
     wr = WN_COPY_Tree(wt) ;
  }

  wn[0] = wt;
  wn[1] = WN_COPY_Tree(rsz) ;
  sz[0] = WN_COPY_Tree(rsz) ;
  sz[1] = NULL ;
  va[0] = FALSE;
  va[1] = TRUE ;

  cwh_intrin_call(INTRN_CONCATEXPR,nm,wn,sz,va,MTYPE_V);

  cwh_stk_push_STR(rsz,wr,ty,WN_item);

  free(sz);
  free(wn);
  free(va);
}

/*===============================================
 *
 * cwh_stmt_character_icall
 *
 * This is a character intrinsic call. The stack contains
 * two STR items - second argument on top. Pop the length
 * and address of each side, then make the
 * intrinsic call. 
 * (args are addr_lhs,addr_rhs,sz_lhs,sz_rhs)
 *
 * Sizes are passed to create OPC_PARM types.
 *
 *===============================================
 */ 
extern void
cwh_stmt_character_icall(INTRINSIC intrinsic)
{
  WN * ar[4];
  WN * sz[4];
  BOOL va[4];

  cwh_stk_pop_STR();
  ar[3] = cwh_expr_operand(NULL);
  ar[1] = cwh_expr_address(f_NONE);
  ar[1] = F90_Wrap_ARREXP(ar[1]);

  sz[3] = NULL;
  sz[1] = WN_COPY_Tree(ar[3]);
  va[3] = TRUE;
  va[1] = FALSE;

  cwh_stk_pop_STR();
  ar[2] = cwh_expr_operand(NULL);
  ar[0] = cwh_expr_address(f_NONE);
  ar[0] = F90_Wrap_ARREXP(ar[0]);

  sz[2] = NULL;
  sz[0] = WN_COPY_Tree(ar[2]);
  va[2] = TRUE;
  va[0] = FALSE;

#ifdef KEY /* Bug 10670 */
  WN *wn = cwh_intrin_call(intrinsic,4,ar,sz,va,MTYPE_V);
  WN_Set_Linenum(wn, USRCPOS_srcpos(current_srcpos));
#else /* KEY Bug 10670 */
  cwh_intrin_call(intrinsic,4,ar,sz,va,MTYPE_V);
#endif /* KEY Bug 10670 */
}

/*===============================================
 *
 * cwh_stmt_add_to_preamble
 *
 * Append the pragma WN argument to the callsite
 * block of the preamble. Check to see if the 
 * blocks have been set up - if not, then this
 * called from the declaration setup eg: a bounds 
 * expression in an ARRAY TY, so it's ignored.
 * 
 *===============================================
 */ 
extern BOOL
cwh_stmt_add_to_preamble(WN *wn,enum site block)
{
  BOOL res = FALSE; 

  if (block == block_ca)
    if (WN_pragma_ca != NULL) {
      WN_INSERT_BlockFirst (WN_pragma_ca,wn);
      res = TRUE;
    }

  if (block == block_pu)
    if (WN_pragma_pu != NULL) {
      WN_INSERT_BlockFirst (WN_pragma_pu,wn);
      res = TRUE;
    }

  return res; 
}

/*===============================================
 *
 * cwh_stmt_add_pragma
 *
 * Generate a PRAGMA node and add to the current
 * block. All args except the id are default NULL.
 *
 *===============================================
 */ 
extern void
cwh_stmt_add_pragma(WN_PRAGMA_ID  wn_pragma_id,
		    BOOL          is_omp,
		    ST	         *st,
		    INT32         arg1,
		    INT32         arg2)
{
  WN *wn;
  wn = WN_CreatePragma(wn_pragma_id, st, arg1, arg2);
  if (is_omp)
    WN_set_pragma_omp(wn);
  cwh_block_append(wn);
}

#ifdef KEY /* Bug 2660 */
/*===============================================
 *
 * cwh_stmt_add_options_pragma
 *
 * Generate a PRAGMA OPTIONS node and add it to the pragma
 * block for the current program unit.
 *
 *===============================================
 */ 
extern void
cwh_stmt_add_options_pragma(ST *st)
{
  /* Imitate handling of command-line switch -chunk=n; see
   * cwh_stmt_add_parallel_pragmas */
  WN *wn = WN_CreatePragma(WN_PRAGMA_OPTIONS, st, 0, 0);
  cwh_stmt_add_to_preamble(wn,block_pu);
}
#endif /* KEY Bug 2660 */

/*===============================================
 *
 * cwh_stmt_add_xpragma
 *
 * Generate a XPRAGMA node with a single kid 
 * and add to the current block. Arg will be kid0 
 * of xpragma. Omp and expr are default NULL.
 *
 *===============================================
 */ 
extern void
cwh_stmt_add_xpragma(WN_PRAGMA_ID  wn_pragma_id,
		     BOOL is_omp,
		     WN * expr)
{
  WN *wn;
  wn = WN_CreateXpragma(wn_pragma_id, (ST_IDX) NULL, 1);
  WN_kid0(wn) = expr;
  if (is_omp)
    WN_set_pragma_omp(wn);  
  cwh_block_append(wn);
}

/*================================================================
 *
 * fei_enddo
 * 
 * Pop the DOLOOP block, & leave block of loop body.
 *
 *================================================================
 */
void 
fei_enddo(void)
{
  WN *wn;

  if (FE_Endloop_Marker) {
    wn = WN_CreateComment("ENDLOOP");
    cwh_block_append(wn);
    cwh_auxst_clear(WN_st(wn));
  }

  cwh_block_pop_block();
}

/*================================================================
 *
 * fei_dowhile
 * 
 * Create a OPC_DOWHILE. TOS has the expression to
 * be evaluated. Push the current block and build the
 * body in a new block.
 *
 *================================================================
 */
void
fei_dowhile(void)
{
   WN *expr,*block,*w;
   
   expr  = cwh_expr_operand(NULL);
   block = WN_CreateBlock();
   WN_Set_Linenum (block, USRCPOS_srcpos(current_srcpos));
   w = WN_CreateWhileDo(expr,block);
   cwh_block_append(w);

   /* Push current block & set new block for body */

   cwh_block_push_block(NULL,NULL,FALSE,FALSE);
   cwh_block_set_current(block);
}

/*================================================================
 *
 * fei_doloop
 * 
 * Create a OPC_DOLOOP. TOS has stride, then ub,lb, variable.
 *
 * First check stride and upper bound, and if expressions move
 * into temps. Then if it's a float loop variable or the stride
 * isn't constant or the loop variable is a pointer the loop 
 * is canonlicalized - count is computed the increment is set 
 * to one and the user's index variable is kept up to date
 * by adding the stride on each iteration. This is done by 
 * maintaining a list of statements which are deferred to 
 * the end of the loop body. A new BLOCK is created and set
 * current to contain the body.
 *
 * For parallel loops, we calculate the user index var based on the
 * normalized index var if the loop is canonlicalized.
 *
 *================================================================
 */
void
fei_doloop(INT32	line)
{
   WN *lb;
   WN *ub,*ubcomp;
   WN *stride,*stride_in_loop;
#ifdef KEY /* Bug 10177 */
   ST *lcv = 0;
#else /* KEY Bug 10177 */
   ST *lcv;
#endif /* KEY Bug 10177 */
   WN *index_id;
   WN *stmts;
   WN *start;
   WN *end;
   WN *step;
   WN *wlcv = NULL;
#ifdef KEY /* Bug 10177 */
   TY_IDX ty = 0;
#else /* KEY Bug 10177 */
   TY_IDX ty;
#endif /* KEY Bug 10177 */

   USRCPOS pos;
   INT32    local_line_num;
   mUINT16  local_file_num;

   TYPE_ID doloop_ty,lcv_t;
   BOOL canonicalize;
   PREG_NUM loop_preg;
   WN *temp, *count;
   WN *deferred_update=NULL;    /* ie: deferred to end of loop body */
   WN *calcu=NULL;		/* calculate user index var */

   WN *doloop;
   WN *body;

   /* 
      example:
      C$DOACROSS NEST(i,j,k)
      DO i		<- is_nested=FALSE
       DO j		<- is_nested=TRUE
	DO k		<- is_nested=TRUE
	 DO l		<- is_nested=FALSE
   */

   BOOL is_top_pdo=FALSE;	/* is this the outermost loop of a PDO? */
   BOOL is_innermost=FALSE;	/* is innermost loop of a nest (if true if not
				   nested) */

   if ((nested_do_descriptor.type == WN_PRAGMA_PDO_BEGIN ||
        nested_do_descriptor.type == WN_PRAGMA_PARALLEL_DO)  &&
       nested_do_descriptor.explicit_end &&
       nested_do_descriptor.current==0 &&
       nested_do_descriptor.depth!=0) {
     is_top_pdo=TRUE;
   }


   if (nested_do_descriptor.depth!=0) {

     /* if a nested parallel do, generate a region for it */

     if (nested_do_descriptor.current>0) {

       body=cwh_mp_region(nested_do_descriptor.type,0,0,0,0,0,0);
       cwh_block_set_current(body);
     }

     nested_do_descriptor.current++;

     if (nested_do_descriptor.current >= nested_do_descriptor.depth) {
       /* this is the last nest, reset the descriptor */
       nested_do_descriptor.depth = 0;
       nested_do_descriptor.current = 0;
       is_innermost=TRUE;
     }
   }


   canonicalize = FALSE;

   stride = cwh_expr_operand(NULL);
   ub = cwh_expr_operand(NULL);
   lb = cwh_expr_operand(NULL);

   /* loop control variable may be ST, or DEREF of pointer - get type */

   if (cwh_stk_get_class() == ST_item || cwh_stk_get_class() == ST_item_whole_array) {

     lcv  = cwh_stk_pop_ST();
     if (ST_sclass(lcv) == SCLASS_FORMAL) {
	lcv_t = TY_mtype(TY_pointed(ST_type(lcv)));
	canonicalize = TRUE;
     } else {
	lcv_t = TY_mtype(ST_type(lcv));
     }

   } else {
     wlcv = cwh_stk_pop_WHIRL();
     ty = cwh_types_WN_TY(wlcv,FALSE);
     lcv_t =  TY_mtype(cwh_types_scalar_TY(ty));
     canonicalize = TRUE;     
   }

   /* create pregs for non-constant bounds or strides   */
   /* or for inconvenient types eg: real do loop varbls */
 
   lb = cwh_convert_to_ty(lb,lcv_t);
   ub = cwh_convert_to_ty(ub,lcv_t);
   stride = cwh_convert_to_ty(stride,lcv_t);

   if (lcv_t != MTYPE_I4 && lcv_t != MTYPE_I8) {
      canonicalize = TRUE;
      doloop_ty = cwh_doloop_typeid;
   } else {
      doloop_ty = lcv_t;
   }

   if (WNOPR(stride) != OPR_INTCONST) {
      canonicalize = TRUE;
   }
   if (WNOPR(stride) != OPR_INTCONST && WNOPR(stride) != OPR_CONST) {
      stride_in_loop = cwh_preg_temp_save("doloop_stride",stride);
   } else {
      stride_in_loop = WN_COPY_Tree(stride);
   }
      
   if (WNOPR(ub) != OPR_INTCONST && WNOPR(ub) != OPR_CONST) {
      ubcomp = cwh_preg_temp_save("doloop_ub",ub);
   } else {
      ubcomp = WN_COPY_Tree(ub);
   }

   /* for loops which can be parallelized, make sure the */
   /* lower bound is a constant or a preg                */

   if (parallel_do_count) {

     if (! ((WNOPR(lb) == OPR_INTCONST) ||
	    (WNOPR(lb) == OPR_LDID && ST_class(WN_st(lb)) == CLASS_PREG))) {
       lb = cwh_preg_temp_save("doloop_lb",lb);
     }
   }
    
   if (canonicalize) {

     /* Initialize lcv  - it needs a temp */

     WN *wc ;

     if (wlcv == NULL) {
       cwh_addr_store_ST(lcv,0,0,WN_COPY_Tree(lb));
       wc = cwh_addr_load_ST(lcv,0,0) ;

     } else {
       cwh_addr_store_WN(wlcv,0,0,WN_COPY_Tree(lb));
       wc = cwh_addr_load_WN(wlcv,0,0) ;
     }

     /* Compute iteration count */
#ifdef KEY // Bug 4660, 8272
     temp  = cwh_addr_extent(WN_COPY_Tree(lb),ub,stride_in_loop);
#else
     temp  = cwh_addr_extent(wc,ub,stride);
#endif
     count = cwh_convert_to_ty(temp,doloop_ty);

     if (WNOPR(count) != OPR_INTCONST) {
       count = cwh_preg_temp_save("doloop_count",count);
     }
     loop_preg = Create_Preg(doloop_ty,Index_To_Str(Save_Str("doloop_var")));
     index_id  = WN_CreateIdname(loop_preg,MTYPE_To_PREG(doloop_ty));

     start = WN_StidPreg(doloop_ty,loop_preg,WN_Intconst(doloop_ty,0));
     end   = WN_CreateExp2(OPCODE_make_op(OPR_LT,MTYPE_I4,doloop_ty),
			   WN_LdidPreg(doloop_ty,loop_preg),
			   count);
     step  = cwh_expr_bincalc(OPR_ADD,WN_LdidPreg(doloop_ty,loop_preg),
			      WN_Intconst(doloop_ty,1));
     step  = WN_StidPreg(doloop_ty,loop_preg,step);

     if (parallel_do_count) { /* parallel, calculate user index */
       calcu = cwh_expr_bincalc(OPR_ADD,WN_COPY_Tree(lb),
	cwh_expr_bincalc(OPR_MPY, WN_LdidPreg(doloop_ty,loop_preg), stride_in_loop));
       if (wlcv)
         calcu = cwh_addr_istore(wlcv,0,ty,calcu);
       else
         calcu = cwh_addr_stid(lcv,0,Be_Type_Tbl(lcv_t),calcu);

     } else { /* not parallel, add stride to user index */

       deferred_update = cwh_expr_bincalc(OPR_ADD,WN_COPY_Tree(wc),stride_in_loop);
       if (wlcv)
         deferred_update = cwh_addr_istore(wlcv,0,ty,deferred_update);
       else
         deferred_update = cwh_addr_stid(lcv,0,Be_Type_Tbl(lcv_t),deferred_update);
     }

     WN_DELETE_Tree(ubcomp);

   } else {
     
     OPERATOR op;
     
     index_id = WN_CreateIdname(0,lcv);
     start = WN_Stid(lcv_t, 0, lcv, Be_Type_Tbl(lcv_t), lb);

     /* Stride is an integer constant (+ve or -ve?)*/

     if (WN_const_val(stride) > 0) 
       op = OPR_LE;
     else
       op = OPR_GE;
     
     end  = WN_CreateExp2(OPCODE_make_op(op,MTYPE_I4,Mtype_comparison(lcv_t)),
			  WN_Ldid(lcv_t,0,lcv,ST_type(lcv)),
			  ubcomp);
     step = cwh_expr_bincalc(OPR_ADD,WN_Ldid(lcv_t,0,lcv,ST_type(lcv)),
			     stride_in_loop);
     step = WN_Stid(lcv_t, 0, lcv, ST_type(lcv), step);
     deferred_update = NULL;
   }
   
   stmts = WN_CreateBlock();
   WN_Set_Linenum (start, USRCPOS_srcpos(current_srcpos) );


   if (line > 0) {  /* 0 means no line number */
      USRCPOS_clear(pos);
      USRCPOS_filenum(pos) = USRCPOS_filenum(current_srcpos);
      USRCPOS_linenum(pos) = global_to_local_line_number(line);
      WN_Set_Linenum (step,  USRCPOS_srcpos(pos));
   }
   else {
      WN_Set_Linenum (step,  USRCPOS_srcpos(current_srcpos));
   }

   WN_Set_Linenum (stmts, USRCPOS_srcpos(current_srcpos) );

   doloop = WN_CreateDO(index_id, start, end, step, stmts, NULL);

   cwh_directive_insert_do_loop_directives();
   cwh_block_append(doloop);

   /* Push the current block & make loop body current block */

   cwh_block_push_block(deferred_update,calcu,TRUE,is_top_pdo);
   cwh_block_set_current(stmts);

   /* Add any MP directives required to start of the loop body */
      
   if (is_innermost)
     cwh_block_append_given(Top_of_Loop_Block);

   /* add calculation of the user index to the start of the loop body */

   if (calcu) {
     cwh_block_append(WN_COPY_Tree(calcu));
   }
   return;
}

/*================================================================
 *
 * fei_doforever
 * 
 * This is handled by a label & goto. Just keep the block
 * stack consistent for fei_enddo.
 *
 *================================================================
 */
void
fei_doforever(void)
{
   /* Dummy block push */
   cwh_block_push_block(NULL,NULL,FALSE,FALSE);
}

/*================================================================
 *
 * fei_if
 *
 *================================================================
 */

void
fei_if(void)
{
   WN *test;
   WN *if_then;
   WN *if_else;
   WN *if_cnstrct;

   test = cwh_expr_operand(NULL);

   if_then = WN_CreateBlock();
   if_else = WN_CreateBlock();
   WN_Set_Linenum (if_else, USRCPOS_srcpos(current_srcpos) );
   WN_Set_Linenum (if_then, USRCPOS_srcpos(current_srcpos) );

   if_cnstrct = WN_CreateIf(test, if_then, if_else);

   cwh_block_append(if_cnstrct);

   /* Push the current block */
   cwh_block_push_block(NULL,NULL,FALSE,FALSE);

   cwh_block_set_current(if_then);

   /* push the if_cnstrct on the stack */
   cwh_stk_push(if_cnstrct, WN_item);

   return;
}

/*================================================================
 *
 * fei_else
 *
 *================================================================
 */

void
fei_else(void)
{
   WN *if_else;
   WN *if_cnstrct;

   /* pop off the if construct */
   if_cnstrct = cwh_stk_pop_WN();

   /* get the else block */
   if_else = WN_kid2(if_cnstrct);

   cwh_block_set_current(if_else);

   /* push the if_cnstrct back on the stack */
   cwh_stk_push(if_cnstrct, WN_item);

   return;
}

/*================================================================
 *
 * fei_endif
 *
 * pop off the if construct from stack
 * 
 *================================================================
 */
void
fei_endif(void)
{
   WN *if_cnstrct;

   if_cnstrct = cwh_stk_pop_WN();

   cwh_block_pop_block();
   return;
}

static ST *allocate_routine_st = NULL;

/*================================================================
 *
 * cwh_inline_allocate
 * 
 * Called for the ALLOCATE statement to do the allocation via the
 * ALLOCATE_SGI intrinsic.This exposes the bounds setup to the optimizer,
 * so bounds can be propagated. Otherwise the whole dope vector is
 * considered to be modified by a call to _ALLOCATE.
 *
 *================================================================
*/

static void 
cwh_inline_allocate(WN **dopes, TY_IDX *types, INT num_dopes, WN *stat)
{
   INT idope,i;
   INT rank;
   WN *dope_addr;
   TY_IDX ty;
   TY_IDX el_ty;
   FLD_HANDLE fl;
   INT64 esize;
   INT64 flag_val;
   WN *size;
   WN *size2;
   WN *assoc;
   WN *flags;
   BOOL is_f90_pointer;
   WN *args[5];
   WN *iop;
   PREG_NUM size_preg;
   PREG_NUM addr_preg;
   TY_IDX addr_ty;

   /* Initialize stat to 0 */
   if (WNOPR(stat) != OPR_INTCONST) {
      cwh_addr_store_WN(WN_COPY_Tree(stat),0,0,WN_Zerocon(MTYPE_I4));
   }

   if (!allocate_routine_st) {
      allocate_routine_st = cwh_intrin_make_intrinsic_symbol("_F90_ALLOCATE_B",Pointer_Mtype);
   }
   

   for (idope=0; idope < num_dopes; idope++) {
      dope_addr = dopes[idope];

      size_preg = Create_Preg(cwh_bound_int_typeid,Index_To_Str(Save_Str("size_preg")));
      
      /* Get the rank and size of the object from the type */
      ty = types[idope];
      if (TY_kind(ty) == KIND_POINTER) ty = TY_pointed(ty);

      /* TY should be the TY of a dope vector Dope */
      TY & tt = Ty_Table[ty];
      is_f90_pointer = TY_is_f90_pointer(tt);

      /* Compute the rank from the size of the dope vector */
      rank = cwh_types_dope_rank(ty);
      
      fl = TY_fld(tt);
      addr_ty = FLD_type(fl);
      ty = TY_pointed(addr_ty);  /* this is the type of the object */
      /* Create a temp symbol to hold the address */
      addr_preg = Create_Preg(Pointer_Mtype,Index_To_Str(Save_Str("alloc_addr")));

      if (rank > 0) {
	 el_ty = TY_AR_etype(ty);
      } else {
	 el_ty = ty;
      }

      esize = TY_size(el_ty);
      if (esize != 0) {
	 size = WN_Intconst(cwh_bound_int_typeid,esize);
      } else {
	 /* This must be an assumed-length character dummy */
	 /* Pick up the size from the element_size field   */
	 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item);
#ifdef KEY /* Bug6845 */
	 fei_get_dv_hdr_fld(DV_EL_LEN_IDX);
#else /* KEY Bug6845 */
	 fei_get_dv_hdr_fld(2);
#endif /* KEY Bug6845 */
	 size = cwh_expr_operand(NULL);
      }
      
	size2 = WN_Int_Type_Conversion(size,MTYPE_I8);
      /* Build up the size in bytes */
      for (i = 0; i < rank; i++) {
	 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item);
	 fei_get_dv_extent(i+1,0);
	 size2 = cwh_expr_bincalc(OPR_MPY,cwh_expr_operand(NULL),size2);
      }
      size2 = WN_StidPreg(cwh_bound_int_typeid,size_preg,size2);
      cwh_block_append(size2);
      
	 
      /* First step, set the flags bits if it's a pointer */
      flag_val = 0;
      if (DEBUG_Trap_Uv) {
	 flag_val |= 4;
      }
      if (is_f90_pointer) {
	 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item);
	 cwh_stk_push(WN_Intconst(MTYPE_I4,1),WN_item);
#ifdef KEY /* Bug6845 */
	 fei_set_dv_hdr_fld(DV_PTR_ALLOC_IDX);
#else /* KEY Bug6845 */
	 fei_set_dv_hdr_fld(4);
#endif /* KEY Bug6845 */
	 flag_val |= 1;
      } 
      flags = WN_Intconst(MTYPE_I4,flag_val);


      /* get the value of assoc from the dope vector */
      cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item);
#ifdef KEY /* Bug6845 */
      fei_get_dv_hdr_fld(DV_ASSOC_IDX);
#else /* KEY Bug6845 */
      fei_get_dv_hdr_fld(3);
#endif /* KEY Bug6845 */
      assoc = cwh_intrin_wrap_value_parm(cwh_expr_operand(NULL));
      
      /* Build up the call to the _ALLOCATE_SGI intrinsic */
      args[0] = cwh_intrin_wrap_value_parm(WN_LdidPreg(cwh_bound_int_typeid,size_preg));
      args[1] = assoc;
      args[2] = cwh_intrin_wrap_value_parm(flags);
      
      if (WNOPR(stat) == OPR_INTCONST) {
	 args[3] = cwh_intrin_wrap_value_parm(WN_COPY_Tree(stat));
      } else {
	 args[3] = cwh_intrin_wrap_ref_parm(WN_COPY_Tree(stat),0);
      }
      
      /* fifth argument is the old value of the dope vector */
      cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item);
#ifdef KEY /* Bug6845 */
      fei_get_dv_hdr_fld(DV_BASE_IDX);
#else /* KEY Bug6845 */
      fei_get_dv_hdr_fld(1);
#endif /* KEY Bug6845 */
      args[4] = cwh_intrin_wrap_value_parm(cwh_expr_operand(NULL));

      iop = WN_Create(opc_call,5);

      for (i=0; i < 5; i++) {
	 WN_kid(iop,i) = args[i];
      }

      /* Build the call to the allocate routine */
      WN_st_idx(iop) = ST_st_idx(allocate_routine_st);
      WN_Set_Call_Does_Mem_Alloc(iop);
      WN_Set_Call_Non_Data_Mod(iop);
      WN_Set_Call_Parm_Mod(iop);
      WN_Set_Call_Parm_Ref(iop);
      cwh_block_append(iop);
      iop = cwh_stmt_return_scalar(NULL, NULL, Be_Type_Tbl(Pointer_Mtype), FALSE);
      iop = WN_StidPreg(Pointer_Mtype,addr_preg,iop);
      cwh_block_append(iop);
      
      /* Add stores to base address, orig_base and orig_size */
      /* base_address */
      cwh_stk_push_typed(WN_COPY_Tree(dope_addr),WN_item, types[idope]);
      cwh_stk_push(WN_LdidPreg(Pointer_Mtype,addr_preg),WN_item);
#ifdef KEY /* Bug6845 */
      fei_set_dv_hdr_fld(DV_BASE_IDX);
#else /* KEY Bug6845 */
      fei_set_dv_hdr_fld(1);
#endif /* KEY Bug6845 */
      
      /* orig_base */
      cwh_stk_push_typed(WN_COPY_Tree(dope_addr),WN_item, types[idope]);
      cwh_stk_push(WN_LdidPreg(Pointer_Mtype,addr_preg),WN_item);
#ifdef KEY /* Bug6845 */
      fei_set_dv_hdr_fld(DV_ORIG_BASE_IDX);
#else /* KEY Bug6845 */
      fei_set_dv_hdr_fld(9);
#endif /* KEY Bug6845 */

      /* orig size */
      cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item);
      size = cwh_expr_bincalc(OPR_SHL,WN_LdidPreg(cwh_bound_int_typeid,size_preg),
			      WN_Intconst(MTYPE_I4,3));
      cwh_stk_push(size,WN_item);
#ifdef KEY /* Bug6845 */
      fei_set_dv_hdr_fld(DV_ORIG_SIZE_IDX);
#else /* KEY Bug6845 */
      fei_set_dv_hdr_fld(10);
#endif /* KEY Bug6845 */
      
      /* Finally, set the assoc bit if allocation was successful */
      cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item);
      assoc = WN_LdidPreg(Pointer_Mtype,addr_preg);
      assoc = WN_CreateExp2(OPCODE_make_op(OPR_GT,MTYPE_I4,Pointer_Mtype),
			    assoc,
			    WN_Zerocon(Pointer_Mtype));
      cwh_stk_push(assoc,WN_item);
#ifdef KEY /* Bug6845 */
      fei_set_dv_hdr_fld(DV_ASSOC_IDX);
#else /* KEY Bug6845 */
      fei_set_dv_hdr_fld(3);
#endif /* KEY Bug6845 */
   }
}


/*================================================================
 *
 * fei_allocate
 * 
 * This routine handles ALLOCATE and DEALLOCATE. Each statement
 * has a list of objects to be (de)allocated. Each object gets
 * its own dope vector and these are stuffed into an argument
 * list and handed to the (de)allocate function. False Parms 
 * are added to indicate that the DOPE vectors are modified.
 *
 * When called the stack has 
 *  1) Arguments to the (DE) ALLOCATE call (count-3 of them)
 *  2) The address of the STAT variable, or 0
 *  3) The version+count argument (I4)
 *  4) The symbol for the routine to call
 *
 *================================================================
*/
extern void
fei_allocate(INT32 count)
{

   INT num_dopes,i,num_args;
   BOOL use_stat;
   WN **dopes;
   TY_IDX *types;
   WN *dope;
   WN *wn;
   WN *stat,*ver;
   ST *routine;
   TY_IDX temp_ty;
   TY_IDX pty;
   ST *temp_st;
   INT64 vernum;
   WN *call;
   char	temp_str[40];
   static INT32 temp_name_idx = 0;

   num_dopes = count - 3;
   dopes = (WN **) malloc(num_dopes*sizeof(WN *));
   types = (TY_IDX *) malloc(num_dopes*sizeof(TY_IDX ));
   for (i=0; i < num_dopes; i++) {
      types[i] = cwh_stk_get_TY();
      dopes[i] = cwh_expr_operand(NULL);
      if (!types[i]) {
	 /* Try to get the type from the actual address node */
	 types[i] = cwh_types_WN_TY(dopes[i],TRUE);
      }
   }
   stat = cwh_expr_operand(NULL);
   ver  = cwh_expr_operand(NULL);
   routine = cwh_stk_pop_ST();

   if (!strcmp(ST_name(routine),"_DEALLOC")) {
      use_stat = FALSE;
      num_args = num_dopes+1;
   } else if (!strcmp(ST_name(routine),"_ALLOCATE")) {
      cwh_inline_allocate(dopes,types,num_dopes,stat);
      free(dopes);
      free(types);
      return;
   } else {
      use_stat = TRUE;
      num_args = num_dopes+2;
   }
   
   /* Create the call */
   call = WN_Create(OPC_VCALL,num_args);
   WN_st_idx(call) = ST_st_idx(routine);
   WN_Set_Call_Parm_Ref(call);
   WN_Set_Call_Parm_Mod(call);
   WN_Set_Call_Does_Mem_Free(call);
   
   /* Make the temp for the argument list to the routine */
   sprintf(temp_str, "%s%d", ".alloctemp.", temp_name_idx);
   temp_ty = cwh_types_array_util(1,Be_Type_Tbl(Pointer_Mtype),Pointer_Size,
				  Pointer_Size*num_dopes+8,temp_str,TRUE);

   ARB_HANDLE arb = TY_arb(temp_ty);
   Set_ARB_ubnd_val(arb, num_dopes + (8/Pointer_Size));
   Set_ARB_stride_val(arb, Pointer_Size);

   sprintf(temp_str, "%s%d", ".alloc", temp_name_idx++);
   temp_st = cwh_stab_address_temp_ST(temp_str,temp_ty,FALSE);   
   Set_ST_base(temp_st, temp_st);
   cwh_expr_set_flags(temp_st, f_T_PASSED);
   
   WN_kid0(call) = cwh_intrin_wrap_ref_parm(cwh_addr_address_ST(temp_st, 0),0);
   
   /* Add the stat argument */
   if (use_stat) {
      if (WNOPR(stat) == OPR_INTCONST) {
	 /* No status present, set to a null */
	 WN_set_opcode(stat,OPCODE_make_op(OPR_INTCONST,Pointer_Mtype,MTYPE_V));
	 stat = cwh_intrin_wrap_value_parm(stat);
      } else {
	 stat = cwh_intrin_wrap_ref_parm(stat,0);
      }
      WN_kid1(call) = stat;
   }
   
   pty = Be_Type_Tbl(Pointer_Mtype);
   /* Fill in the temp */
   DevAssert((WN_opcode(ver) == OPC_I8INTCONST),("Expected I8INTCONST for allocate version."));
   if (Pointer_Size == 4) {
# ifndef ORIGINAL_SGI_CODE
      vernum = WN_const_val(ver) & (0xffffffff);
      cwh_block_append(cwh_addr_stid(temp_st,0,pty,
                                      WN_Intconst(Pointer_Mtype,vernum)));
      vernum = WN_const_val(ver) >> 32;
      cwh_block_append(cwh_addr_stid(temp_st,4,pty,
                                      WN_Intconst(Pointer_Mtype,vernum)));
# else
      vernum = WN_const_val(ver) >> 32;
      cwh_block_append(cwh_addr_stid(temp_st,0,pty,
                                      WN_Intconst(Pointer_Mtype,vernum)));
      vernum = WN_const_val(ver) & (0xffffffff);
      cwh_block_append(cwh_addr_stid(temp_st,4,pty,
                                      WN_Intconst(Pointer_Mtype,vernum)));
# endif
      WN_DELETE_Tree(ver);
   } else {
      cwh_block_append(cwh_addr_stid(temp_st,0,pty, ver));
   }
   
   for (i=0; i < num_dopes; i++) {
      dope = dopes[i];
      wn = cwh_addr_stid(temp_st, 8 + Pointer_Size*i,pty,WN_COPY_Tree(dope));
      cwh_block_append(wn);
      dope = cwh_intrin_wrap_ref_parm(dope,0);
      WN_Set_Parm_Dummy(dope);
      if (use_stat) {
	 WN_kid(call,i+2) = dope;
      } else {
	 WN_kid(call,i+1) = dope;
      }
   }
   
   /* Insert the call */

   cwh_block_append(call);
   free (dopes);
   free (types);
}

/*===============================================
 *
 * cwh_stmt_init_file
 *
 * Initialize data structures for WHIRL conversion
 * at the start of each compilation. The flag says
 * -ump was seen on the command line (SGI mp 
 * directives) and is just convenient here.
 *
 *===============================================
 */ 

extern void
cwh_stmt_init_file(BOOL sgi_mp)
{
  cwh_stmt_sgi_mp_flag = sgi_mp ;
  cwh_addr_init_target() ;
}

/*===============================================
 *
 * cwh_stmt_add_parallel_pragmas
 *
 * Add the pragmas for CHUNK and MP_SCHEDTYPE 
 * as specified on the command line
 *
 *===============================================
 */ 
static void
cwh_stmt_add_parallel_pragmas(void)
{
   WN *prag;

   if (global_chunk_pragma_set) {
      prag = WN_CreateXpragma(WN_PRAGMA_CHUNKSIZE, (ST_IDX) 0, 1);
      WN_kid0(prag) = WN_Intconst(MTYPE_I4,global_chunk_pragma_value);
      cwh_stmt_add_to_preamble(prag,block_pu);
   }
   
   if (global_schedtype_pragma_set) {
      prag = WN_CreatePragma(WN_PRAGMA_MPSCHEDTYPE, (ST_IDX) NULL, global_schedtype_pragma_val,4);
      cwh_stmt_add_to_preamble(prag,block_pu);
   }
}

#ifdef KEY /* Bug 4260 */
/*
 * symname	Name of global data symbol to export as I*4 variable
 * value	Initial value for symbol
 */
static void
export_i4_sym(const char *symname, int value) {
  TY_IDX int_ty_idx = MTYPE_To_TY(MTYPE_I4);
  ST *st = New_ST(GLOBAL_SYMTAB);
  cwh_auxst_clear(st);
  ST_Init(st, Save_Str(symname), CLASS_VAR, SCLASS_DGLOBAL, EXPORT_PREEMPTIBLE,
    int_ty_idx);
  Set_ST_is_initialized(st);
  INITO_IDX inito = New_INITO(st);
  INITV_IDX inv = New_INITV();
  INITV_Init_Integer(inv, MTYPE_I4, value, 1);
  Set_INITO_val(inito, inv);
}
#endif /* KEY Bug 4260 */

/*===============================================
 *
 * cwh_stmt_init_pu
 *
 * Initialize data structures for WHIRL conversion
 * at the start of each PU.
 *
 *===============================================
 */ 

extern void
cwh_stmt_init_pu(ST * st, INT32 lineno)
{
  INT16 nkids,i ;
  ST   **ap     ;

  cwh_stmt_init_srcpos(lineno);
  (void) cwh_block_toggle_debug(FALSE);

  nkids = cwh_auxst_num_dummies(st);
  ap    = cwh_auxst_arglist(st);

  (void) cwh_block_new_and_current() ;

  WN_tree  = WN_CreateEntry (nkids,st,cwh_block_current(), NULL,NULL );

  WN_pragma_pu = WN_kid(WN_tree,nkids);
  WN_pragma_ca = WN_kid(WN_tree,nkids+1);

  for (i = 0 ; i < nkids ; i ++) 
    WN_kid(WN_tree,i) = WN_CreateIdname ( 0, *ap++);

  WN_Set_Linenum (WN_tree, USRCPOS_srcpos(current_srcpos) );
  WN_Set_Linenum (cwh_block_current(), USRCPOS_srcpos(current_srcpos));

  cwh_stmt_add_parallel_pragmas();
#ifdef KEY
  char *compiler_bin = getenv("COMPILER_BIN");
  if (strcmp(ST_name(st), "MAIN__") == 0 &&
      compiler_bin != NULL) {
    size_t str_len = strlen(compiler_bin) + 1;
    // Bug: should not use alloca when passing psc_str out of this function
    // char *psc_str = (char *) alloca(str_len);
    char *psc_str = (char *) malloc(str_len*sizeof(char));
    strcpy(psc_str, compiler_bin);
    // create an array of chars initialized to psc_str
    TY_IDX str_ty_idx;
    TY &str_ty = New_TY(str_ty_idx);
    TY_Init(str_ty, str_len, KIND_ARRAY, MTYPE_M, 0);
    Set_TY_etype(str_ty, MTYPE_To_TY(MTYPE_I1));
    Set_TY_align(str_ty_idx, TY_align(TY_etype(str_ty)));
    ARB_HANDLE arb = New_ARB ();
    ARB_Init (arb, 0, 0, 0);
    Set_TY_arb (str_ty, arb);
    Set_ARB_first_dimen (arb);
    Set_ARB_last_dimen (arb);
    Set_ARB_dimension (arb, 1);
    Set_ARB_const_stride(arb);
    Set_ARB_stride_val(arb, 1);
    Set_ARB_const_lbnd (arb);
    Set_ARB_lbnd_val (arb, 0);
    Set_ARB_const_ubnd (arb);
    Set_ARB_ubnd_val (arb, str_len);
    ST *str_st = New_ST(GLOBAL_SYMTAB);
    // Bug 3713 - (typo) should be clearing auxst for str_st and not st here
    cwh_auxst_clear(str_st);
    ST_Init(str_st, Save_Str("__pathscale_compiler"), CLASS_VAR, SCLASS_DGLOBAL,
    	    EXPORT_PREEMPTIBLE, str_ty_idx);
    Set_ST_is_initialized(str_st);
    INITO_IDX inito = New_INITO(str_st);
    INITV_IDX inv = New_INITV();
    INITV_Init_String(inv, psc_str, str_len);
    Set_INITO_val(inito, inv);
#ifdef KEY /* Bug 4260 */
    /* If command line switch "-byteswap" or "-convert" appeared, export a
     * global data variable of type I*4 to the runtime system to reflect the
     * switch.
     */
    if (IO_DEFAULT != io_byteswap) {
      export_i4_sym("__io_byteswap_value", io_byteswap);
    }
#endif /* KEY Bug 4260 */
#ifdef KEY /* Bug 5089 */
# ifdef TARG_X8664
  /* If -TARG:sse2=off, export a global data variable of type I*4
   * to the runtime system telling it not to attempt to use the MXCSR register
   * in ieee_module_support.c. There exist processors with SSE but not SSE2
   * which do have the MXCSR register, but we're interested in only two
   * cases: SSE2 support or not. */
  if (!(Target_SSE2 || Target_SSE3)) {
    export_i4_sym("__SSE2_off", 1);
    }
# endif /* TARG_X8664 */
#endif /* KEY Bug 5089 */
  }
#endif
}

/*===============================================
 *
 * cwh_stmt_end_pu
 *
 * Return the top of the WN tree and clean up.
 * Setting the pragma blocks to NULL, means
 * additions (from declarations) will be ignored
 * until the next PU is set up.
 *
 *===============================================
 */ 
extern WN *
cwh_stmt_end_pu(void)
{

  WN_pragma_pu = NULL;
  WN_pragma_ca = NULL;

  return(WN_tree) ;
}


/*===============================================
 *
 * cwh_stmt_postprocess_pu
 *
 *===============================================
 */ 
extern void
cwh_stmt_postprocess_pu(void)
{

  if (DEBUG_Conform_Check) {
    cwh_stmt_conformance_checks(WN_tree);
  }

  // if (mp) {
  // cwh_stmt_add_local_pragmas(WN_tree);
  //}
  return;
}


/*===============================================
 *
 * cwh_stmt_init_srcpos
 *
 * Initialize the current line SRCPOS.
 * 
 * The line numbers from the FE occasionally
 * refer to an earlier line (eg: a two part
 * operation like ALLOC/DEALLOC) so ignore
 * the line if < current srcpos. Note that
 * nested procedures are processed first.
 *
 * global_to_local_file returns a pointer into
 * the FE's file table, so can avoid cwh_dst_enter_path
 * if the pointer was the same as last time.
 *
 *===============================================
 */ 
static void
cwh_stmt_init_srcpos(INT32 lineno)
{
  char    *file_name;
  INT32    local_line_num;
  mUINT16  local_file_num;

  static char *last_file_name = NULL;
  static PU *last_pu = NULL;

  if (lineno != 0) {

    file_name = global_to_local_file(lineno);
    local_line_num = global_to_local_line_number(lineno);

    if ((last_file_name != file_name) || 
	(local_line_num > USRCPOS_linenum(current_srcpos)) ||
	(last_pu != &(Get_Current_PU()))) {

      local_file_num = USRCPOS_filenum(current_srcpos) ;

      USRCPOS_clear(current_srcpos);

      if (last_file_name != file_name) 
	USRCPOS_filenum(current_srcpos) = cwh_dst_enter_path(file_name);
      else 
	USRCPOS_filenum(current_srcpos) = local_file_num ;

      USRCPOS_linenum(current_srcpos) = local_line_num;
      Set_Error_Source (file_name );
      Set_Error_Line(local_line_num);
    } 
    last_file_name = file_name ;
    last_pu = &(Get_Current_PU());
  } 
}

//================================================================
//================================================================
//================================================================

/*================================================================
 *  cwh_stmt_insert_conformance_check(WN **s1, WN **s2, INT ndims1, INT ndims2, INT first_axis, 
 *        WN *stmt, WN *block);
 *
 * Do the actual work of inserting the conformance check calls. 
 * 
 * s1, s2 - arrays of size nodes
 * ndims1, ndims2 - number of dimensions to check
 * first_axis - the first axis number to report in the event of a failure. If this is 1, for example
 * the axes will be numbered 1,2,3.... If it's 0, don't report the axis number. 
 * stmt, block - where to put the check. Line number comes from stmt. 
 *
 *================================================================*/

static void 
cwh_stmt_insert_conformance_check(WN **s1, WN **s2, INT ndims1, INT ndims2, INT first_axis, 
				  WN *stmt, WN *block)
{
  INT i;
  WN *eq, *t1,*t2, *gt0, *temp;
  BOOL not_all_const = FALSE;
  BOOL need_gt0_check;
  WN *args[5];
  WN *call;
  WN *if_stmt,*ifthenblock;
  char * proc_name;
#ifdef KEY /* Bug 10177 */
  PREG_NUM r1,r2;
  PREG_NUM rgt0 = 0;
#else /* KEY Bug 10177 */
  PREG_NUM r1,r2,rgt0;
#endif /* KEY Bug 10177 */
  INT64 lineno;

  // quick exit if one or the other ndims is scalar
  if (ndims1 == 0 || ndims2 == 0) return;
  Is_True(ndims1==ndims2,("conformance check rank mismatch."));

  /* Check for all axes non-zero */
  gt0 = WN_Intconst(MTYPE_I4,1);
  for (i=0; i < ndims1; i++) {
    t1 = cwh_convert_to_ty(WN_COPY_Tree(s1[i]),MTYPE_I8);
    t2 = cwh_convert_to_ty(WN_COPY_Tree(s2[i]),MTYPE_I8);
    gt0 = WN_LAND(gt0,WN_LIOR(WN_GT(MTYPE_I8,t1,WN_Zerocon(MTYPE_I8)),
			      WN_GT(MTYPE_I8,t2,WN_Zerocon(MTYPE_I8))));
  }
  
  need_gt0_check = TRUE;
  if (WN_operator(gt0) == OPR_INTCONST) {
     if (WN_const_val(gt0) == 0) {
	/* Zero sized-array, no check needed */
	WN_DELETE_Tree(gt0);
	return;
     } else {
	WN_DELETE_Tree(gt0);
	need_gt0_check = FALSE;
     }
  }

  if (need_gt0_check) {
     rgt0 = Create_Preg(MTYPE_I4,Index_To_Str(Save_Str("ccgt0")));
     WN_INSERT_BlockBefore(block,stmt,WN_StidPreg(MTYPE_I4,rgt0,gt0));
  }
  
  for (i=0; i < ndims1; i++) {
    t1 = cwh_convert_to_ty(WN_COPY_Tree(s1[i]),MTYPE_I8);
    t2 = cwh_convert_to_ty(WN_COPY_Tree(s2[i]),MTYPE_I8);
    eq = WN_EQ(MTYPE_I8,WN_COPY_Tree(t1),WN_COPY_Tree(t2));

    if (WN_operator(eq) != OPR_INTCONST || 
	WN_const_val(eq) == 0) {
      // insert the check
      
      lineno = WN_Get_Linenum(stmt);
      proc_name = cwh_dst_filename_from_filenum(SRCPOS_filenum(lineno));
      //      proc_name = ST_name(Procedure_ST);
      args[0] = cwh_intrin_wrap_value_parm(WN_LdaString(proc_name, 0, strlen(proc_name)));
      args[1] = cwh_intrin_wrap_value_parm(WN_Intconst(MTYPE_I4, SRCPOS_linenum(lineno)));
      if (first_axis != 0) {
	args[2] = cwh_intrin_wrap_value_parm(WN_Intconst(MTYPE_I4,ndims1-1-i+first_axis));
      } else {
	args[2] = cwh_intrin_wrap_value_parm(WN_Intconst(MTYPE_I4,0));
      }

      // Need to stick these in PREGS tp make sure that no array nodes are under the call
      r1 = Create_Preg(MTYPE_I8,Index_To_Str(Save_Str("cc1")));
      r2 = Create_Preg(MTYPE_I8,Index_To_Str(Save_Str("cc2")));
      WN_INSERT_BlockBefore(block,stmt,WN_StidPreg(MTYPE_I8,r1,t1));
      WN_INSERT_BlockBefore(block,stmt,WN_StidPreg(MTYPE_I8,r2,t2));
      args[3] = cwh_intrin_wrap_value_parm(WN_LdidPreg(MTYPE_I8,r1));
      args[4] = cwh_intrin_wrap_value_parm(WN_LdidPreg(MTYPE_I8,r2));
      call = WN_Create_Intrinsic(OPR_INTRINSIC_CALL, MTYPE_V, MTYPE_V,
			INTRN_F90CONFORM_CHECK, 5, args);
      ifthenblock = WN_CreateBlock();
      WN_INSERT_BlockFirst(ifthenblock,call);
      if_stmt = WN_NE(MTYPE_I8,WN_LdidPreg(MTYPE_I8,r1),WN_LdidPreg(MTYPE_I8,r2));
      if (need_gt0_check) {
	 if_stmt = WN_LAND(WN_LdidPreg(MTYPE_I4,rgt0),if_stmt);
      }
      if_stmt = WN_CreateIf(if_stmt,ifthenblock,WN_CreateBlock());
      WN_INSERT_BlockBefore(block,stmt,if_stmt);
    } else {
      WN_DELETE_Tree(t1);
      WN_DELETE_Tree(t2);
    }
    WN_DELETE_Tree(eq);
  }
}
  


/*===============================================
 *
 * cwh_stmt_conformance_checks_walk (WN *tree, WN *stmt, WN *block, WN ** sizes, INT * ndim)
 * 
 * tree - Tree to check
 * stmt, block - The current statement and block before which to put the checks
 * sizes - array of sizes (output) of the current tree. The nodes need not be copied before use.
 * ndim - dimnesionality of tree (output)
 *
 * This walks the tree and adds the conformance check information. 
 *
 *================================================================*/
#define MAX_KIDS 6

static void 
cwh_stmt_conformance_checks_walk (WN *tree, WN *stmt, WN *block, WN ** sizes, INT * ndim)
{
  OPERATOR op;
  WN *node, *nextnode;
  
  WN *ksizes[MAX_KIDS][MAX_ARY_DIMS];
  INT kndims[MAX_KIDS];
  INT i,j,numkids,i_save,numargs;
  INT dim;
  
  op = WN_operator(tree);
  numkids = WN_kid_count(tree);
  if (ndim) *ndim = 0;
  
  if (op == OPR_BLOCK) {
    node = WN_first(tree);
    while (node) {
      nextnode = WN_next(node); /* Because the walk may insert statements */
      cwh_stmt_conformance_checks_walk (node, NULL, tree, NULL, NULL);
      node = nextnode;
    }

  } else if (op == OPR_WHERE) {
    /* should be three kids */
    DevAssert((numkids == 3),("Expected WHERE to have three kids."));

    /* first the mask */
    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), tree, block, NULL, NULL);

    /* second, the assignment block */
    DevAssert((WN_operator(WN_kid(tree,1)) == OPR_BLOCK),("Expected WHERE to have BLOCK kid 1"));

    node = WN_first(WN_kid(tree,1));
    while (node) {
      nextnode = WN_next(node); /* Because the walk may insert statements */
      /* send tree and block as insert points */
      cwh_stmt_conformance_checks_walk (node, tree, block, NULL, NULL);
      node = nextnode;
    }

    /* third, is empty block, right now. Send it anyway */

    DevAssert((WN_operator(WN_kid(tree,2)) == OPR_BLOCK),("Expected WHERE to have BLOCK kid 2"));

    node = WN_first(WN_kid(tree,2));
    while (node) {
      nextnode = WN_next(node); /* Because the walk may insert statements */
      /* send tree and block as insert points */
      cwh_stmt_conformance_checks_walk (node, tree, block, NULL, NULL);
      node = nextnode;
    }

  } else if (op == OPR_ISTORE || op == OPR_MSTORE) {
    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), (stmt?stmt:tree), block, ksizes[0], &kndims[0]);
    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), (stmt?stmt:tree), block, ksizes[1], &kndims[1]);
    cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,(stmt?stmt:tree),block);
    if (sizes) {
      *ndim = kndims[0];
      for (i=0; i < kndims[0]; i++) {
	sizes[i] = ksizes[0][i];
      }
    } else {
      for (i=0; i < kndims[0]; i++) {
	WN_DELETE_Tree(ksizes[0][i]);
      }
    }
    for (i=0; i < kndims[1]; i++) {
      WN_DELETE_Tree(ksizes[1][i]);
    }

  } else if (op == OPR_INTRINSIC_CALL && WN_intrinsic(tree) == INTRN_CASSIGNSTMT) {
    // Character assignment
    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), (stmt?stmt:tree), block, ksizes[0], &kndims[0]);
    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), (stmt?stmt:tree), block, ksizes[1], &kndims[1]);
    cwh_stmt_conformance_checks_walk (WN_kid(tree,2), (stmt?stmt:tree), block, NULL, NULL);
    cwh_stmt_conformance_checks_walk (WN_kid(tree,3), (stmt?stmt:tree), block, NULL, NULL);
    cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,(stmt?stmt:tree),block);
    if (sizes) {
      *ndim = kndims[0];
      for (i=0; i < kndims[0]; i++) {
	sizes[i] = ksizes[0][i];
      }
    } else {
      for (i=0; i < kndims[0]; i++) {
	WN_DELETE_Tree(ksizes[0][i]);
      }
    }
    for (i=0; i < kndims[1]; i++) {
      WN_DELETE_Tree(ksizes[1][i]);
    }

  } else if (op == OPR_INTRINSIC_CALL && WN_intrinsic(tree) == INTRN_CONCATEXPR) {
    // CONCAT
    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), (stmt?stmt:tree), block, ksizes[0], &kndims[0]);
    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), (stmt?stmt:tree), block, NULL, NULL);
    
    numargs = (numkids - 2)/2;
    for (i=0; i < numargs; i++) {
      cwh_stmt_conformance_checks_walk (WN_kid(tree,i+2), (stmt?stmt:tree), block, ksizes[1], &kndims[1]);
      cwh_stmt_conformance_checks_walk (WN_kid(tree,i+2+numargs), (stmt?stmt:tree), block, NULL, NULL);
      cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,(stmt?stmt:tree),block);
      for (j=0; j < kndims[1]; j++) {
	WN_DELETE_Tree(ksizes[1][j]);
      }
    }

    if (sizes) {
      *ndim = kndims[0];
      for (i=0; i < kndims[0]; i++) {
	sizes[i] = ksizes[0][i];
      }
    } else {
      for (i=0; i < kndims[0]; i++) {
	WN_DELETE_Tree(ksizes[0][i]);
      }
    }

  } else if (OPERATOR_is_stmt(op) || OPERATOR_is_scf(op)) {
    for (i=0; i < numkids; i++) {
      cwh_stmt_conformance_checks_walk (WN_kid(tree,i), (stmt?stmt:tree), block, NULL, NULL);
    }

  } else {
    // Expression nodes
    switch (op) {
     case OPR_ARRAYEXP:
     case OPR_ARRSECTION:
     case OPR_ARRAY:
     case OPR_TRIPLET:
       for (i=0; i < numkids; i++) {
	 cwh_stmt_conformance_checks_walk (WN_kid(tree,i), stmt, block, NULL, NULL);
       }
       if (sizes) {
	 F90_Size_Walk(tree,ndim,sizes);
       }
       break;

     default:
       // Make sure all arguments are the same shape
       if (op == OPR_INTRINSIC_OP && F90_Is_Transformational(WN_intrinsic(tree))) {
	 // Special for transformationals
	 switch (WN_intrinsic(tree)) {
	   // No specific checking needed 
	  default:
	  case INTRN_SPREAD:
	  case INTRN_TRANSPOSE:
	  case INTRN_ALL:
	  case INTRN_ANY:
	  case INTRN_COUNT:
	  case INTRN_RESHAPE:  // we don't generate this yet, so we don't need to check it
	    for (i=0; i < numkids; i++) {
	      cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, NULL, NULL);
	    }
	    if (sizes) {
	      F90_Size_Walk(tree,ndim,sizes);
	    }
	    break;

	  case INTRN_MATMUL:
	  case INTRN_DOT_PRODUCT:
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]);
	    if (kndims[0] == 2 && kndims[1] == 2) {
	      cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][1],1,1,0,stmt,block);
	      WN_DELETE_Tree(ksizes[0][0]);
	      WN_DELETE_Tree(ksizes[1][1]);
	      if (sizes) {
		sizes[1] = ksizes[0][1];
		sizes[0] = ksizes[1][0];
		*ndim = 2;
	      }
	    } else if (kndims[0] == 2 && kndims[1] == 1) {
	      cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][0],1,1,0,stmt,block);
	      WN_DELETE_Tree(ksizes[0][0]);
	      WN_DELETE_Tree(ksizes[1][0]);
	      if (sizes) {
		sizes[0] = ksizes[0][1];
		*ndim = 1;
	      }
	    } else if (kndims[0] == 1 && kndims[1] == 2) {
	      cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][1],1,1,0,stmt,block);
	      WN_DELETE_Tree(ksizes[0][0]);
	      WN_DELETE_Tree(ksizes[1][1]);
	      if (sizes) {
		sizes[0] = ksizes[1][0];
		*ndim = 1;
	      }
	    } else {
	      // 1,1 means dot_product
	      cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][0],1,1,1,stmt,block);
	      WN_DELETE_Tree(ksizes[0][0]);
	      WN_DELETE_Tree(ksizes[1][0]);
	    }
	    break;

	  case INTRN_PRODUCT:
	  case INTRN_SUM:
	  case INTRN_MAXVAL:
	  case INTRN_MINVAL:
	  case INTRN_MAXLOC:
	  case INTRN_MINLOC:
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, ksizes[1], &kndims[1]);
	    cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,stmt,block);
	    for (i=0; i < kndims[0]; i++) {
	      WN_DELETE_Tree(ksizes[0][i]);
	    }
	    for (i=0; i < kndims[1]; i++) {
	      WN_DELETE_Tree(ksizes[1][i]);
	    }
	    if (sizes) {
	      F90_Size_Walk(tree,ndim,sizes);
	    }
	    break;

	  case INTRN_CSHIFT:
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]);
	    dim = F90_Get_Dim(WN_kid(tree,2))-1;
	    // check for conformance between the shift argument and the array argument
	    // less the dim dimension
	    if (dim >= 0) {
	      for (i=0,j=0; i < kndims[0]; i++) {
		if (i != kndims[0]-1-dim) {
		  ksizes[2][j] = ksizes[0][i];
		  ++j;
		}
	      }
	      kndims[2] = kndims[0] - 1;
	      cwh_stmt_insert_conformance_check(ksizes[2],ksizes[1],kndims[2],kndims[1],0,stmt,block);
	    }
	    if (sizes) {
	      *ndim = kndims[0];
	      for (i=0; i < kndims[0]; i++) {
		sizes[i] = ksizes[0][i];
	      }
	    } else {
	      for (i=0; i < kndims[0]; i++) {
		WN_DELETE_Tree(ksizes[0][i]);
	      }
	    }
	    for (i=0; i < kndims[1]; i++) {
	      WN_DELETE_Tree(ksizes[1][i]);
	    }
	    break;

	  case INTRN_EOSHIFT:
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, ksizes[2], &kndims[2]);
	    dim = F90_Get_Dim(WN_kid(tree,3))-1;
	    // check for conformance between the shift and boundary arguments and the array argument
	    // less the dim dimension
	    if (dim >= 0) {
	      for (i=0,j=0; i < kndims[0]; i++) {
		if (i != kndims[0]-1-dim) {
		  ksizes[3][j] = ksizes[0][i];
		  ++j;
		}
	      }
	      kndims[3] = kndims[0] - 1;
	      cwh_stmt_insert_conformance_check(ksizes[3],ksizes[1],kndims[3],kndims[1],0,stmt,block);
	      cwh_stmt_insert_conformance_check(ksizes[3],ksizes[2],kndims[3],kndims[2],0,stmt,block);
	    }
	    if (sizes) {
	      *ndim = kndims[0];
	      for (i=0; i < kndims[0]; i++) {
		sizes[i] = ksizes[0][i];
	      }
	    } else {
	      for (i=0; i < kndims[0]; i++) {
		WN_DELETE_Tree(ksizes[0][i]);
	      }
	    }
	    for (i=0; i < kndims[1]; i++) {
	      WN_DELETE_Tree(ksizes[1][i]);
	    }
	    for (i=0; i < kndims[2]; i++) {
	      WN_DELETE_Tree(ksizes[2][i]);
	    }
	    break;

	  case INTRN_PACK:
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, sizes, ndim);
	    cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,stmt,block);
	    for (i=0; i < kndims[0]; i++) {
	      WN_DELETE_Tree(ksizes[0][i]);
	    }
	    for (i=0; i < kndims[1]; i++) {
	      WN_DELETE_Tree(ksizes[1][i]);
	    }
	    break;

	  case INTRN_UNPACK:
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, NULL, NULL);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[0], &kndims[0]);
	    cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, ksizes[1], &kndims[1]);
	    cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,stmt,block);
	    // copy sizes and cleanup
	    if (sizes) {
	      *ndim = kndims[0];
	      for (i=0; i < kndims[0]; i++) {
		sizes[i] = ksizes[0][i];
	      }
	    } else {
	      for (i=0; i < kndims[0]; i++) {
		WN_DELETE_Tree(ksizes[0][i]);
	      }
	    }
	    for (i=0; i < kndims[1]; i++) {
	      WN_DELETE_Tree(ksizes[1][i]);
	    }
	    break;
	    
	 } // intrinsics switch

	 break;
       } // Transformational intrinsics
       
       if (numkids == 0) {
	 break;
       } 
       if (numkids == 1) {
	 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, sizes, ndim);
	 break;
       }
       
       // More than one kid
       if (numkids > MAX_KIDS) break;
       for (i=0; i < numkids; i++) {
	 cwh_stmt_conformance_checks_walk (WN_kid(tree,i), stmt, block,
					   ksizes[i], &kndims[i]);
       }
       for (i=0; i < numkids; i++) {
	 for (j = i+1; j < numkids; j++) {
	   cwh_stmt_insert_conformance_check(ksizes[i],ksizes[j],kndims[i],kndims[j],1,stmt,block);
	 }
       }
       
       /* Figure out which ones to save */
       i_save = -1;
       if (sizes) {
	 for (i=0; i < numkids; i++) {
	   if (kndims[i] > *ndim) {
	     i_save = i;
	     *ndim = kndims[i]; 
	     for (j = 0; j < kndims[i]; j++) {
	       sizes[j] = ksizes[i][j];
	     }
	   }
	 }
       }
       
       /* Clean up the rest */
       for (i=0; i < numkids; i++) {
	 if (i_save != i) {
	   for (j = 0; j < kndims[i]; j++) {
	     WN_DELETE_Tree(ksizes[i][j]);
	   }
	 }
       }
       break;
    } // expressions switch
  } // expressions
  return;
}


/*===============================================
 *
 * cwh_stmt_conformance_checks (WN *tree)
 *
 * Adds the conformance checks for array operations to the tree. This 
 * is normally added only with bounds checking
 *
 *================================================================*/

static void 
cwh_stmt_conformance_checks(WN *tree)
{
  cwh_stmt_conformance_checks_walk(tree,NULL,NULL,NULL,NULL);
}
