/*
 * Copyright (C) 2008, 2009. 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_io.c
 * $Revision: 1.6 $
 * $Date: 05/11/10 13:51:51-08:00 $
 * $Author: scorrell@soapstone.internal.keyresearch.com $
 * $Source: crayf90/sgi/SCCS/s.cwh_io.cxx $
 *
 * Revision history:
 *  dd-mmm-95 - Original Version
 *
 * Description: Contains routines to convert IO statements. Entry points from
		the PDGCS layer are:
		fei_*_read, fei_*_write, fei_control_list, fei_IO_list,
		fei_implied_do and fei_iolength.
 *
 * ====================================================================
 * ====================================================================
 */

static const char *source_file = __FILE__;

#ifdef _KEEP_RCS_ID
  static char *rcs_id = " $Id: cwh_io.cxx 1.6 05/11/10 13:51:51-08:00 scorrell@soapstone.internal.keyresearch.com $ ";
#endif /* _KEEP_RCS_ID */

/* sgi includes */

#include "defs.h"
#include "glob.h"
#include "stab.h"
#include "strtab.h"
#include "errors.h"
#include "config.h"
#include "config_targ.h"
#include "wn.h"
#include "const.h"
#include "wio.h"
#include "ir_reader.h"
#include "wn_util.h"
#include "targ_const.h"
#include "targ_sim.h"

/* Cray includes */

#include "i_cvrt.h"


/* conversion includes */

#include "cwh_defines.h"
#include "cwh_addr.h"
#include "cwh_dope.h"
#include "cwh_stk.h"
#include "cwh_types.h"
#include "cwh_expr.h"
#include "cwh_block.h"
#include "sgi_cmd_line.h"
#include "cwh_preg.h"
#include "cwh_stab.h"
#include "cwh_auxst.h"

#include "cwh_io.i"
#include "cwh_io.h"

#define STACK_PUSH(x) \
if (x != NULL) \
  cwh_stk_push(x, WN_item);

#define IoItem_TY(wn) (WN_kid(wn,3))
#ifndef NIL
#define NIL 0
#endif

static INT32 num_list_items_last_processed;

typedef enum {
  CILIST_EDFLAG = 0,
  CILIST_EEEFLAG = 1,
  CILIST_FLFLAG = 2,
  CILIST_UNIT = 3,
  CILIST_IOSTAT = 4,
  CILIST_REC = 5,
  CILIST_PARSFMT = 6,
  CILIST_FMTSRC = 7,
  CILIST_ADVANCE = 8,
  CILIST_SIZE = 9,
  CILIST_ERR = 10,
  CILIST_END = 11,
  CILIST_EOR = 12
} CILIST_TABLE_ITEM;

typedef enum {
  OPEN_CALLNAME = 0,
  OPEN_VERSION = 1,
  OPEN_UNIT = 2,
  OPEN_IOSTAT = 3,
  OPEN_ERRFLAG = 4,
  OPEN_FILE = 5,
  OPEN_STATUS = 6,
  OPEN_ACCESS = 7,
  OPEN_FORM = 8,
  OPEN_RECL = 9,
  OPEN_BLANK = 10,
  OPEN_POSITION = 11,
  OPEN_ACTION = 12,
  OPEN_DELIM = 13,
  OPEN_PAD = 14,
  OPEN_ERR = 15
} OPEN_TABLE_ITEM;

typedef enum {
  CLOSE_CALLNAME = 0,
  CLOSE_VERSION = 1,
  CLOSE_UNIT = 2,
  CLOSE_IOSTAT = 3,
  CLOSE_ERRFLAG = 4,
  CLOSE_STATUS = 5,
  CLOSE_ERR = 6
} CLOSE_TABLE_ITEM;

typedef enum {
  INQ_CALLNAME = 0,
  INQ_VERSION = 1,
  INQ_UNIT = 2,
  INQ_FILE = 3,
  INQ_IOSTAT = 4,
  INQ_ERRFLAG = 5,
  INQ_EXIST = 6,
  INQ_OPENED = 7,
  INQ_NUMBER = 8,
  INQ_NAMED = 9,
  INQ_NAME = 10,
  INQ_ACCESS = 11,
  INQ_SEQUENTIAL = 12,
  INQ_DIRECT = 13,
  INQ_FORM = 14,
  INQ_FORMATTED = 15,
  INQ_UNFORMATTED = 16,
  INQ_RECL =17,
  INQ_NEXTREC = 18,
  INQ_BLANK = 19,
  INQ_POSITION = 20,
  INQ_ACTION = 21,
  INQ_READ = 22,
  INQ_WRITE = 23,
  INQ_READWRITE = 24,
  INQ_DELIM = 25,
  INQ_PAD = 26,
  INQ_ERR = 27
} INQ_TABLE_ITEM;

typedef enum {
  BIO_CALLNAME = 0,
  BIO_VERSION = 1,
  BIO_UNIT = 2,
  BIO_RECMODE = 3,
  BIO_BLOC = 4,
  BIO_ELOC = 5,
  BIO_TIPTR = 6
} BIO_TABLE_ITEM;

/* Rewind, backspace and endfile do not require the io descriptor setup
   and use the following enum */

typedef enum {
  NODESC_CALLNAME = 0,
  NODESC_UNIT = 1,
  NODESC_IOSTAT = 2,
  NODESC_ERRFLAG = 3,
  NODESC_ERR = 4
} NODESC_TABLE_ITEM;

#define WRITE_STMT 0
#define READ_STMT 1
#define NML_MASK 2
#define READ_WRITE_MASK 1
#define NAMELIST_MODE(x) ((x) & NML_MASK)
#define READ_MODE(x) ((x) & READ_WRITE_MASK)
#define WRITE_MODE(x) (!((x) & READ_WRITE_MASK))

static WN * cwh_io_ioitem(int mode, WN *craytype);
static WN * cwh_io_str_ioitem(IOITEM it, int mode, WN *craytype);
static WN * cwh_io_char_ioitem(IOITEM it, WN *len, int mode, WN *craytype);   

static INT32 eeeflag;
static MARKED_SET *marked_set;

static TY_IDX  
cwh_io_scalar_type(WN *wn) {
  TY_IDX ty = NIL;

  if (wn) {
    ty = cwh_types_WN_TY(wn,FALSE);
    ty = cwh_types_array_TY(ty);
    ty = cwh_types_scalar_TY(ty);
  } 
  return ty;
}

/*===============================================
 *
 * fei_control_list
 *
 * Create IO item nodes from the list items already pushed on the
 * stack. 
 * Ten list items are assumed to have already been pushed onto the stack
 * with #10 at the top of the stack.
 *   1. Encode/Decode Flag
 *   2. eeeflag value
 *         1 if ERR=specified
 *         2 if END=specified
 *         4 if EOR=specified
 *         8 if IOSTAT=specified
 *   3. flflag value -- indicates information on first/last flag
 *   4. Unit Specifier
 *   5. IOSTAT variable
 *   6. REC variable
 *   7. Preparsed format variable
 *   8. format source variable
 *   9. ADVANCE variable
 *  10. SIZE variable
 *===============================================
 */

extern void 
fei_control_list(int mode)
{
  INT item;
  WN *wn_eeeflag = NULL;
  WN *wn_unit = NULL;
  WN *wn_iostat = NULL;
  WN *wn_rec = NULL;
  WN *wn_parsfmt = NULL;
  WN *wn_fmtsrc = NULL;
  WN *wn_advance = NULL;
  WN *wn_size = NULL;
  WN *wn_flflag = NULL;
  WN *wn_edflag = NULL;
  WN *wn_end = NULL;
  WN *wn_err = NULL;
  WN *wn_eor = NULL;
  WN *wn1;
  WN *wn2;
  WN *unit_address = NULL;
  WN *ed_unit = NULL;  /* unit for encode decode */
  ST *st;
  TY_IDX ts = NIL;
  TY_IDX td = NIL;
  TY_IDX ty = NIL;
  WN *se;
  INT32 edflag = 0;

  eeeflag = 0;
  for (item=CILIST_EOR; item >= CILIST_EDFLAG ; item--) {

      switch (item) {

        case CILIST_SIZE:
	  ts = cwh_stk_get_TY();
	  wn1 = cwh_expr_address(f_NONE);

          if (wn1) { 
	    if (ts != NIL) {
	       ty = cwh_types_array_TY(ts);
	       ty = cwh_types_scalar_TY(ty);
            } else {
	       ty = cwh_io_scalar_type(wn1);
            }
            wn_size = WN_CreateIoItem1 ( IOC_SIZE, wn1, ty );   
          }
	  break;

        case CILIST_ADVANCE:
	  if (cwh_stk_get_class() == STR_item) {
	     cwh_stk_pop_STR();
	     wn2 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
	     wn1 = cwh_expr_address(f_NONE);
	     wn_advance  = WN_CreateIoItem2 (IOC_ADVANCE, wn1, wn2, NIL);
          } else {
	     /* Assume there was a null wn for a place holder; just pop it */
	     wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
          }
	  break;

        case CILIST_FMTSRC:
	   if (target_io_library == IOLIB_MIPS) {
	     wn1 = cwh_expr_address(f_NONE);
	     if (wn1 == NULL)
	       wn_fmtsrc = WN_CreateIoItem0 ( IOF_LIST_DIRECTED, NIL );
             else
	       DevWarn(("Only List directed I/O supported now"));
           } else { /* Library = CRAY */
	     switch(cwh_stk_get_class()) {

             case STR_item :

                cwh_stk_pop_STR();
                wn2 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		ts  = cwh_stk_get_TY();
		wn1 = cwh_expr_address(f_NONE);
		se = cwh_addr_find_section(wn1, p_RETURN_SECTION);
		if (se) {
		   ty = cwh_types_array_TY(ts);
		   wn1 = cwh_dope_from_expression(wn1, NULL, wn2, ts, NULL );
		   ty  = cwh_types_scalar_TY(ty);
  		   wn_fmtsrc = WN_CreateIoItem2 (IOF_CR_FMTSRC_DOPE, wn1, 
		                 cwh_addr_find_address(se), ty);
                } else {
		  wn_fmtsrc = WN_CreateIoItem2 (IOF_CR_FMTSRC, wn1, wn2, NIL);
                }
                break ;

	     case ST_item :
	     case ST_item_whole_array:

		if (NAMELIST_MODE(mode)) {

		   ST *namelist_group;
		   ITEM* element;
		   NLIST *dummy, *nmlist;
		   INT32 count, i;

		   element = NULL;
		   namelist_group = cwh_stk_pop_ST();
		   wn1 = cwh_addr_address_ST(namelist_group, 0);
		   dummy = (NLIST *) malloc(sizeof (NLIST)) ;
		   Nlist_wn(dummy) = wn1;
		   Nlist_next(dummy) = NULL;
		   nmlist = dummy;
		   count = 1;
		   while ((element = cwh_auxst_next_element(
			    namelist_group,element,l_NAMELIST)) != NULL ) {
                      wn1 = cwh_addr_address_ST(I_element(element), 0 );  
		      dummy = (NLIST *) malloc(sizeof (NLIST)) ;
		      Nlist_wn(dummy) = wn1;
		      Nlist_next(dummy) = nmlist;
		      nmlist = dummy;
		      count++;
                   }
                   wn_fmtsrc = WN_CreateIoItemN(IOF_NAMELIST_DIRECTED, 
							count, NIL);
		   for(i=0; i<count; i++) {
		      WN_kid(wn_fmtsrc, i) = Nlist_wn(nmlist);
		      nmlist = Nlist_next(nmlist);
                   }
		   free (dummy);

               } else {

		  st = cwh_stk_pop_ST();
		  cwh_stk_push(st, ST_item);
		  ty = ST_type(st);

		  /* For ASSIGN 0012 TO I
                         WRITE (*,I) 
                     Cray FE puts the address of the format in I, and we 
                     need to use cwh_expr_operand to load I to get to the
                     address of the format. 
                     For write(*,100) i
                     100 format(I4)
                     the Cray FE provides a TEMP of KIND_ARRAY that holds the
                     format. For this we need to use cwh_expr_address.
                  */

                  if (TY_kind(ty) == KIND_ARRAY)
                    wn1 = cwh_expr_address(f_NONE);
                  else
                    wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
                  wn_fmtsrc = WN_CreateIoItem1 ( IOF_CR_FMTSRC, wn1, NIL );
                }
		break;

             default:
		 if (cwh_stk_get_class() == FLD_item) {
		    td = cwh_stk_get_FLD_TY();
                 }

		 wn1 = cwh_expr_address(f_NONE);
		 se = cwh_addr_find_section(wn1, p_RETURN_SECTION);
		 if (se) {
		     if (td != NIL) {
			ty = cwh_types_array_TY(td);
			ty = cwh_types_scalar_TY(ty);
                     } else {
		        ts = cwh_types_WN_TY(se,FALSE);
                        ts = cwh_types_array_TY(ts);
                        ty = cwh_types_scalar_TY(ts);
                     }
		     wn1 = cwh_dope_from_expression(wn1, NULL, NULL, ty,
		     NULL);
  		     wn_fmtsrc = WN_CreateIoItem2 (IOF_CR_FMTSRC_DOPE, wn1, 
				     cwh_addr_find_address(se), ty);
                 } else { 
		    if (wn1 != NULL)
		       wn_fmtsrc = WN_CreateIoItem1 (IOF_CR_FMTSRC, wn1, NIL);
                    else
		       wn_fmtsrc = WN_CreateIoItem0 ( IOF_NONE, NIL );
                 }
		 break;

             }
           }
           break;

        case CILIST_PARSFMT:
	  /* Preparsed format variable */
	  wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
          if (wn1)
            wn_parsfmt = WN_CreateIoItem1 ( IOF_CR_PARSFMT, wn1, NIL );
	  break;

        case CILIST_REC:
	  wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
          if (wn1)
	    wn_rec  = WN_CreateIoItem1 ( IOC_REC, wn1, NIL );
	  break;

        case CILIST_IOSTAT:
#ifdef KEY /* Bug 4716, 7874 */
	  switch (cwh_stk_get_class()) {
	    case FLD_item:
	      ts = cwh_stk_get_FLD_TY();
	      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])));
	      }
	      break;
	    default:
	      ts = cwh_stk_get_TY();
	      break;
	  }
#else /* KEY Bug 4716, 7874 */
          ts = cwh_stk_get_TY();
#endif /* KEY Bug 4716, 7874 */
	  wn1 = cwh_expr_address(f_NONE);
	  if (wn1) {
            if (ts != NIL) {
               ty = cwh_types_array_TY(ts);
               ty = cwh_types_scalar_TY(ty);
            } else {
               ty = cwh_io_scalar_type(wn1);
            }
	    wn_iostat = WN_CreateIoItem1 ( IOC_IOSTAT, wn1, ty );
          }
	  break;
	case CILIST_END:
	case CILIST_ERR:
	case CILIST_EOR:

	  /* if label, mark assigned so not removed by optimizer */
          wn1 = cwh_io_cvt_tos_label_to_wn(TRUE);
	  if (wn1) {
            if (item == CILIST_END)
	      wn_end = WN_CreateIoItem1 ( IOC_END, wn1, NIL );
            else if (item == CILIST_ERR)
	      wn_err = WN_CreateIoItem1 ( IOC_ERR, wn1, NIL );
            else if (item == CILIST_EOR)
	      wn_eor = WN_CreateIoItem1 ( IOC_EOR, wn1, NIL );
          }
	  break;

        case CILIST_UNIT:
	  switch(cwh_stk_get_class()) {
	  case STR_item:

             cwh_stk_pop_STR();
             wn2 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
	     ts  = cwh_stk_get_TY();
             wn1 = cwh_expr_address(f_NONE);
             se = cwh_addr_find_section(wn1, p_RETURN_SECTION);
	     if (se) {
	       wn1 = cwh_dope_from_expression(wn1, NULL, wn2, ts, NULL);
	       wn_unit = WN_CreateIoItem2(IOU_DOPE, wn1, 
				      cwh_addr_find_address(se), NIL);
             } else {
  	       wn_unit  = WN_CreateIoItem2 (IOU_INTERNAL, wn1, wn2, NIL);
             }
             break ;

          default:

             /* Push the top item again on the stack and extract it thru 
                cwh_expr_address. We save the resultant item, in case we
                need to use it later, if we happen to be in an encode/decode
                statement */
  
             cwh_stk_push_top_item_again();
             unit_address = cwh_expr_address(f_NONE);

             wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
	     if (target_io_library == IOLIB_MIPS) {
		if (wn1 == NULL) {
		  wn1 = WN_CreateIntconst ( OPC_I4INTCONST, 6);
		  wn_unit  = WN_CreateIoItem1 ( IOU_DEFAULT, wn1, NIL );
                } else {
		  /* Only handle external IO for now */
		  wn_unit  = WN_CreateIoItem1 ( IOU_EXTERNAL, wn1, NIL);
                }
              } else {   /* Target library is Cray */
		if (wn1 != NULL) {

		   /* DIMENSION IREC(2) 
		    * ENCODE(8,100,IREC) LREC(K),ICNT,ITAU
		    * 
		    * The above can cause the code to reach here, with wn1
		      as an ARRSECTION
		    */

                   se = cwh_addr_find_section(wn1, p_RETURN_SECTION);
		   if (se) {
		      ts = cwh_types_WN_TY(se,FALSE);
		      ts = cwh_types_array_TY(ts);
		      ty = cwh_types_scalar_TY(ts);
		      wn1 = cwh_dope_from_expression(wn1, NULL, NULL, ty,
		      NULL);
		      wn_unit = WN_CreateIoItem2(IOU_DOPE, wn1, 
				    cwh_addr_find_address(se), NIL);
                   } else {
		      wn_unit = WN_CreateIoItem1 ( IOU_EXTERNAL, wn1, NIL );
                      ed_unit = WN_CreateIoItem1 ( IOU_EXTERNAL, unit_address, NIL);
                   }
                } else {
		   wn_unit = WN_CreateIoItem0 ( IOU_NONE, NIL );
                }
              }
	      break;

          }
          break;

        case CILIST_FLFLAG:
	  wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
	  if (target_io_library == IOLIB_CRAY)
	    wn_flflag = WN_CreateIoItem1 ( IOC_CR_FLFLAG, wn1, NIL);
	  break;
	  
        case CILIST_EEEFLAG:
	  /* eeeflag value; 1 if err= specified, 2 if end= specified,
                            4 if eor= specified, 8 if iostat= specified 
          */
	  wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
	  eeeflag = WN_const_val(wn1);
	  if (target_io_library == IOLIB_CRAY)
	    wn_eeeflag = WN_CreateIoItem1 ( IOC_CR_EEEFLAG, wn1, NIL );  
	  break;

        case CILIST_EDFLAG:
	  /* Version Number */
	  wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
          edflag = WN_const_val(wn1);
	  wn_edflag = WN_CreateIoItem1(IOC_CR_EDFLAG, wn1, NIL);
	  /* Ignore */
	  break;

       } /* Switch */
   } /* for */

   if (edflag != 0 && ed_unit) {
      wn_unit  = WN_CreateIoItem2 (IOU_INTERNAL, WN_kid0(ed_unit), WN_kid0(wn_edflag), NIL);
      STACK_PUSH(wn_unit);
   } else {
      STACK_PUSH(wn_unit);
   }
   STACK_PUSH(wn_fmtsrc);
   STACK_PUSH(wn_flflag);
   STACK_PUSH(wn_parsfmt);
   STACK_PUSH(wn_eeeflag);
   STACK_PUSH(wn_iostat);
   STACK_PUSH(wn_rec);
   STACK_PUSH(wn_advance);
   STACK_PUSH(wn_size);
   STACK_PUSH(wn_edflag);
   STACK_PUSH(wn_end);
   STACK_PUSH(wn_err);
   STACK_PUSH(wn_eor);
} 

/*===================================================
 *
 * fei_IO_list
 *
 * Process the iolist items on the stack. For scalars
 * just load the value or pass the expression along
 * wrapped as an IO_item. For array sections a dope
 * vector supplants the OPC_ARRSECTION on the stack.
 * 
 *====================================================
*/
extern void 
fei_IO_list (int num_args, int mode )
{
  int i;
  WN *wn;
  WN **iolist;
  WN *cray_type_code = NULL;

  iolist = (WN **) malloc(sizeof (WN *) * num_args);
  
  for (i=0; i < num_args; i++) {
    
    if (!NAMELIST_MODE(mode)) {
       cray_type_code = cwh_expr_operand(DELETE_ARRAYEXP_WN);
   
       /* Implied do's that have already been processed by fei_implied_do don't
          have a type code over them; in this case, we need to push the 
          item back on the stack, because it is not a cray type code, and 
          continue with further processing */
   
       if ((WN_opcode(cray_type_code) == OPC_IO_ITEM) && 
          (WN_io_item(cray_type_code) == IOL_IMPLIED_DO))
          cwh_stk_push(cray_type_code,WN_item);
    }

    switch(cwh_stk_get_class()) {
    case STR_item :
      wn = cwh_io_str_ioitem(IOL_CHAR, mode, cray_type_code);
      break ;

    default:
      wn = cwh_io_ioitem(mode, cray_type_code);
      break;

    }
    iolist[i] = wn;
  }
  
  for (i=num_args-1; i >= 0; i--) {
    cwh_stk_push(iolist[i], WN_item);
  }
  
  num_list_items_last_processed = num_args;
  
  free(iolist);
}

/*===================================================
 *
 * fei_formatted_write
 *
 * Pops all the control items and the list items from 
 * stack and makes them kids of a IOS_CR_FWF node.
 *
 *====================================================
*/
  
extern void
fei_formatted_write( void ) 
{
  WN *wn;
  BOOL status;

  if (target_io_library == IOLIB_MIPS) 
    wn = cwh_stk_pop_iostmt (IOS_WRITE, eeeflag);
  else 
    wn = cwh_stk_pop_iostmt (IOS_CR_FWF, eeeflag);

  if (Use_Three_Call) {
     cwh_io_split_io_statement(wn);
  } else {
    marked_set = NULL;
    status = cwh_io_analyse_io_statement(wn, WRITE_STMT);
    cwh_io_unmark();
  
    if (status) {
       cwh_io_split_io_statement(wn);
    } else {
       cwh_io_create_dopes(wn);
       cwh_block_append(wn);
    }
  }
}

/*===================================================
 *
 * fei_formatted_read
 *
 * Pops all the control items and the list items from
 * stack and makes them kids of a IOS_CR_FRF node.
 *
 *====================================================
*/

extern void
fei_formatted_read(void) 
{
  WN *wn;
  BOOL status;

  wn = cwh_stk_pop_iostmt (IOS_CR_FRF, eeeflag);

  if (Use_Three_Call) {
     cwh_io_split_io_statement(wn);
  } else {
    marked_set = NULL;
    status = cwh_io_analyse_io_statement(wn, READ_STMT);
    cwh_io_unmark();
  
    if (status) {
       cwh_io_split_io_statement(wn);
    } else {
       cwh_io_create_dopes(wn);
       cwh_block_append(wn);
    }
  }
}

/*===================================================
 *
 * fei_unformatted_write
 *
 * Pops all the control items and the list items from
 * stack and makes them kids of a IOS_CR_FWU node.
 *
 *====================================================
*/

extern void
fei_unformatted_write(void) 
{
  WN *wn;
  BOOL status;

  wn = cwh_stk_pop_iostmt (IOS_CR_FWU, eeeflag);

  if (Use_Three_Call) {
     cwh_io_split_io_statement(wn);
  } else {
    marked_set = NULL;
    status = cwh_io_analyse_io_statement(wn, WRITE_STMT);
    cwh_io_unmark();
  
    if (status) {
       cwh_io_split_io_statement(wn);
    } else {
       cwh_io_create_dopes(wn);
       cwh_block_append(wn);
    }
  }
}

/*===================================================
 *
 * fei_unformatted_read
 *
 * Pops all the control items and the list items from
 * stack and makes them kids of a IOS_CR_FRU node.
 *
 *====================================================
*/

extern void
fei_unformatted_read(void)
{
  WN *wn;
  BOOL status;

  wn = cwh_stk_pop_iostmt (IOS_CR_FRU, eeeflag);

  if (Use_Three_Call) {
     cwh_io_split_io_statement(wn);
  } else {
    marked_set = NULL;
    status = cwh_io_analyse_io_statement(wn, READ_STMT);
    cwh_io_unmark();
  
    if (status) {
       cwh_io_split_io_statement(wn);
    } else {
       cwh_io_create_dopes(wn);
       cwh_block_append(wn);
    }
  }
}

/*===================================================
 *
 * fei_namelist_write
 *
 * Pops all the control items and the list items from
 * stack and makes them kids of a IOS_CR_FWN node.
 *
 *====================================================
*/

extern void
fei_namelist_write(void)
{
  WN *wn;

  wn = cwh_stk_pop_iostmt (IOS_CR_FWN, eeeflag);
  cwh_block_append(wn);
}

/*===================================================
 *
 * fei_namelist_read
 *
 * Pops all the control items and the list items from
 * stack and makes them kids of a IOS_CR_FRN node.
 *
 *====================================================
*/

extern void
fei_namelist_read(void)
{
  WN *wn;

  wn = cwh_stk_pop_iostmt (IOS_CR_FRN, eeeflag);
  cwh_block_append(wn);
}

/*===================================================
 *
 * fei_implied_do
 *
 * The following are already on the stack: implied_do_var,
 * start expr, end expr, incr expr, and the list of items 
 * to iterate over. It builds an entry for implied do
 * out of it. If any of the list items happen to be an
 * array element, a dope vector is created out of it, if
 * the implied_do_var happens to be part of the array index.
 *
 *====================================================
*/

extern void
fei_implied_do(void)
{
 WN **iolist;
 WN *incr;
 WN *stop;
 WN *start;
 WN *index;
 WN *wn;
 ST *st;
 INT32 num_list_items;
 INT32 i, j;

 num_list_items = num_list_items_last_processed;
 iolist = (WN **) malloc(sizeof (WN *) * num_list_items);

 for (i = 0; i < num_list_items; i++) 
   iolist[i] = cwh_expr_operand(DELETE_ARRAYEXP_WN);

 incr = cwh_expr_operand(DELETE_ARRAYEXP_WN);
 stop = cwh_expr_operand(DELETE_ARRAYEXP_WN);
 start = cwh_expr_operand(DELETE_ARRAYEXP_WN);
 st = cwh_stk_pop_ST();
 index = WN_CreateIdname(0, st);

 wn = WN_CreateIoItemN ( IOL_IMPLIED_DO, num_list_items + 4, NIL);
 WN_index(wn) = index;
 WN_start(wn) = start;
 WN_end(wn) = stop;
 WN_step(wn) = incr;

 for(i = num_list_items-1, j = 4; i >= 0 ; i--, j++) {
   WN_kid(wn,j) = iolist[i];
 }

 cwh_stk_push(wn, WN_item);
 free (iolist);
}

/*===================================================
 *
 * cwh_io_ioitem
 *
 * A utility routine for non-character scalar 
 * io items. Load the value TOS & return it as 
 * WN IO_item. 
 *
 * The only way to distinguish a logical constant
 * from an integer is to look a the TY that's pushed
 * on the stack (by fei_constant).

 * First pop the type code
 * 
 *====================================================
*/
static WN *
cwh_io_ioitem(int mode, WN *cray_type_code)
{
  WN * wn ;
  WN * wr ;
  TY_IDX  ty ;
  TY_IDX  ts = NIL ;
  TY_IDX cray_ptr_ty = NIL;
   
  if (cwh_stk_get_class() == FLD_item) {
     ts = cwh_stk_get_FLD_TY();
  } else if (cwh_stk_get_class() == 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])));
     }
  } else if ((cwh_stk_get_class() == ADDR_item) && !NAMELIST_MODE(mode)){
     ts = Be_Type_Tbl(Pointer_type);
     if (READ_MODE(mode))
       DevAssert((0),("Received an ADDR item in read mode"));
  } else if (cwh_stk_get_class() == ST_item) {
     ST *st;

     st = cwh_stk_pop_ST();

     if (ST_sclass(st) == SCLASS_FORMAL) {
	if ( !ST_is_value_parm(st) &&
		(TY_kind(TY_pointed(ST_type(st))) == KIND_POINTER)) {
	   /* This is a cray pointer */
	   DevAssert((!ST_is_temp_var(st)), ("Expecting a Cray Pointer"));
	   cray_ptr_ty = ST_type(st);
        } 
     } else if (TY_kind(ST_type(st)) == KIND_POINTER) {
	/* This is a cray pointer */
	DevAssert((!ST_is_temp_var(st)), ("Expecting a Cray Pointer"));
	cray_ptr_ty = ST_type(st);
     }
     cwh_stk_push(st,ST_item);
	   
  } else {
     ts = cwh_stk_get_TY();
  }

  if (NAMELIST_MODE(mode) || READ_MODE(mode)) {
     wn = cwh_expr_address(f_NONE);
  } else {
     wn = cwh_expr_operand(DELETE_ARRAYEXP_WN);
  }

  if (cray_ptr_ty != NIL) {
     ty = cray_ptr_ty;
  } else if (ts != NIL) {
     ty = cwh_types_array_TY(ts);
     ty = cwh_types_scalar_TY(ty);
  } else {
    ty = cwh_types_WN_TY(wn,FALSE);
    ty = cwh_types_array_TY(ty);
    ty = cwh_types_scalar_TY(ty);
  }

  if (cwh_addr_find_section(wn, p_RETURN_SECTION)) {
      wn = WN_CreateIoItem3 (IOL_DOPE, wn, cray_type_code, NULL, ty);
      return wn;
  }

  if ((WN_opcode(wn) == OPC_IO_ITEM) && (WN_io_item(wn) == IOL_IMPLIED_DO))
    return wn;

 
  if (NAMELIST_MODE(mode)) {
       wr = WN_CreateIoItem1 ( IOL_VAR, wn, ty);
  } else if (READ_MODE(mode)) {
       wr = WN_CreateIoItem2 ( IOL_VAR, wn, cray_type_code, ty);
  } else {
       wr = WN_CreateIoItem2 ( IOL_EXPR, wn, cray_type_code, ty);
  }
  return (wr);
}

/*===================================================
 *
 * cwh_io_str_ioitem
 *
 * A utility routine for character scalar 
 * io items. Load the value TOS & return it as 
 * WN IO_item. If it's an array section, it needs
 * a dope vector, otherwise it's just a 2 element item
 * 
 *====================================================
*/
static WN *
cwh_io_str_ioitem(IOITEM it, int mode, WN *craytype)
{
  WN * wn2 ;
  WN * wn  ;

  cwh_stk_pop_STR();

  wn2 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
  wn = cwh_io_char_ioitem(it,wn2, mode, craytype);

  return(wn);
}
/*===================================================
 *
 * cwh_io_char_ioitem
 *
 * create an item of the given kind with the address 
 * of the string on TOS and its length passed.
 * 
 *====================================================
*/
static WN *
cwh_io_char_ioitem(IOITEM it, WN *len, int mode, WN *craytype)
{
  WN * wn ;
  TY_IDX  ty ;

  ty = cwh_stk_get_TY();

  wn = cwh_expr_address(f_NONE);

  if (cwh_addr_find_section(wn, p_RETURN_SECTION)) {
      wn = WN_CreateIoItem3 (IOL_DOPE, wn, craytype, len, ty );
      return wn;
  }

  wn = WN_CreateIoItem3 (it, wn, craytype, len, ty); 

  return (wn);
}

/*===================================================
 *
 * fei_iolength
 *
 * Handles inquire(iolength=len) <iolist>
 * 
 * The iolist is assumed to have gone through an fei_IO_list
 * interface. Also on the stack is a constant which represents
 * the first last flag.
 *
 *====================================================
*/

extern void
fei_iolength(void)
{
  INT32 num_items;
  INT32 i, j;
  WN *item;
  WN *wn;
  WN *wn1;
  ST *st;
  WN *temp;
  BOOL status;

  num_items = cwh_stk_get_num_inquire_items();
  wn = WN_CreateIo ( IOS_INQLENGTH, num_items + 4);

  /* Kids 1 and 2 are passed because for every IO sttaement
     the IO lowerer expects that the first kid is a UNIT,
     and the second a format; it just satisfies this requirement
     of the io lowerer and then ignored.
   */

  WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL );
  WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL );
  for (i=0, j = 4+num_items-1; i<num_items; i++, j--) {
     item = cwh_expr_operand(DELETE_ARRAYEXP_WN);
     WN_kid(wn,j) = item;
  }    
  wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN);
  WN_kid(wn,2) = WN_CreateIoItem1 ( IOC_CR_FLFLAG, wn1, NIL);
  
  st = cwh_stk_pop_ST();
  cwh_stk_push(st, ST_item);
  wn1 = cwh_expr_address(f_NONE);
  WN_kid(wn,3) = WN_CreateIoItem1(IOC_INQLENGTH_VAR, wn1, NIL);

     /* The following is just to fool the subsequent fei_store call;
	We make it store the inqlength var into itself.  The var has 
	already been passed to the io lowerer and it makes sure that 
	the value returned by _INQIL is stored into this var.
      */

  cwh_stk_push(st, ST_item);
  temp = cwh_expr_operand(DELETE_ARRAYEXP_WN);
  cwh_stk_push(st, ST_item);
  cwh_stk_push(temp,WN_item);

  if (Use_Three_Call) {
     cwh_io_split_io_statement(wn);
  } else {
    marked_set = NULL;
    status = cwh_io_analyse_io_statement(wn, WRITE_STMT);
    cwh_io_unmark();

    if (status) {
       cwh_io_split_io_statement(wn);
    } else {
       cwh_io_create_dopes(wn);
       cwh_block_append(wn);
    }
  }

}

#ifdef KEY /* Bug 7443 */
int inside_io;
#endif /* Bug 7443 */

/*===================================================
 *
 * fei_start_ioblock
 *
 * Mark the beginning of the translation for an IO statement with 
 * two comments: First, with the user's original IO statement, and 
 * the second with just "START_IO". Also add a pragma, to prevent
 * region processing from splitting IO statements.
 *
 *====================================================
*/

extern void
fei_start_ioblock(void) 
{
  char *str;
  TCON tc;
  ST *st;
  WN *wn;

#ifdef KEY /* Bug 7443 */
  inside_io += 1;
#endif /* Bug 7443 */

  cwh_stk_pop_STR();
  cwh_stk_pop_whatever();
  st = cwh_stk_pop_ST();
  ++cwh_io_in_ioblock;

  if (IO_Comments) {
     tc = STC_val(st);
     str = Targ_String_Address(tc);
     wn = WN_CreateComment(str);
     cwh_auxst_clear(WN_st(wn));
     cwh_block_append(wn);
     str = (char *) malloc(9*sizeof(char));
     strcpy(str, "START_IO");
     wn = WN_CreateComment(str);
     cwh_auxst_clear(WN_st(wn));
     cwh_block_append(wn);
     free(str);

  }
  wn = WN_CreatePragma(WN_PRAGMA_START_STMT_CLUMP, (ST *) NIL, NIL,NIL);
  cwh_block_append(wn);

}

/*===================================================
 *
 * fei_start_ioblock
 *
 * Mark the end of the translation for this IO statement
 * with the comment "END_IO"
 *
 *====================================================
*/

extern void
fei_end_ioblock(void)
{
  char *str;
  WN *wn;

#ifdef KEY /* Bug 7443 */
  inside_io -= 1;
#endif /* Bug 7443 */

  wn = WN_CreatePragma(WN_PRAGMA_END_STMT_CLUMP, (ST *) NIL, NIL,NIL);
  cwh_block_append(wn);

  --cwh_io_in_ioblock;
  if (IO_Comments) {
     str = (char *) malloc(7*sizeof(char));
     strcpy(str, "END_IO");
     wn = WN_CreateComment(str);
     cwh_auxst_clear(WN_st(wn));
     cwh_block_append(wn);
     free(str);
  }
}

/*================================================================
 *
 * static BOOL cwh_io_null_address(WN * addr)
 *
 * return TRUE if the addr node is a NULL pointer (constant 0)
 * also deletes the pointer. 
 *
 *================================================================
*/
static BOOL cwh_io_null_address(WN *addr)
{
  if (WN_operator(addr) == OPR_INTCONST &&
      WN_const_val(addr) == 0) {
    WN_Delete(addr);
    return (TRUE);
  }

  return (FALSE);
}

/*===================================================
 *
 * fei_open
 *
 * Handles the F90 open statement
 *
 *====================================================
*/

void 
fei_open(void)
{
  INT item;
  WN **open_list;
#ifdef KEY /* Bug 10177 */
  WN *wn = 0;
#else /* KEY Bug 10177 */
  WN *wn;
#endif /* KEY Bug 10177 */
  WN *length;
  WN *addr;
  WN *unit= NULL;
  TY_IDX ty = NIL;
  INT32 num_items = 0;
  INT32 i,j;
  TY_IDX ts = NIL;

  open_list = (WN **) malloc(sizeof (WN *) * 15);

  for (item=OPEN_ERR; item >= OPEN_CALLNAME; item--) {
      switch (item) {

	case OPEN_ERR:
           addr = cwh_io_cvt_tos_label_to_wn(FALSE);
	   if (addr != NULL) {
	      wn = WN_CreateIoItem1(IOC_ERR, addr, NIL);
              open_list[num_items++] = wn;
           }
	   break;

	case OPEN_PAD:
	case OPEN_DELIM:
	case OPEN_ACTION:
	case OPEN_POSITION:
	case OPEN_BLANK:
	case OPEN_FORM:
	case OPEN_ACCESS:
	case OPEN_STATUS:
	case OPEN_FILE:
	   switch(cwh_stk_get_class()) {
	      case STR_item:
		  cwh_stk_pop_STR();
		  length = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		  addr = cwh_expr_address(f_NONE);

		  if (item == OPEN_PAD)
		    wn = WN_CreateIoItem2 (IOC_PAD, addr, length, NIL);
                  else if (item == OPEN_DELIM)
		    wn = WN_CreateIoItem2 (IOC_DELIM, addr, length, NIL);
                  else if (item == OPEN_ACTION)
		    wn = WN_CreateIoItem2 (IOC_ACTION, addr, length, NIL);
                  else if (item == OPEN_POSITION)
		    wn = WN_CreateIoItem2 (IOC_POSITION, addr, length, NIL);
                  else if (item == OPEN_BLANK)
		    wn = WN_CreateIoItem2 (IOC_BLANK, addr, length, NIL);
                  else if (item == OPEN_FORM)
		    wn = WN_CreateIoItem2 (IOC_FORM, addr, length, NIL);
                  else if (item == OPEN_ACCESS)
		    wn = WN_CreateIoItem2 (IOC_ACCESS, addr, length, NIL);
                  else if (item == OPEN_STATUS)
		    wn = WN_CreateIoItem2 (IOC_STATUS, addr, length, NIL);
                  else if (item == OPEN_FILE)
		    wn = WN_CreateIoItem2 (IOC_FILE, addr, length, NIL);

		  open_list[num_items++] = wn;
		  break;
              default:
		  cwh_stk_pop_whatever();
		  break;
           }
	   break;

	case OPEN_RECL:
	case OPEN_IOSTAT:
	case OPEN_UNIT:

           ts = cwh_stk_get_TY();
	   switch(cwh_stk_get_class()) {
	     case ADDR_item:
	       
	       addr = cwh_expr_address(f_NONE);
	       if (cwh_io_null_address(addr)) break;

               if (ts != NIL) {
                 ty = cwh_types_array_TY(ts);
                 ty = cwh_types_scalar_TY(ty);
               } else {
                 ty = cwh_io_scalar_type(addr);
               }

	       if (item == OPEN_RECL)
	         wn = WN_CreateIoItem1(IOC_RECL, addr, ty);
               else if (item == OPEN_IOSTAT)
		 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty);
               else if (item == OPEN_UNIT) 
                 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL);

               if (item != OPEN_UNIT)
	         open_list[num_items++] = wn;
	       break;
             default:
	       cwh_stk_pop_whatever(); 
	       break;
           }
           break;

	case OPEN_ERRFLAG:
           switch(cwh_stk_get_class()) {
	     case ADDR_item:
	     case WN_item:
	     case WN_item_whole_array:
		wn = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL);
                open_list[num_items++] = wn;
		break;
             default:
		DevAssert((0),("Odd Open Item"));
            }
	    break;
	case OPEN_VERSION:
	case OPEN_CALLNAME:
            cwh_stk_pop_whatever(); /* ignore */
	    break;
     }
   }

   wn = WN_CreateIo (IOS_CR_OPEN, num_items + 2);

   if (unit)
      WN_kid0(wn) = unit;
   else
      WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL );
    
   WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL );
   for(i=0,j=2; i<num_items; i++,j++) 
      WN_kid(wn,j) = open_list[i];
   cwh_block_append(wn);

  free(open_list);
}  

/*===================================================
 *
 * fei_inquire
 *
 * Handles the F90 inquire statement
 *
 *====================================================
*/

void 
fei_inquire(void)
{
  INT item;
  WN **inq_list;
#ifdef KEY /* Bug 10177 */
  WN *wn = 0;
#else /* KEY Bug 10177 */
  WN *wn;
#endif /* KEY Bug 10177 */
  WN *length;
  WN *addr;
  WN *unit= NULL;
  INT32 num_items = 0;
  INT32 i,j;
  TY_IDX ts = NIL;

  inq_list = (WN **) malloc(sizeof (WN *) * 27);

  for (item=INQ_ERR; item >= INQ_CALLNAME; item--) {
      switch (item) {

        case INQ_ERR:

           addr = cwh_io_cvt_tos_label_to_wn(FALSE);

           if (addr != NULL) {
              wn = WN_CreateIoItem1(IOC_ERR, addr, NIL);
              inq_list[num_items++] = wn;
           }
           break;

	case INQ_PAD:
	case INQ_DELIM:
	case INQ_READWRITE:
	case INQ_WRITE:
	case INQ_READ:
	case INQ_ACTION:
	case INQ_POSITION:
	case INQ_BLANK:
	case INQ_UNFORMATTED:
	case INQ_FORMATTED:
	case INQ_FORM:
	case INQ_DIRECT:
	case INQ_SEQUENTIAL:
	case INQ_ACCESS:
	case INQ_NAME:
	case INQ_FILE:
	   switch(cwh_stk_get_class()) {
	      case STR_item:
		  cwh_stk_pop_STR();
		  length = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		  addr = cwh_expr_address(f_NONE);

		  if (item == INQ_PAD)
		    wn = WN_CreateIoItem2 (IOC_PAD, addr, length, NIL);
                  else if (item == INQ_DELIM)
		    wn = WN_CreateIoItem2 (IOC_DELIM, addr, length, NIL);
                  else if (item == INQ_READWRITE)
		    wn = WN_CreateIoItem2 (IOC_READWRITE, addr, length, NIL);
                  else if (item == INQ_WRITE)
		    wn = WN_CreateIoItem2 (IOC_WRITE, addr, length, NIL);
                  else if (item == INQ_READ)
		    wn = WN_CreateIoItem2 (IOC_READ, addr, length, NIL);
                  else if (item == INQ_ACTION)
		    wn = WN_CreateIoItem2 (IOC_ACTION, addr, length, NIL);
                  else if (item == INQ_POSITION)
		    wn = WN_CreateIoItem2 (IOC_POSITION, addr, length, NIL);
                  else if (item == INQ_BLANK)
		    wn = WN_CreateIoItem2 (IOC_BLANK, addr, length, NIL);
                  else if (item == INQ_UNFORMATTED)
		    wn = WN_CreateIoItem2 (IOC_UNFORMATTED, addr, length, NIL);
                  else if (item == INQ_FORMATTED)
		    wn = WN_CreateIoItem2 (IOC_FORMATTED, addr, length, NIL);
                  else if (item == INQ_FORM)
		    wn = WN_CreateIoItem2 (IOC_FORM, addr, length, NIL);
                  else if (item == INQ_DIRECT)
		    wn = WN_CreateIoItem2 (IOC_DIRECT, addr, length, NIL);
                  else if (item == INQ_SEQUENTIAL)
		    wn = WN_CreateIoItem2 (IOC_SEQUENTIAL, addr, length, NIL);
                  else if (item == INQ_ACCESS)
		    wn = WN_CreateIoItem2 (IOC_ACCESS, addr, length, NIL);
                  else if (item == INQ_NAME)
		    wn = WN_CreateIoItem2 (IOC_NAME, addr, length, NIL);
                  else if (item == INQ_FILE)
		    wn = WN_CreateIoItem2 (IOC_FILE, addr, length, NIL);

		  inq_list[num_items++] = wn;
		  break;
              default:
		  cwh_stk_pop_whatever();
		  break;
           }
	   break;

	case INQ_NEXTREC: 
	case INQ_RECL:
	case INQ_NAMED:
	case INQ_NUMBER:
	case INQ_OPENED:
	case INQ_EXIST:
	case INQ_IOSTAT:
	case INQ_UNIT:

           ts = cwh_stk_get_TY();
	   switch(cwh_stk_get_class()) {
	     TY_IDX ty;

	     case ADDR_item:
	       addr = cwh_expr_address(f_NONE);
	       if (cwh_io_null_address(addr)) break;

               if (ts != NIL) {
                 ty = cwh_types_array_TY(ts);
                 ty = cwh_types_scalar_TY(ty);
               } else {
                 ty = cwh_io_scalar_type(addr);
               }

	       if (item == INQ_NEXTREC)
	         wn = WN_CreateIoItem1(IOC_NEXTREC, addr, ty);
	       else if (item == INQ_RECL)
	         wn = WN_CreateIoItem1(IOC_RECL, addr, ty);
	       else if (item == INQ_NAMED)
	         wn = WN_CreateIoItem1(IOC_NAMED, addr, ty);
	       else if (item == INQ_NUMBER)
	         wn = WN_CreateIoItem1(IOC_NUMBER, addr, ty);
	       else if (item == INQ_OPENED)
	         wn = WN_CreateIoItem1(IOC_OPENED, addr, ty);
	       else if (item == INQ_EXIST)
	         wn = WN_CreateIoItem1(IOC_EXIST, addr, ty);
               else if (item == INQ_IOSTAT)
		 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty);
               else if (item == INQ_UNIT) 
                 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL);

               if (item != INQ_UNIT)
	         inq_list[num_items++] = wn;
	       break;
             default:
	       cwh_stk_pop_whatever(); 
	       break;
           }
           break;

	case INQ_ERRFLAG:
           switch(cwh_stk_get_class()) {
	     case ADDR_item:
	     case WN_item:
	     case WN_item_whole_array:
		wn = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL);
                inq_list[num_items++] = wn;
		break;
             default:
		DevAssert((0),("Odd Inquire Item"));
            }
	    break;
	case INQ_VERSION:
	case INQ_CALLNAME:
            cwh_stk_pop_whatever(); /* ignore */
	    break;
     }
   }

   wn = WN_CreateIo (IOS_CR_INQUIRE, num_items + 2);

   if (unit)
      WN_kid0(wn) = unit;
   else
      WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL );
    
   WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL );
   for(i=0,j=2; i<num_items; i++,j++) 
      WN_kid(wn,j) = inq_list[i];
   cwh_block_append(wn);

  free(inq_list);
}  

/*===================================================
 *
 * fei_close
 *
 * Handles the F90 close statement
 *
 *====================================================
*/

void 
fei_close(void)
{
  INT item;
  WN **close_list;
#ifdef KEY /* Bug 10177 */
  WN *wn = 0;
#else /* KEY Bug 10177 */
  WN *wn;
#endif /* KEY Bug 10177 */
  WN *length;
  WN *addr;
  WN *unit= NULL;
  INT32 num_items = 0;
  INT32 i,j;
  TY_IDX ts = NIL;

  close_list = (WN **) malloc(sizeof (WN *) * 6);

  for (item=CLOSE_ERR; item >= CLOSE_CALLNAME; item--) {
      switch (item) {
       
        case CLOSE_ERR:

           addr = cwh_io_cvt_tos_label_to_wn(FALSE);

           if (addr != NULL) {
              wn = WN_CreateIoItem1(IOC_ERR, addr, NIL);
              close_list[num_items++] = wn;
           }
           break;
 
	case CLOSE_STATUS:
	   switch(cwh_stk_get_class()) {
	      case STR_item:
		  cwh_stk_pop_STR();
		  length = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		  addr = cwh_expr_address(f_NONE);
		  wn = WN_CreateIoItem2 (IOC_STATUS, addr, length, NIL);
		  close_list[num_items++] = wn;
		  break;
              default:
		  cwh_stk_pop_whatever();
		  break;
           }
	   break;

	case CLOSE_IOSTAT:
	case CLOSE_UNIT:

           ts = cwh_stk_get_TY();

	   switch(cwh_stk_get_class()) {
	     TY_IDX ty;

	     case ADDR_item:

	       addr = cwh_expr_address(f_NONE);
	       if (cwh_io_null_address(addr)) break;

               if (ts != NIL) {
                 ty = cwh_types_array_TY(ts);
                 ty = cwh_types_scalar_TY(ty);
               } else {
                 ty = cwh_io_scalar_type(addr);
               }

               if (item == CLOSE_IOSTAT)
		 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty);
               else if (item == CLOSE_UNIT) 
                 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL);

               if (item != CLOSE_UNIT)
	         close_list[num_items++] = wn;
	       break;
             default:
	       cwh_stk_pop_whatever(); 
	       break;
           }
           break;

	case CLOSE_ERRFLAG:
           switch(cwh_stk_get_class()) {
	     case ADDR_item:
	     case WN_item:
	     case WN_item_whole_array:
		wn = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL);
                close_list[num_items++] = wn;
		break;
             default:
		DevAssert((0),("Odd Close Item"));
            }
	    break;
	case CLOSE_VERSION:
	case CLOSE_CALLNAME:
            cwh_stk_pop_whatever(); /* ignore */
	    break;
     }
   }

   wn = WN_CreateIo (IOS_CR_CLOSE, num_items + 2);

   if (unit)
      WN_kid0(wn) = unit;
   else
      WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL );
    
   WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL );
   for(i=0,j=2; i<num_items; i++,j++) 
      WN_kid(wn,j) = close_list[i];
   cwh_block_append(wn); 

  free(close_list);
}  


/*===================================================
 *
 * cwh_io_no_desc
 *
 * Handles rewind, backspace and endfile
 *
 *====================================================
*/

static void 
cwh_io_no_desc(IOSTATEMENT statement)
{
  INT item;
  WN **nodesc_list;
#ifdef KEY /* Bug 10177 */
  WN *wn = 0;
#else /* KEY Bug 10177 */
  WN *wn;
#endif /* KEY Bug 10177 */
  WN *addr;
  WN *unit= NULL;
  INT32 num_items = 0;
  INT32 i,j;
  TY_IDX ts = NIL;

  nodesc_list = (WN **) malloc(sizeof (WN *) * 6);

  for (item=NODESC_ERR; item >= NODESC_CALLNAME; item--) {
      switch (item) {

        case NODESC_ERR:

           addr = cwh_io_cvt_tos_label_to_wn(FALSE);
           if (addr != NULL) {
              wn = WN_CreateIoItem1(IOC_ERR, addr, NIL);
              nodesc_list[num_items++] = wn;
           }
           break;

	case NODESC_IOSTAT:
	case NODESC_UNIT:

           ts = cwh_stk_get_TY();
	   switch(cwh_stk_get_class()) {
	     TY_IDX ty;

	     case ADDR_item:

	       addr = cwh_expr_address(f_NONE);
	       if (cwh_io_null_address(addr)) break;

               if (ts != NIL) {
                 ty = cwh_types_array_TY(ts);
                 ty = cwh_types_scalar_TY(ty);
               } else {
                 ty = cwh_io_scalar_type(addr);
               }

               if (item == NODESC_IOSTAT)
		 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty);
               else if (item == NODESC_UNIT) 
                 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL);

               if (item != NODESC_UNIT)
	         nodesc_list[num_items++] = wn;
	       break;
             default:
	       cwh_stk_pop_whatever(); 
	       break;
           }
           break;

	case NODESC_ERRFLAG:
           switch(cwh_stk_get_class()) {
	     case ADDR_item:
	     case WN_item:
	     case WN_item_whole_array:
		wn = cwh_expr_operand(DELETE_ARRAYEXP_WN);
		wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL);
                nodesc_list[num_items++] = wn;
		break;
             default:
		DevAssert((0),("Odd Close Item"));
            }
	    break;

	case NODESC_CALLNAME:
            cwh_stk_pop_whatever(); /* ignore */
	    break;
     }
   }

   if (statement == IOS_CR_REWIND)
     wn = WN_CreateIo (IOS_CR_REWIND, num_items + 2);
   else if (statement == IOS_CR_BACKSPACE)
     wn = WN_CreateIo (IOS_CR_BACKSPACE, num_items + 2);
   else if (statement == IOS_CR_ENDFILE)
     wn = WN_CreateIo (IOS_CR_ENDFILE, num_items + 2);

   if (unit)
      WN_kid0(wn) = unit;
   else
      WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL );
    
   WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL );
   for(i=0,j=2; i<num_items; i++,j++) 
      WN_kid(wn,j) = nodesc_list[i];
   cwh_block_append(wn); 

   free(nodesc_list);
}  

/*===================================================
 *
 * fei_rewind
 *
 * Handles the F90 rewind statement
 *
 *====================================================
*/

void
fei_rewind(void)
{
  cwh_io_no_desc(IOS_CR_REWIND);
}

/*===================================================
 *
 * fei_backspace
 *
 * Handles the F90 backspace statement
 *
 *====================================================
*/

void
fei_backspace(void)
{
  cwh_io_no_desc(IOS_CR_BACKSPACE);
}

/*===================================================
 *
 * fei_endfile
 *
 * Handles the F90 endfile statement
 *
 *====================================================
*/

void
fei_endfile(void)
{
  cwh_io_no_desc(IOS_CR_ENDFILE);
}

/*===================================================
 *
 * fei_iotype
 *
 * Handles the io type code operator. They sit above each
 * io list item. The io type code constant is on top of the
 * stack, followed by the io list item.
 *
 *====================================================
*/

void
fei_iotype(void)
{

   WN *wn;

   wn = cwh_expr_operand(DELETE_ARRAYEXP_WN);
   cwh_stk_push(wn, WN_item);
}

/*===================================================
 *
 *
 * is_f90_pointer
 *
 * Called only when the OPR is an ILOAD, LDID or LDA.
 * Returns TRUE is the ST represents an f90 pointer.
 * 
 *
 *====================================================
*/

static BOOL 
is_f90_pointer(WN *addr)
{
   OPERATOR opr;
   opr = WN_operator(addr);
   if (opr == OPR_LDID || opr == OPR_LDA) {
      if (ST_class(WN_st(addr)) == CLASS_VAR) {

         return (ST_auxst_is_f90_pointer(WN_st(addr)));
      } else {
         return FALSE;
      }
   } else if (opr == OPR_ILOAD) {
      return (TY_is_f90_pointer(Ty_Table[TY_pointed(WN_load_addr_ty(addr))]));
   } else {
      return (FALSE);
   }
}

/*===================================================
 *
 * cwh_io_ST_base
 *
 * Input : an ST
 * Output:  Base of the ST
 *
 *====================================================
*/

static ST *
cwh_io_ST_base(ST *st)
{

  ST *base;

  /* cannot follow the base_st of a PREG!
   * or text
   * or preemptible symbols
   */

  if (ST_sclass(st) == SCLASS_REG || 
      ST_sclass(st) == SCLASS_TEXT ||
      ((Gen_PIC_Shared || Gen_PIC_Call_Shared) &&
       ST_export(st) == EXPORT_PREEMPTIBLE) )
  {
    return st;
  }

  /* SCLASS_BASED represents both Fortran pointers and also 
   * COMMON block spliting.  When the base_st is a KIND_POINTER,
   * it represents the former case.
   */

  if (Has_Base_Block(st)) {

    /* need to screen out the base_st that has pointer type */
//TODO ???
    TY_IDX ty = ST_type(ST_base(st));
    if (ty != NIL && TY_kind(ty) == KIND_POINTER)  {
      return st;
    }
  }

  base = st;

  while ( ST_base(base) != base  ) {

    base = ST_base(base); 
  }

  return base;
}

/*===================================================
 *
 * cwh_io_analyse_io_statement
 *
 * Returns TRUE is a single call will not suffice for this 
 * IO statement. If FALSE is returned then a single can 
 * safely be generated.
 *
 *====================================================
*/

static BOOL
cwh_io_analyse_io_statement(WN *tree, int mode)
{

  INT32 iolist;
  INT32 i;
  WN *wn;
  INT32 ioitem;

  for (iolist=0; iolist<WN_kid_count(tree); iolist++) { 
     wn = WN_kid(tree,iolist);
     ioitem = WN_io_item(wn);
     if (ioitem >= IOL_ARRAY)
        break;
  }

  for(i=iolist; i<WN_kid_count(tree); i++) {
    wn = WN_kid(tree,i);
    if (cwh_io_analyse_io_item(wn, NULL, mode))
       return TRUE;
  }
  return FALSE;
}


/*===================================================
 *
 * cwh_io_analyse_io_item
 *
 * Analyses one IO item to see if this item requires
 * that multiple calls be generated to the library. 
 * Returns FALSE if a single call will suffice; returns
 * TRUE otherwise. 
 * 
 * It uses the visited field in AUXST to analyse dependency
 * information.
 *
 *====================================================
*/

static BOOL
cwh_io_analyse_io_item(WN *tree, IMPDO_INFO *impdo_set, int mode)
{

   INT32 item;
   WN *kid0;
   OPERATOR opr;
   ST *index;
   IMPDO_INFO *new_impdo_set;
   BOOL visited;
   INT32 i;
   INT32 nd;

   item = WN_intrinsic(tree);
   
   switch(item) {

   case IOL_IMPLIED_DO:

       if (is_f90_pointer(WN_index(tree)))
          return TRUE;

       index = cwh_io_ST_base(WN_st(WN_index(tree)));
       new_impdo_set = (IMPDO_INFO *) malloc(sizeof(IMPDO_INFO));
       Impdo_index(new_impdo_set) = WN_st(WN_index(tree));
       Impdo_next(new_impdo_set) = impdo_set;

#ifdef KEY /* Bug 3279 */
       // Runtime library can interpret the implied-do loop internally only if
       // the indices are type integer*4 (see "struct dovarlist" in
       // dopexfer.c or "struct ioarray_entry" member "dovar" in f90io.h.)
       {
	 if (MTYPE_I4 != TY_mtype(WN_type(WN_index(tree))) ||
	     MTYPE_I4 != WN_rtype(WN_start(tree)) ||
	     MTYPE_I4 != WN_rtype(WN_end(tree)) ||
	     MTYPE_I4 != WN_rtype(WN_step(tree))) {
	   return TRUE;
	   }
       }
#endif /* KEY Bug 3279 */
       
       visited = ST_auxst_visited(index);
       if (visited) {
          return TRUE; 
       } else {
	 Set_ST_auxst_visited(index,TRUE);
	 cwh_io_add_st_to_marked_set(index);
       }

       if (cwh_io_analyse_expr(WN_start(tree), new_impdo_set, mode))
          return TRUE;
       else if (cwh_io_analyse_expr(WN_end(tree), new_impdo_set, mode))
          return TRUE;
       else if (cwh_io_analyse_expr(WN_step(tree), new_impdo_set, mode))
          return TRUE;
        
       for(i=4; i<WN_kid_count(tree); i++) {
          if (cwh_io_analyse_io_item(WN_kid(tree,i), new_impdo_set, mode))
             return TRUE;
       }
       free (new_impdo_set);
       break; 
       
   case IOL_EXPR:

       kid0 = WN_kid0(tree);
       opr = WNOPR(kid0);

       if ((opr == OPR_ILOAD) && (WNOPR(WN_kid0(kid0)) == OPR_ARRAY)) {
          if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode))
             return TRUE;
       } else {
          if (cwh_io_analyse_expr(kid0, impdo_set, mode))
             return TRUE;
       }
       break;

   case IOL_VAR:

       kid0 = WN_kid0(tree);
       opr = WNOPR(kid0);

       if (opr == OPR_ARRAY) {
          if (cwh_io_analyse_arr(kid0, impdo_set, mode))
             return TRUE;
       } else {
          if (cwh_io_analyse_expr(kid0, impdo_set, mode))
             return TRUE;
       }
       break;

   case IOL_CHAR:
       kid0 = WN_kid0(tree);

       /* If the length is dependent on some variable, split */

       if (cwh_io_analyse_expr(WN_kid2(tree), impdo_set, mode))
	  return TRUE;

       opr = WNOPR(kid0);

       if (opr == OPR_ARRAY) {

          nd = WN_kid_count(kid0)/2;	

	  if (WNOPR(WN_kid0(kid0)) == OPR_LDA || WNOPR(WN_kid0(kid0)) == OPR_LDID) {
             if (cwh_io_analyse_arr(kid0, impdo_set, mode))
                return TRUE;
          } else if ((nd == 1) && (WNOPR(WN_kid0(kid0)) == OPR_ARRAY)) {
	     if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode))
		return TRUE;
             for (i=2*nd; i > nd; i-- ) {
                if (cwh_io_analyse_index_expr(WN_kid(kid0,i), 
                                           impdo_set, mode) != 0)
                return TRUE;
             }
          } else {
             if (cwh_io_analyse_expr(kid0, impdo_set, mode))
                return TRUE;
          } 

       } else {
          if (cwh_io_analyse_expr(kid0, impdo_set, mode))
             return TRUE;
       }
       break;

   case IOL_DOPE:
       kid0 = WN_kid0(tree);
       opr = WNOPR(kid0);


       /* If the length is dependent on some variable, split */
       if (WN_kid2(tree) && 
              cwh_io_analyse_expr(WN_kid2(tree), impdo_set, mode))
          return TRUE;
      
       if (opr == OPR_ARRSECTION) {
	 if (cwh_io_analyse_arr(kid0, impdo_set, mode))
	    return TRUE;
       } else if ((opr == OPR_ILOAD) && 
		 (WNOPR(WN_kid0(kid0)) == OPR_ARRSECTION)) {
         if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode))
	    return TRUE;
       } else if (opr == OPR_ARRAY) {
	    nd = WN_kid_count(kid0)/2;
	    if ((nd == 1) && (WNOPR(WN_kid0(kid0)) == OPR_ARRSECTION)) {
	       if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode))
	          return TRUE;
               for (i=2*nd; i > nd; i-- ) {
                  if (cwh_io_analyse_index_expr(WN_kid(kid0,i), 
                                             impdo_set, mode) != 0)
                     return TRUE;
               }
            } else {
	       if (cwh_io_analyse_expr(kid0, impdo_set, mode))
		  return TRUE;
            }
       } else {
	 if (cwh_io_analyse_expr(kid0, impdo_set, mode))
	    return TRUE;
       }
       break;
	 
   default:
       DevAssert((0),("Odd iolist Item"));
   }

   return FALSE;
}
        

/*===================================================
 *
 * cwh_io_analyse_expr
 *
 * Analyse any expression to see if any ST in that
 * expression has the visited bit set, and if so,
 * return TRUE to indicate that the IO statement this
 * expression appears in, needs multiple calls.
 *
 * If an ST is encountered that does not have visited
 * bit set, the bit is now set so that dependency with
 * any subsequent expressions can be analyzed.
 *
 *====================================================
*/

static BOOL
cwh_io_analyse_expr(WN *tree, IMPDO_INFO *impdo_set, int mode)
{
   ST *st;
   BOOL visited;
   INT32 i;
  
   if ((WNOPR(tree) == OPR_ILOAD) || ( OPCODE_has_aux(WN_opcode(tree))))
      if (is_f90_pointer(tree))
         return TRUE;

   if ( OPCODE_has_aux(WN_opcode(tree))) {
     st = cwh_io_ST_base(WN_st(tree));
     visited = ST_auxst_visited(st);
     if (visited) {
        return TRUE;
     } else if (READ_MODE(mode)) {
       Set_ST_auxst_visited(st,TRUE);
       cwh_io_add_st_to_marked_set(st);
     }
   } else {
     for ( i = 0; i < WN_kid_count(tree); i++ )
       if (cwh_io_analyse_expr(WN_kid(tree,i), impdo_set, mode))
          return TRUE;
   }
   return FALSE;
}

/*===================================================
 *
 * cwh_io_analyse_arr
 *
 * Analyse an OPC_ARRAY node or an OPC_ARRSECTION node
 * to see if it has constructs that prevent a single call
 * from being generated. If kid0 is anything other than 
 * an LDA, a TRUE value is returned to indicate multiple
 * calls are required. The indexes along all dimensions 
 * are analyzed (see cwh_io_analyse_index_expr) and if
 * everything looks okay a value of FALSE is returned
 * to indicate that this node does not prevent a single call
 * from being generated.
 *
 *
 *====================================================
*/

static BOOL
cwh_io_analyse_arr(WN *tree, IMPDO_INFO *impdo_set, int mode)
{
  INT32 nd;
  WN *addr;
  ST *st;
  BOOL visited;
  INT32 i;

  nd = WN_kid_count(tree)/2;

  /* addr = cwh_addr_find_address(tree); */
  addr = WN_kid0(tree);

  if (WNOPR(addr) == OPR_LDA || WNOPR(addr) == OPR_LDID) {

     if (is_f90_pointer(addr))
        return TRUE;

     st = cwh_io_ST_base(WN_st(addr));
     visited = ST_auxst_visited(st);
     if (visited) {
        return TRUE;
     } else if (READ_MODE(mode)) {
        Set_ST_auxst_visited(st,TRUE);
        cwh_io_add_st_to_marked_set(st);
     }
     for (i=2*nd; i > nd; i-- ) {
         if (cwh_io_analyse_index_expr(WN_kid(tree,i), impdo_set, mode) == -1)
            return TRUE;
     }
  } else {
     if (cwh_io_analyse_expr(tree, impdo_set, mode))
        return TRUE;
  }

  return FALSE;
}

/*===================================================
 *
 * cwh_io_analyse_index_expr
 *
 * Analyze the index along a dimension of an ARRAY or
 * ARRSECTION node. If the index expr happens to be
 * an OPR_TRIPLET, then the kids representing the extent
 * and stride are analyzed by cwh_io_analyse_expr to make 
 * sure there is no dependency on an ST that has visited 
 * bit set. kid0 of the TRIPLET node is analyzed by this
 * same routine as would an index under an OPC_ARRAY node.
 *
 * If the index is of the form <i+<expr>> or <i-<expr>>
 * where i can possible be an implied do index, and expr
 * does not contain an implied do index, then it is a 
 * candidate for a single call. If anything in <expr> 
 * has the visited bit set, multiple calls are needed.
 * Any expressions which is not of the above type and 
 * is not a constant will cause a multiple call to be 
 * generated.
 *
 *====================================================
*/

static INT32
cwh_io_analyse_index_expr(WN *tree, IMPDO_INFO *impdo_set, int mode)
{
   INT32 kid0_status;
   INT32 kid1_status;
   INT32 i;
   INT32 pos;
   BOOL visited;
   ST *st;

   if (WNOPR(tree) == OPR_TRIPLET) {
     for (i=1; i<=2; i++) 
        if (cwh_io_analyse_expr(WN_kid(tree, i), impdo_set, mode))
           return -1;

     kid0_status = cwh_io_analyse_index_expr(WN_kid0(tree), impdo_set, 
                                             mode);
     return kid0_status;
     
   } else if (WNOPR(tree) == OPR_LDID) {

      if (is_f90_pointer(tree))
         return -1;

      if ( (pos = member (WN_st(tree), impdo_set)) != 0) {
         return pos;
      } else {
         st = cwh_io_ST_base(WN_st(tree));
         visited = ST_auxst_visited(st);
         if (visited)
           return -1;
         else
           return 0;
      }
   } else if ( WN_operator_is(tree,OPR_CONST) ||
               WN_operator_is(tree,OPR_INTCONST)) {
      return 0;
   } else if ( WN_operator_is(tree,OPR_ADD) ) { 
     kid0_status = cwh_io_analyse_index_expr(WN_kid0(tree), impdo_set, mode);
     kid1_status = cwh_io_analyse_index_expr(WN_kid1(tree), impdo_set, mode);
     switch(kid0_status) {
       case 0:
          return kid1_status;
       case -1:
          return -1;
       default: /* >= 1 */
          if (kid1_status == 0)
             return kid0_status;
          else
             return -1;
     }
   } else if (WN_operator_is(tree,OPR_SUB)) { 
     kid0_status = cwh_io_analyse_index_expr(WN_kid0(tree), impdo_set, mode);
     kid1_status = cwh_io_analyse_index_expr(WN_kid1(tree), impdo_set, mode);
     switch(kid0_status) {
       case 0:
	  if (kid1_status == 0)
	     return 0;
          else
	     return -1;
       case -1:
          return -1;
       default: /* >= 1 */
          if (kid1_status == 0)
             return kid0_status;
          else
             return -1;
     }
   }
   return -1;
}

/*===================================================
 *
 * member
 *
 * Checks if the given ST is a memeber of the ST's
 * contained in the implied do set. If it is a member,
 * the position of the ST is returned, else 0 is returned.
 *
 *
 *====================================================
*/

static mINT32
member(ST *st, IMPDO_INFO *impdo_set)
{
  mINT32 ret_val = 1;
  while (impdo_set) {
     if (st == Impdo_index(impdo_set))
        return ret_val;
     impdo_set = Impdo_next(impdo_set);
     ret_val++;
  }
  return 0;
}

/*===================================================
 *
 * cwh_io_create_dopes
 *
 * This routine is invoked only after it has been previously
 * determined that a single call will suffice for this IO
 * statement. This routine takes an IO statement as argument 
 * and converts:
 *
 * 1. All ARRSECTION nodes into dope vectors.
 * 2. OPC_ARRAY nodes under the control of an implied do
 *    are converted to dope vectors.
 *
 *
 *====================================================
*/

static void
cwh_io_create_dopes(WN *tree)
{
  INT32 iolist;
  INT32 i;
  WN *wn;
  INT32 ioitem;

  for (iolist=0; iolist<WN_kid_count(tree); iolist++) {
     wn = WN_kid(tree,iolist);
     ioitem = WN_io_item(wn);
     if (ioitem >= IOL_ARRAY)
        break;
  }

  for(i=iolist; i<WN_kid_count(tree); i++) {
    wn = WN_kid(tree,i);
    cwh_io_create_dope_from_item(tree, i, NULL);
  }
}

/*===================================================
 *
 * cwh_io_create_dope_from_item
 * 
 * Called by cwh_io_create_dopes to deal with a single
 * item when creating dope vectors.  For implied do's
 * the routine recursively calls itself. For other items,
 * it finds the appropriate array node and passes that to
 * cwh_io_conv_array_to_dope for conversion.
 *
 *
 *====================================================
*/

static void
cwh_io_create_dope_from_item(WN *parent, int kid_num, IMPDO_INFO *impdo_set)
{
   INT32 item;
   WN *kid0;
   OPERATOR opr;
   ST *index;
   IMPDO_INFO *new_impdo_set;
   INT32 i;
   WN *tree;

   tree = WN_kid(parent, kid_num);

   item = WN_intrinsic(tree);

   switch(item) {

   case IOL_IMPLIED_DO:

       index = WN_st(WN_index(tree));
       new_impdo_set = (IMPDO_INFO *) malloc(sizeof(IMPDO_INFO));
       Impdo_index(new_impdo_set) = index;
       Impdo_next(new_impdo_set) = impdo_set;

       for(i=4; i<WN_kid_count(tree); i++) 
          cwh_io_create_dope_from_item(tree, i, new_impdo_set);

       free(new_impdo_set);
       break;

   case IOL_EXPR:

       if (impdo_set == NULL)
	  return;

       kid0 = WN_kid0(tree);
       opr = WNOPR(kid0);

       if ((opr == OPR_ILOAD) && (WNOPR(WN_kid0(kid0)) == OPR_ARRAY)) {
          WN_kid(parent,kid_num) = cwh_io_conv_array_to_dope(kid0, 
                                                       impdo_set, tree, NULL, WN_ty(tree), WN_COPY_Tree(WN_kid1(tree)));
          WN_Delete(tree);
       }
       break;

   case IOL_VAR:

       if (impdo_set == NULL)
	  return;

       kid0 = WN_kid0(tree);
       opr = WNOPR(kid0);

       if (opr == OPR_ARRAY) {
          WN_kid(parent,kid_num) = cwh_io_conv_array_to_dope(kid0, 
                                                       impdo_set, tree, NULL,WN_ty(tree), WN_COPY_Tree(WN_kid1(tree)));
          WN_Delete(tree);
       }

       break;

   case IOL_CHAR:

       if (impdo_set == NULL)
	  return;

       kid0 = WN_kid0(tree);

       opr = WNOPR(kid0);

       if (opr == OPR_ARRAY) {

          if  ( (WNOPR(WN_kid0(kid0)) == OPR_LDA)  ||  
		(WNOPR(WN_kid0(kid0)) == OPR_LDID)  ||
		(WNOPR(WN_kid0(kid0)) == OPR_ARRAY)) {
              WN_kid(parent,kid_num) = cwh_io_conv_array_to_dope(kid0, 
                                              impdo_set, tree, WN_kid2(tree),
					      WN_ty(tree), WN_COPY_Tree(WN_kid1(tree)));
              WN_Delete(tree);
          }
       }

       break;


   case IOL_DOPE:

       kid0 = WN_kid0(tree);
       WN_kid(parent,kid_num) = cwh_io_conv_arrsection_to_dope(kid0, impdo_set, 
							  tree, WN_kid2(tree), WN_ty(tree), WN_kid1(tree));
       break;

   default:
       DevAssert((0),("Odd iolist Item"));
   }

}

/*===================================================
 *
 * cwh_io_conv_array_to_dope
 *
 * The routine receives an ARRAY or an ILOAD node as argument.
 * Thr routine first extracts the ARRAY node from the argument.
 * It then checks if any index is under the control of an implied
 * do; if yes, an IOL_DOPE item is created; the base address in the
 * dope vector may have some offset added to it. eg. for
 * a(i+5), i=1,n), the address stored in the dope vector is the address
 * of a(5).  kids 2 thru n+2 are added for the n dims of the array. The
 * 2+ith kid is set to the address of the corresponding implied do
 * var, if the ith dimension is under the control of an implied do index,
 * otherwise it contains 0. 
 *
 * If no index is under the control of an implied do, then 
 * a dope vector is not created.
 * The second kid on the IOL_DOPE is the base address of the arr node; this is 
 * passed as a dummy argument in the call generated in the IO lowerer. 
 *
 *====================================================
*/

static WN *
cwh_io_conv_array_to_dope(WN *tree, IMPDO_INFO *impdo_set, WN *old_item, WN *char_len,TY_IDX ty, WN *craytype) 
{
  INT32 nd;
  ST *st;
  WN *wn;
  INT32 pos;
  INT32 indflag = 0;
  IMPDO_INFO *impdo;
  INT32 i;
  INT32 j;
  INT32 k;
  WN *index;
  WN *address_fixup;
  WN *final_address = NULL;
  WN *offset = NULL;
  WN *new_index_expr;
  WN *kid;
  OPERATOR opr;
  WN *arr;

  opr = WNOPR(tree);

  switch(opr) {
    case OPR_ILOAD:
      kid = WN_kid0(tree);
      if (WNOPR(kid) == OPR_ARRAY) {
	 arr = kid;
	 offset =  WN_Intconst(Pointer_Mtype,WN_load_offset(tree));
      } else {
	 return (WN_COPY_Tree(old_item));
      }
      break;

    case OPR_ARRAY:
      kid = WN_kid0(tree);
      nd = WN_kid_count(tree)/2;
      if (WNOPR(kid) == OPR_LDA || WNOPR(kid) == OPR_LDID) {
	 arr = tree;
      } else if ((WNOPR(kid) == OPR_ARRAY) && (nd == 1) ) {
	 arr = kid;
         final_address = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,
                                   MTYPE_V), 3);
         WN_element_size(final_address) = WN_element_size(tree);
         WN_kid(final_address, 1) =  WN_COPY_Tree(WN_kid(tree,nd));
         WN_kid(final_address, 2) = WN_COPY_Tree(WN_kid(tree, 2*nd));
      } else {

         /* Previous dependence analysis guarantees that if we hit this else 
	    then the array is not dependent on an implied do; if it were,
	    dependence analysis would have asked us to convert the
	    implied do into a do loop and we wouldn't be here */

	 return (WN_COPY_Tree(old_item));
      } 
      break;

    default:
         /* Previous dependence analysis guarantees that if we hit this case
	    then the array is not dependent on an implied do; if it were,
	    dependence analysis would have asked us to convert the
	    implied do into a do loop and we wouldn't be here */

      return (WN_COPY_Tree(old_item));
  }
      
  nd = WN_kid_count(arr)/2;

  if (impdo_set != NULL) {
   for (i=2*nd; i > nd; i-- ) { 
       index = WN_kid(arr,i);
       if (WNOPR(index) == OPR_TRIPLET)
 	 pos = cwh_io_search_implied_do_index(WN_kid0(index), impdo_set);
       else
 	 pos = cwh_io_search_implied_do_index(index, impdo_set);
       if (pos >= 1 ) {
 	 indflag = 1;
 	 break;
       }
   }
  }
	
  if (indflag == 0) {
	return(WN_COPY_Tree(old_item));
  } else {
     wn = WN_CreateIoItemN (IOL_DOPE, nd+2, NIL);
     address_fixup = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,MTYPE_V),
			       WN_kid_count(arr));
     WN_kid0(address_fixup) = WN_kid0(arr);
     WN_element_size(address_fixup) = WN_element_size(arr);


     for (i=2*nd, k=2; i > nd; i--, k++ ) {
	 WN_kid(address_fixup,i-nd) = WN_COPY_Tree(WN_kid(arr,i-nd));
	 index = WN_kid(arr,i);
	 pos = cwh_io_search_implied_do_index(index, impdo_set);
         if (pos >= 1) {
            impdo = impdo_set;
	    for (j=1; j < pos; j++)
	       impdo = Impdo_next(impdo);
            WN_kid(wn,k) = WN_CreateLda (opc_lda, 0,
				 Make_Pointer_Type(ST_type(Impdo_index(impdo))),
                                 Impdo_index(impdo));
            new_index_expr = Substitute_1_For_Impdo_Index_Val(
				 WN_COPY_Tree(index), impdo);
            WN_kid(address_fixup,i) = new_index_expr;
         } else {
	    WN_kid(address_fixup,i) = WN_COPY_Tree(index);
	    WN_kid(wn,k) = WN_CreateIntconst ( OPC_I4INTCONST, 0);
         }
     }
     if (final_address != NULL) {
        WN_kid0(final_address) = address_fixup;
     } else if (offset != NULL) {
	final_address = WN_Add(Pointer_Mtype, address_fixup, offset);
     } else {
        final_address = address_fixup;
     }
     WN_kid0(wn) = cwh_dope_from_expression(arr, arr, char_len,ty, craytype);
     WN_kid1(wn) = cwh_addr_find_address(arr);
     st = WN_st(WN_kid0(wn));
     cwh_addr_store_ST(st, 0, Be_Type_Tbl(Pointer_type), final_address);
     return wn;
  }
}

/*===================================================
 *
 * cwh_io_conv_arrsection_to_dope
 *
 * The routine receives an expr as argument that has an ARRSECTION somewhere.
 * The routine first checks for an ILOAD over an ARRSECTION or an ARRAY
 * over an ARRSECTION or just an ARRSECTION at the top level. If any of
 * these is found, it extracts the ARRSECTION node and proceeds with
 * further processing, otherwise, the entire expr is just converted to
 * a dope vector.
 *
 * It first checks if any index is under the control of an implied
 * do; if yes, an IOL_DOPE item is created; the base address in the
 * dope vector may have some offset added to it. eg. for
 * a(i+5, :), i=1,n), the address stored in the dope vector is the address
 * of a(5,1).  kids 2 thru n+2 are added for the n dims of the array. The
 * 2+ith kid is set to the address of the corresponding implied do
 * var, if the ith dimension is under the control of an implied do index,
 * otherwise it contains 0. 
 *
 * If no index is under the control of an implied do, then f dope vector
 * is still created.
 * The second kid on the IOL_DOPE is the base address of the arr node; this is 
 * passed as a dummy argument in the call generated in the IO lowerer. 
 *
 *====================================================
*/

static WN *
cwh_io_conv_arrsection_to_dope(WN *tree, IMPDO_INFO *impdo_set, WN *old_item, 
                          WN *char_len, TY_IDX ty, WN *craytype)
{
  INT32 nd;
  ST *st;
  WN *wn;
  INT32 pos;
  INT32 indflag = 0;
  IMPDO_INFO *impdo;
  INT32 i;
  INT32 j;
  INT32 k;
  WN *index;
  WN *address_fixup;
  WN *final_address = NULL;
  WN *offset = NULL;
  WN *new_index_expr;
  WN *ad;
  WN *kid;
  OPERATOR opr;
  WN *arr;

  opr = WNOPR(tree);

  switch(opr) {
    case OPR_ILOAD:
      kid = WN_kid0(tree);
      if (WNOPR(kid) == OPR_ARRSECTION) {
	 arr = kid;
	 offset = WN_Intconst(Pointer_Mtype,WN_load_offset(tree));
      } else {
	 /* Previous dependence analysis guarantees us that if we reach
	    here, we can safely convert this to a dope vector; the ARRSECTION
	    hidden somewhere in this expression is not dependent on any
	    implied do, and we can avoid further analysis; if it were
	    dependent on an implied do index, then we would have decided
	    to split this statement, and we wouldn't be here */

         arr = cwh_addr_find_section(tree, p_RETURN_SECTION);
         ad = cwh_addr_find_address(arr);
         wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype);	  
         wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL);
         return wn;
      }
      break;

    case OPR_ARRAY:
      kid = WN_kid0(tree);
      nd = WN_kid_count(tree)/2;
      if ((WNOPR(kid) == OPR_ARRSECTION) && (nd == 1) ) {
	 arr = kid;
         final_address = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,
                                   MTYPE_V), 3);
         WN_element_size(final_address) = WN_element_size(tree);
         WN_kid(final_address, 1) =  WN_COPY_Tree(WN_kid(tree,nd));
         WN_kid(final_address, 2) = WN_COPY_Tree(WN_kid(tree, 2*nd));
      } else {
         /* Previous dependence analysis guarantees us that if we reach
            here, we can safely convert this to a dope vector; the ARRSECTION
            hidden somewhere in this expression is not dependent on any
            implied do, and we can avoid further analysis; if it were
            dependent on an implied do index, then we would have decided
            to split this statement, and we wouldn't be here */

         arr = cwh_addr_find_section(tree, p_RETURN_SECTION);
         ad = cwh_addr_find_address(arr);
         wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype);
         wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL);
         return wn;
      } 
      break;

    case OPR_ARRSECTION:
      arr = tree;
      break;

    default:
         /* Previous dependence analysis guarantees us that if we reach
            here, we can safely convert this to a dope vector; the ARRSECTION
            hidden somewhere in this expression is not dependent on any
            implied do, and we can avoid further analysis; if it were
            dependent on an implied do index, then we would have decided
            to split this statement, and we wouldn't be here */

      arr = cwh_addr_find_section(tree, p_RETURN_SECTION);
      ad = cwh_addr_find_address(arr);
      wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype);
      wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL);
      return wn;
  }
      
  nd = WN_kid_count(arr)/2;

  if (impdo_set != NULL) {
    for (i=2*nd; i > nd; i-- ) { 
        index = WN_kid(arr,i);
        if (WNOPR(index) == OPR_TRIPLET)
  	 pos = cwh_io_search_implied_do_index(WN_kid0(index), impdo_set);
        else
  	 pos = cwh_io_search_implied_do_index(index, impdo_set);
        if (pos >= 1 ) {
  	 indflag = 1;
  	 break;
        }
    }
  }
	
  if (indflag == 0) {
      arr = cwh_addr_find_section(tree, p_RETURN_SECTION);
      ad = cwh_addr_find_address(arr);
      wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype);
      wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL);
      return wn;
  } else {
     wn = WN_CreateIoItemN (IOL_DOPE, nd+2, NIL);
     address_fixup = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,MTYPE_V),
			       WN_kid_count(arr));
     WN_kid0(address_fixup) = WN_kid0(arr);
     WN_element_size(address_fixup) = WN_element_size(arr);


     for (i=2*nd, k=2; i > nd; i--, k++ ) {
	 WN_kid(address_fixup,i-nd) = WN_COPY_Tree(WN_kid(arr,i-nd));
	 index = WN_kid(arr,i);
	 if (WNOPR(index) == OPR_TRIPLET) 
	    index = WN_kid0(index);
	 pos = cwh_io_search_implied_do_index(index, impdo_set);
         if (pos >= 1) {
            impdo = impdo_set;
	    for (j=1; j < pos; j++)
	       impdo = Impdo_next(impdo);
            WN_kid(wn,k) = WN_CreateLda (opc_lda, 0,
					 Make_Pointer_Type(ST_type(Impdo_index(impdo))),
					 Impdo_index(impdo));
            new_index_expr = Substitute_1_For_Impdo_Index_Val(
				 WN_COPY_Tree(index), impdo);
            WN_kid(address_fixup,i) = new_index_expr;
         } else {
	    WN_kid(address_fixup,i) = WN_COPY_Tree(index);
	    WN_kid(wn,k) = WN_CreateIntconst ( OPC_I4INTCONST, 0);
         }
     }
     
     if (final_address != NULL) {
        WN_kid0(final_address) = address_fixup;
     } else if (offset != NULL) {
	final_address = WN_Add(Pointer_Mtype, address_fixup, offset);
     } else {
        final_address = address_fixup;
     }

     WN_kid0(wn) = cwh_dope_from_expression(arr, NULL, char_len, ty,
     craytype);
     WN_kid1(wn) = cwh_addr_find_address(arr);
     st = WN_st(WN_kid0(wn));
     cwh_addr_store_ST(st, 0, Be_Type_Tbl(Pointer_type), final_address);
     return wn;
  }
}

/*===================================================
 *
 * cwh_io_search_implied_do_index
 *
 * Checks if any ST in the array index <passed in tree>
 * is a member of the implied do index set. If yes, the 
 * position of the ST is returned, else, 0 is returned.
 *
 *====================================================
*/

static INT32 
cwh_io_search_implied_do_index(WN *tree, IMPDO_INFO *impdo_set)
{
  INT32 pos;
  ST *st;
  INT32 i;

  if (WNOPR(tree) == OPR_LDID) {
     st = WN_st(tree);
     if ( (pos = member (st, impdo_set)) != 0) 
        return pos;
  } else {
     for(i=0; i < WN_kid_count(tree); i++) {
        pos = cwh_io_search_implied_do_index(WN_kid(tree, i),impdo_set);
	if (pos != 0)
           return pos;
     }
  }
  return 0;
}

/*===================================================
 *
 * cwh_io_add_st_to_marked_set
 *
 * Adds a new ST to the visited set.
 *
 *====================================================
*/

static void
cwh_io_add_st_to_marked_set(ST *st) {
 
   MARKED_SET *new_marked_set;
 
   new_marked_set = (MARKED_SET *) malloc(sizeof(MARKED_SET));
   Marked_st(new_marked_set)  = st;
   Marked_next(new_marked_set) = marked_set;

   marked_set = new_marked_set; 
}

/*===================================================
 *
 * cwh_io_unmark
 *
 * Unmarks all ST's that were marked visited, since we
 * are done with this IO statement.
 *
 *====================================================
*/
 
static void 
cwh_io_unmark(void) {

   MARKED_SET *temp;

   while(marked_set)  {
      temp = marked_set;
      if (ST_auxst_visited(Marked_st(marked_set))) 
	Set_ST_auxst_visited(Marked_st(marked_set),FALSE);
      marked_set = Marked_next(marked_set);
      free(temp);
   }
}
      
/*===================================================
 *
 * Substitute_1_For_Impdo_Index_Val
 *
 * Searches for occurences of the implied do index in
 * the tree, and replaces the occurence by an INTCONST
 * node with val 1.
 *
 ====================================================
*/

static WN *
Substitute_1_For_Impdo_Index_Val(WN *tree, IMPDO_INFO *impdo)
{
  INT32 i;
#ifdef KEY /* Bug 10177 */
  OPCODE opc_intconst = OPC_I4INTCONST;
#else /* KEY Bug 10177 */
  OPCODE opc_intconst;
#endif /* KEY Bug 10177 */
  INT32 rtype;

  if (WN_operator_is(tree,OPR_LDID) && 
      (WN_st(tree) == Impdo_index(impdo)) ) {
     rtype = WN_rtype(tree);
     switch (rtype) {
       case MTYPE_I4:
         opc_intconst = OPC_I4INTCONST;
         break;
       case MTYPE_I8:
         opc_intconst = OPC_I8INTCONST;
         break;
       case MTYPE_U4:
         opc_intconst = OPC_U4INTCONST;
         break;
       case MTYPE_U8:
         opc_intconst = OPC_U8INTCONST;
         break;
       default:
          DevAssert((0),("Odd type"));
     }
     return (WN_CreateIntconst ( opc_intconst, 1));
  } else {
     for(i=0; i<WN_kid_count(tree); i++ ) {
       WN_kid(tree, i) = Substitute_1_For_Impdo_Index_Val(WN_kid(tree, i),
                                                          impdo);
     }
  }
  return tree;
}

/*===================================================
 *
 * cwh_io_split_io_statement
 *
 * Splits IO statement completely into a three call model.
 *
 *====================================================
*/
static void
cwh_io_split_io_statement(WN *tree) {
  WN **cilist;
  WN *wn_tmp;
  WN *item;
  WN *wn;
  INT32 ioitem_tmp;
  INT32 i;
  INT32 j;
  INT32 iolist_marker;
  INT32 num_cilist_items;
  INT32 iostatement;
  WN *kid0;
  INT32 flflag;
  INT32 new_flflag;

  iostatement = WN_io_statement(tree);

  for(i=0; i<WN_kid_count(tree); i++) {
     wn_tmp = WN_kid(tree,i);
     ioitem_tmp = WN_io_item(wn_tmp);
     if (ioitem_tmp >= IOL_ARRAY)
        break;
  }

  iolist_marker = i;

  num_cilist_items = i ;

  cilist = (WN **) malloc(sizeof (WN *) * num_cilist_items );

  for(i=0; i<iolist_marker; i++)
     cilist[i] = WN_kid(tree,i);

  wn = WN_CreateIo ( (IOSTATEMENT) iostatement, num_cilist_items);
  
  for(j=0; j<num_cilist_items; j++) {
     wn_tmp = cilist[j];
     ioitem_tmp =  WN_io_item(cilist[j]);
     if (ioitem_tmp == IOC_CR_FLFLAG) {
        kid0 = WN_kid0(wn_tmp);
        flflag = WN_const_val(kid0);
        new_flflag = flflag & 2;
        WN_kid(wn,j) = WN_CreateIoItem1 ( IOC_CR_FLFLAG,
                             WN_CreateIntconst ( OPC_I4INTCONST, new_flflag),
                             NIL);
     } else {
        WN_kid(wn,j) = WN_COPY_Tree(cilist[j]);
     } 
  } 
  cwh_block_append(wn);
    
     
  for(i=iolist_marker; i<WN_kid_count(tree); i++) {
     item = WN_kid(tree,i);
     cwh_io_split_io_items((IOSTATEMENT)iostatement, cilist, num_cilist_items, item);
  }

  wn = WN_CreateIo ( (IOSTATEMENT)iostatement, num_cilist_items);
  for(j=0; j<num_cilist_items; j++) {
     wn_tmp = cilist[j];
     ioitem_tmp =  WN_io_item(cilist[j]);
     if (ioitem_tmp == IOC_CR_FLFLAG) {
        kid0 = WN_kid0(wn_tmp);
        flflag = WN_const_val(kid0);
        new_flflag = flflag & 1;
        WN_kid(wn,j) = WN_CreateIoItem1 ( IOC_CR_FLFLAG,
                             WN_CreateIntconst ( OPC_I4INTCONST, new_flflag),
                             NIL);
     } else {
        WN_kid(wn,j) = WN_COPY_Tree(cilist[j]);
     }
  }
  cwh_block_append(wn);
  free(cilist);
}

/*===================================================
 *
 * cwh_io_split_io_items
 *
 * Called by cwh_io_split_iostatement to deal with an 
 * individual item. Recursively calls itself for implied 
 * do's.
 *
 *====================================================
*/

static void
cwh_io_split_io_items(IOSTATEMENT ios, WN **cilist,
                      INT32 num_cilist_items, WN *item) {
  WN *wn;
  INT32 ioitem_tmp;
  INT32 i;
  INT32 j;
  WN *top_label;
  WN *cont_label;
  TY_IDX ty;
  INT32 mtype;
  INT32 ntype;
  WN *load_index;
  WN *start;
  WN *step;
  WN *end;
  PREG_NUM pregnum;
  ST *pregst;
  WN *ad;
  WN *se;

  if (WN_io_item(item) == IOL_IMPLIED_DO) {
     top_label = cwh_io_create_new_label();
     cont_label = cwh_io_create_new_label();
     ty = ST_type(WN_st(WN_index(item)));
     if ( TY_kind(ty) != KIND_POINTER ) {
       ntype = mtype = TY_mtype(ty);
       if (ntype == MTYPE_I1 || ntype == MTYPE_I2)
         ntype = MTYPE_I4;
       load_index = WN_Ldid ( mtype, WN_idname_offset(WN_index(item)),
                              WN_st(WN_index(item)), ty );
       start = WN_Stid ( mtype, WN_idname_offset(WN_index(item)),
                         WN_st(WN_index(item)), ty, WN_start(item) );
       step = WN_Stid ( mtype, WN_idname_offset(WN_index(item)),
                        WN_st(WN_index(item)), ty,
                        WN_CreateExp2 ( OPCODE_make_op ( OPR_ADD, ntype,
                                                         MTYPE_V ),
                                        WN_COPY_Tree ( load_index ),
                                        WN_COPY_Tree(WN_step(item)) ));
     } else {
       ntype = mtype = TY_mtype(TY_pointed(ty));
       if (ntype == MTYPE_I1 || ntype == MTYPE_I2)
	  ntype = MTYPE_I4;
       load_index = WN_Iload ( mtype, 0, TY_pointed(ty),
                               WN_Ldid ( Pointer_type,
                                       WN_idname_offset(WN_index(item)),
                                         WN_st(WN_index(item)), ty ));
       start = WN_Istore ( mtype, 0, ty,
                           WN_Ldid ( Pointer_type,
                                     WN_idname_offset(WN_index(item)),
                                     WN_st(WN_index(item)), ty ),
                           WN_start(item) );
       step = WN_Istore ( mtype, 0, ty,
                          WN_Ldid ( Pointer_type,
                                    WN_idname_offset(WN_index(item)),
                                    WN_st(WN_index(item)), ty ),
                          WN_CreateExp2 ( OPCODE_make_op ( OPR_ADD,
								   ntype,
                                                           MTYPE_V ),
                                          WN_COPY_Tree ( load_index ),
                                          WN_COPY_Tree(WN_step(item)) ));
     }
     if ( WN_operator(WN_step(item)) == OPR_INTCONST ||
          WN_operator(WN_step(item)) == OPR_CONST ) {
       if ( ( WN_operator(WN_step(item)) == OPR_INTCONST &&
              WN_const_val(WN_step(item)) >= 0 ) ||
            ( WN_operator(WN_step(item)) == OPR_CONST &&
              STC_val(WN_st(WN_step(item))).vals.ival.v0 >= 0 ) )
         end = WN_LE ( ntype, load_index, WN_end(item) );
       else
         end = WN_GE ( ntype, load_index, WN_end(item) );
     } else {
       pregst = MTYPE_To_PREG ( Boolean_type );
       pregnum = Create_Preg ( Boolean_type, "stoptemp");
       cwh_block_append( WN_StidIntoPreg ( Boolean_type, pregnum,
                                               pregst,
                                       WN_GE ( ntype,
                                         WN_COPY_Tree ( WN_step(item) ),                                                 WN_Zerocon ( ntype ))));
       end = WN_Select ( Boolean_type,
                         WN_LdidPreg ( Boolean_type, pregnum ),
                         WN_LE ( ntype, load_index, WN_end(item) ),
                         WN_GE ( ntype, WN_COPY_Tree (load_index),
                                 WN_COPY_Tree (WN_end(item)) ));
     }
     cwh_block_append(start );
     
     cwh_block_append( WN_CreateGoto ( (ST_IDX) NULL,
						 WN_label_number(cont_label) ));
     cwh_block_append( top_label );
   
     for (i=4; i < WN_kid_count(item); i++)
        cwh_io_split_io_items(ios, cilist, num_cilist_items, 
                              WN_kid(item,i));

	cwh_block_append( step );
	cwh_block_append( cont_label );
	cwh_block_append( WN_CreateTruebr ( WN_label_number(top_label),
						     end ));

  } else {

     if (WN_io_item(item) == IOL_DOPE) {
	se = cwh_addr_find_section(WN_kid0(item), p_RETURN_SECTION);
	ad = cwh_addr_find_address(se);
	wn = cwh_dope_from_expression(WN_kid0(item), NULL, WN_kid2(item), WN_ty(item), WN_kid1(item));
	WN_Delete(item);
	item = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL);
     }

     wn = WN_CreateIo ( ios, num_cilist_items+1);
     for(j=0; j<num_cilist_items; j++) {
        ioitem_tmp = WN_io_item(cilist[j]);
        if (ioitem_tmp == IOC_CR_FLFLAG) {
          WN_kid(wn,j) = WN_CreateIoItem1 ( IOC_CR_FLFLAG,
                               WN_CreateIntconst ( OPC_I4INTCONST, 0),
                               NIL);
        } else {
          WN_kid(wn,j) = WN_COPY_Tree(cilist[j]);
        }
     }
    
      
     WN_kid(wn,num_cilist_items) = WN_COPY_Tree(item);
     cwh_block_append(wn);
  }
}

/*===================================================
 *
 * OPCODE_has_aux
 *
 * Return TRUE if operator is an LDID, or LDA or STID.
 *
 *====================================================
*/

static BOOL 
OPCODE_has_aux(const OPCODE opc)
{

  OPERATOR opr = OPCODE_operator(opc);
  return (opr == OPR_LDID || opr == OPR_STID || 
	  opr == OPR_LDA || opr == OPR_IDNAME);
}

/*===================================================
 *
 * cwh_io_create_new_label
 *
 * Create a new label and make a WN out of it.
 *
 *====================================================
*/

static WN *
cwh_io_create_new_label(void)
{
  LABEL_IDX label;

  (void) New_LABEL (CURRENT_SYMTAB, label);
  return WN_CreateLabel(NIL, label, 0, NIL);
}

/*===================================================
 *
 * cwh_io_cvt_tos_label_to_wn
 *
 * If TOS is a label, make a WN out of it.
 *
 * If flag is true, mark the label as LKIND_ASSIGNED.
 *
 *====================================================
*/
static WN *
cwh_io_cvt_tos_label_to_wn(BOOL flag)
{
  WN *wn;

  if (cwh_stk_get_class() == LB_item) {
    LABEL_IDX lbl;
    lbl = (LABEL_IDX) cwh_stk_pop_LB();
    if (flag)
       Set_LABEL_KIND(Label_Table[lbl], LKIND_ASSIGNED);
    wn = WN_CreateGoto (lbl);
  } else {
    cwh_stk_pop_whatever();
    wn = NULL;
  }
  return wn;
}
