Open64 (mfef90, whirl2f, and IR tools): osprey1.0/crayf90/fe90/s

Go to the documentation of this file.
00001 /*
00002 
00003   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00004 
00005   This program is free software; you can redistribute it and/or modify it
00006   under the terms of version 2 of the GNU General Public License as
00007   published by the Free Software Foundation.
00008 
00009   This program is distributed in the hope that it would be useful, but
00010   WITHOUT ANY WARRANTY; without even the implied warranty of
00011   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00012 
00013   Further, this software is distributed without any warranty that it is
00014   free of the rightful claim of any third person regarding infringement 
00015   or the like.  Any license provided herein, whether implied or 
00016   otherwise, applies only to this software file.  Patent licenses, if 
00017   any, provided herein do not apply to combinations of this program with 
00018   other software, or any other product whatsoever.  
00019 
00020   You should have received a copy of the GNU General Public License along
00021   with this program; if not, write the Free Software Foundation, Inc., 59
00022   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00023 
00024   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00025   Mountain View, CA 94043, or:
00026 
00027   http://www.sgi.com
00028 
00029   For further information regarding this notice, see:
00030 
00031   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00032 
00033 */
00034 
00035 
00036 
00037 static char USMID[] = "\n@(#)5.0_pl/sources/s_io.c      5.8     10/04/99 17:44:33\n";
00038 
00039 # include "defines.h"           /* Machine dependent ifdefs */
00040 
00041 # include "host.m"              /* Host machine dependent macros.*/
00042 # include "host.h"              /* Host machine dependent header.*/
00043 # include "target.m"            /* Target machine dependent macros.*/
00044 # include "target.h"            /* Target machine dependent header.*/
00045 
00046 # include "globals.m"
00047 # include "tokens.m"
00048 # include "sytb.m"
00049 # include "s_globals.m"
00050 # include "debug.m"
00051 # include "p_io.m"
00052 
00053 # include "globals.h"
00054 # include "tokens.h"
00055 # include "sytb.h"
00056 # include "s_globals.h"
00057 # include "s_io.h"
00058 
00059 
00060 /*****************************************************************\
00061 |* Function prototypes of static functions declared in this file *|
00062 \*****************************************************************/
00063 
00064 static boolean   io_ctl_list_semantics(opnd_type *, io_stmt_type, boolean);
00065 static boolean   io_list_semantics(opnd_type *, io_stmt_type);
00066 static void      namelist_static_dv_whole_def(opnd_type *, opnd_type *);
00067 static void      put_string_in_tmp(char *, int, opnd_type *);
00068 
00069 # ifdef _INIT_RELOC_BASE_OFFSET
00070 static int       change_to_base_and_offset(opnd_type *, opnd_type *);
00071 # endif
00072 static int       create_scalar_type_tbl(opnd_type *, boolean);
00073 static int       create_strct_tbl(opnd_type *, boolean);
00074 static boolean   do_read_namelist_semantics(opnd_type   *);
00075 static void      do_write_namelist_semantics(opnd_type  *);
00076 static int       discombobulate_structure_ref(opnd_type *, int, int *);
00077 static int       change_section_to_do(int *);
00078 static void      process_deferred_io_list(void);
00079 static void      expand_io_list(void);
00080 static void      expand_imp_do(int, int);
00081 static int       copy_text_for_expansion(int);
00082 static void      create_io_call_descriptor(int, io_descriptor_type);
00083 # ifdef _NO_IO_ALTERNATE_RETURN
00084 static void      add_alt_return_lbl(int, int);
00085 # endif
00086 static boolean   item_has_bounds_chk(opnd_type *);
00087 static void gen_array_element_init(int, long_type *, opnd_type *, int, int);
00088 
00089 static int      err_attr_idx;
00090 
00091 
00092 /******************************************************************************\
00093 |*                                                                            *|
00094 |* Description:                                                               *|
00095 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
00096 |*                                                                            *|
00097 |* Input parameters:                                                          *|
00098 |*      NONE                                                                  *|
00099 |*                                                                            *|
00100 |* Output parameters:                                                         *|
00101 |*      NONE                                                                  *|
00102 |*                                                                            *|
00103 |* Returns:                                                                   *|
00104 |*      NONE                                                                  *|
00105 |*                                                                            *|
00106 \******************************************************************************/
00107 
00108 void backspace_stmt_semantics (void)
00109 
00110 {
00111 # ifndef _NO_IO_ALTERNATE_RETURN
00112    int                  alt_return_tmp;
00113    int                  asg_idx;
00114    int                  br_true_idx;
00115    int                  col;
00116    int                  eq_idx;
00117    int                  line;
00118    int                  save_next_sh_idx;
00119 # endif
00120 
00121    int                  ir_idx;
00122    opnd_type            opnd;
00123    int                  save_arg_info_list_base;
00124    int                  save_curr_stmt_sh_idx;
00125    boolean              semantically_correct;
00126 
00127 
00128    TRACE (Func_Entry, "backspace_stmt_semantics", NULL);
00129 
00130    SCP_DOES_IO(curr_scp_idx) = TRUE;
00131 
00132    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00133 
00134    /* do memory management stuff to make sure the call tables are big enough */
00135 
00136    if (max_call_list_size >= arg_list_size) {
00137       enlarge_call_list_tables();
00138    }
00139 
00140    save_arg_info_list_base = arg_info_list_base;
00141 
00142    arg_info_list_base      = arg_info_list_top;
00143 
00144    arg_info_list_top       = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
00145 
00146    if (arg_info_list_top >= arg_info_list_size) {
00147       enlarge_info_list_table();
00148    }
00149 
00150 # ifndef _NO_IO_ALTERNATE_RETURN
00151    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
00152 # endif
00153 
00154    COPY_OPND(opnd, IR_OPND_R(ir_idx));
00155    semantically_correct = io_ctl_list_semantics(&opnd, Backspace, TRUE);
00156    COPY_OPND(IR_OPND_R(ir_idx), opnd);
00157 
00158    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00159 
00160 # ifndef _NO_IO_ALTERNATE_RETURN
00161    if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
00162 
00163       line = IR_LINE_NUM(ir_idx);
00164       col  = IR_COL_NUM(ir_idx);
00165 
00166       alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
00167       ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
00168       ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
00169       AT_REFERENCED(alt_return_tmp)     = Referenced;
00170       AT_DEFINED(alt_return_tmp)        = TRUE;
00171       AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
00172 
00173       NTR_IR_TBL(asg_idx);
00174       IR_OPR(asg_idx)        = Alt_Return_Opr;
00175       IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
00176       IR_LINE_NUM(asg_idx)   = line;
00177       IR_COL_NUM(asg_idx)    = col;
00178       IR_LINE_NUM_L(asg_idx) = line;
00179       IR_COL_NUM_L(asg_idx)  = col;
00180       IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
00181       IR_IDX_L(asg_idx)      = alt_return_tmp;
00182       IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
00183       IR_IDX_R(asg_idx)      = ir_idx;
00184 
00185       SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
00186 
00187       if (err_list_idx) {
00188          NTR_IR_TBL(br_true_idx);
00189          IR_OPR(br_true_idx)      = Br_True_Opr;
00190          IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
00191          IR_LINE_NUM(br_true_idx) = line;
00192          IR_COL_NUM(br_true_idx)  = col;
00193 
00194          NTR_IR_TBL(eq_idx);
00195          IR_OPR(eq_idx)           = Eq_Opr;
00196          IR_TYPE_IDX(eq_idx)      = LOGICAL_DEFAULT_TYPE;
00197          IR_LINE_NUM(eq_idx)      = line;
00198          IR_COL_NUM(eq_idx)       = col;
00199          IR_FLD_L(eq_idx)         = AT_Tbl_Idx;
00200          IR_IDX_L(eq_idx)         = alt_return_tmp;
00201          IR_LINE_NUM_L(eq_idx)    = line;
00202          IR_COL_NUM_L(eq_idx)     = col;
00203 
00204          IR_FLD_R(eq_idx)         = CN_Tbl_Idx;
00205          IR_IDX_R(eq_idx)         = CN_INTEGER_ONE_IDX;
00206          IR_LINE_NUM_R(eq_idx)    = line;
00207          IR_COL_NUM_R(eq_idx)     = col;
00208 
00209          IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
00210          IR_IDX_L(br_true_idx)    = eq_idx;
00211 
00212          COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
00213 
00214          curr_stmt_sh_idx = save_next_sh_idx;
00215 
00216          gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
00217 
00218          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = br_true_idx;
00219          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
00220 
00221          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00222       }
00223    }
00224 # endif
00225       
00226    if (semantically_correct) {
00227       COPY_OPND(opnd, IR_OPND_R(ir_idx));
00228       semantically_correct = final_arg_work(&opnd,
00229                                             IR_IDX_L(ir_idx), 
00230                                             IR_LIST_CNT_R(ir_idx),
00231                                             NULL);
00232       COPY_OPND(IR_OPND_R(ir_idx), opnd);
00233 
00234 # if defined(_FILE_IO_OPRS)
00235       IR_OPR(ir_idx) = Backspace_Opr;
00236 # endif
00237    }
00238 
00239 # ifdef _NO_IO_ALTERNATE_RETURN
00240    add_alt_return_lbl(ir_idx, err_attr_idx);
00241 # endif
00242 
00243    /* restore arg_info_list to previous "stack frame" */
00244 
00245    arg_info_list_top  = arg_info_list_base;
00246    arg_info_list_base = save_arg_info_list_base;
00247 
00248    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00249 
00250    TRACE (Func_Exit, "backspace_stmt_semantics", NULL);
00251 
00252    return;
00253 
00254 }  /* backspace_stmt_semantics */
00255 
00256 
00257 /******************************************************************************\
00258 |*                                                                            *|
00259 |* Description:                                                               *|
00260 |*      do semantic stuff for buffer in and buffer out stmts.                 *|
00261 |*                                                                            *|
00262 |* Input parameters:                                                          *|
00263 |*      NONE                                                                  *|
00264 |*                                                                            *|
00265 |* Output parameters:                                                         *|
00266 |*      NONE                                                                  *|
00267 |*                                                                            *|
00268 |* Returns:                                                                   *|
00269 |*      NONE                                                                  *|
00270 |*                                                                            *|
00271 \******************************************************************************/
00272 
00273 void buffer_stmt_semantics (void)
00274 
00275 {
00276    int           base_attr;
00277    boolean       buffer_in;
00278    int           col;
00279    expr_arg_type exp_desc;
00280    expr_arg_type exp_desc2;
00281    int           info_idx;
00282    int           ir_idx;
00283    int           line;
00284    int           list_idx;
00285    opnd_type     opnd;
00286    int           save_arg_info_list_base;
00287    boolean       semantically_correct;
00288    long_type     the_constant[2];
00289    int           type_idx;
00290 
00291 
00292    TRACE (Func_Entry, "buffer_stmt_semantics", NULL);
00293 
00294    SCP_DOES_IO(curr_scp_idx) = TRUE;
00295 
00296    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00297 
00298    /* do memory management stuff to make sure the call tables are big enough */
00299 
00300    if (max_call_list_size >= arg_list_size) {
00301       enlarge_call_list_tables();
00302    }
00303 
00304    save_arg_info_list_base = arg_info_list_base;
00305 
00306    arg_info_list_base      = arg_info_list_top;
00307 
00308    arg_info_list_top       = arg_info_list_base + 5;
00309 
00310    if (arg_info_list_top >= arg_info_list_size) {
00311       enlarge_info_list_table();
00312    }
00313 
00314    info_idx = arg_info_list_base;
00315 
00316    if (IR_IDX_L(ir_idx) == glb_tbl_idx[Buffer_In_Attr_Idx]) {
00317       buffer_in = TRUE;
00318    }
00319    else {
00320       buffer_in = FALSE;
00321    }
00322 
00323    /* process unit number or file name */
00324 
00325    list_idx = IR_IDX_R(ir_idx);
00326    COPY_OPND(opnd, IL_OPND(list_idx));
00327    exp_desc.rank = 0;
00328    xref_state = CIF_Symbol_Reference;
00329    semantically_correct = expr_semantics(&opnd, &exp_desc);
00330    COPY_OPND(IL_OPND(list_idx), opnd);
00331    find_opnd_line_and_column(&opnd, &line, &col);
00332 
00333    if (exp_desc.linear_type == Long_Typeless) {
00334       PRINTMSG(line, 1133, Error, col);
00335       semantically_correct = FALSE;
00336    }
00337    else if (exp_desc.type != Integer    &&
00338             exp_desc.type != Typeless   &&
00339             exp_desc.type != Character) {
00340 
00341       /* error .. bad type for unit */
00342 
00343       PRINTMSG(line, 229, Error, col);
00344       semantically_correct = FALSE;
00345    }
00346    else if (exp_desc.type != Character &&
00347             exp_desc.rank != 0)        {
00348 
00349       /* error .. not scalar */
00350 
00351       PRINTMSG(line, 229, Error, col);
00352       semantically_correct = FALSE;
00353    }
00354    else if (exp_desc.type == Character &&
00355             exp_desc.constant) {
00356 
00357       /* change to Typeless if length right */
00358 
00359       if (compare_cn_and_value(TYP_IDX(CN_TYPE_IDX(OPND_IDX(opnd))),
00360                                TARGET_BYTES_PER_WORD,
00361                                Lt_Opr)) {
00362          CN_TYPE_IDX(OPND_IDX(opnd)) = TYPELESS_DEFAULT_TYPE;
00363       }
00364       else {
00365          PRINTMSG(line, 231, Error, col,
00366                   TARGET_BYTES_PER_WORD - 1);
00367          semantically_correct = FALSE;
00368       }
00369    }
00370    else if (exp_desc.linear_type == Short_Typeless_Const) {
00371       IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
00372                                                 CG_INTEGER_DEFAULT_TYPE,
00373                                                 line,
00374                                                 col);
00375       exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
00376       exp_desc.type_idx    = INTEGER_DEFAULT_TYPE;
00377       exp_desc.type        = Integer;
00378    }
00379 
00380    COPY_OPND(opnd, IL_OPND(list_idx));
00381    cast_to_cg_default(&opnd, &exp_desc);
00382    COPY_OPND(IL_OPND(list_idx), opnd);
00383 
00384    info_idx++;
00385    arg_info_list[info_idx]    = init_arg_info;
00386    arg_info_list[info_idx].ed = exp_desc;
00387    arg_info_list[info_idx].maybe_modified   = TRUE;
00388    IL_ARG_DESC_IDX(list_idx)                = info_idx;
00389 
00390    /* process mode */
00391 
00392    list_idx = IL_NEXT_LIST_IDX(list_idx);
00393    COPY_OPND(opnd, IL_OPND(list_idx));
00394    exp_desc.rank = 0;
00395    xref_state = CIF_Symbol_Reference;
00396    semantically_correct = expr_semantics(&opnd, &exp_desc) &&
00397                           semantically_correct;
00398    COPY_OPND(IL_OPND(list_idx), opnd);
00399 
00400    if (exp_desc.type != Integer) {
00401 
00402       /* error .. mode must be integer expression */
00403 
00404       find_opnd_line_and_column(&opnd, &line, &col);
00405       PRINTMSG(line, 228, Error, col);
00406       semantically_correct = FALSE;
00407    }
00408    
00409    if (exp_desc.rank != 0) {      /* error .. must be scalar */
00410       find_opnd_line_and_column(&opnd, &line, &col);
00411       PRINTMSG(line, 230, Error, col);
00412       semantically_correct = FALSE;
00413    }
00414 
00415    COPY_OPND(opnd, IL_OPND(list_idx));
00416    cast_to_cg_default(&opnd, &exp_desc);
00417    COPY_OPND(IL_OPND(list_idx), opnd);
00418 
00419    info_idx++;
00420    arg_info_list[info_idx]    = init_arg_info;
00421    arg_info_list[info_idx].ed = exp_desc; 
00422    arg_info_list[info_idx].maybe_modified   = TRUE;
00423    IL_ARG_DESC_IDX(list_idx)                = info_idx;
00424    
00425    /* process bloc */
00426 
00427    list_idx = IL_NEXT_LIST_IDX(list_idx);
00428 
00429    COPY_OPND(opnd, IL_OPND(list_idx));
00430    exp_desc.rank = 0;
00431 
00432    if (buffer_in) {
00433       xref_state = CIF_Symbol_Modification;
00434    }
00435    else {
00436       xref_state = CIF_Symbol_Reference;
00437    }
00438    semantically_correct = expr_semantics(&opnd, &exp_desc) &&
00439                           semantically_correct;
00440    COPY_OPND(IL_OPND(list_idx), opnd);
00441 
00442    base_attr = find_base_attr(&opnd, &line, &col);
00443 
00444    info_idx++;
00445    arg_info_list[info_idx]    = init_arg_info;
00446    arg_info_list[info_idx].ed = exp_desc;
00447    arg_info_list[info_idx].maybe_modified   = TRUE;
00448    IL_ARG_DESC_IDX(list_idx)                = info_idx;
00449 
00450    list_idx = IL_NEXT_LIST_IDX(list_idx);
00451 
00452    /* process eloc */
00453 
00454    COPY_OPND(opnd, IL_OPND(list_idx));
00455    exp_desc.rank = 0;
00456 
00457    if (buffer_in) {
00458       xref_state = CIF_Symbol_Modification;
00459    }
00460    else {
00461       xref_state = CIF_Symbol_Reference;
00462    }
00463    semantically_correct = expr_semantics(&opnd, &exp_desc2) &&
00464                           semantically_correct;
00465    COPY_OPND(IL_OPND(list_idx), opnd);
00466 
00467    if (exp_desc.type == Structure) {
00468       find_opnd_line_and_column(&opnd, &line, &col);
00469       PRINTMSG(line, 879, Error, col);
00470       semantically_correct = FALSE;
00471    }
00472    else if ((exp_desc.type == Character &&
00473              exp_desc2.type != Character) ||
00474             (exp_desc2.type == Character &&
00475              exp_desc.type != Character)) {
00476 
00477       find_opnd_line_and_column(&opnd, &line, &col);
00478       PRINTMSG(line, 896, Error, col);
00479       semantically_correct = FALSE;
00480    }
00481    else if (exp_desc.type != Character &&
00482             exp_desc2.type != Character &&
00483             storage_bit_size_tbl[exp_desc.linear_type] !=
00484             storage_bit_size_tbl[exp_desc2.linear_type]) {
00485 
00486       find_opnd_line_and_column(&opnd, &line, &col);
00487       PRINTMSG(line, 896, Error, col);
00488       semantically_correct = FALSE;
00489    }
00490 
00491    info_idx++;
00492    arg_info_list[info_idx]    = init_arg_info;
00493    arg_info_list[info_idx].ed = exp_desc2;
00494    arg_info_list[info_idx].maybe_modified   = TRUE;
00495    IL_ARG_DESC_IDX(list_idx)                = info_idx;
00496 
00497    /* set up type code arg */
00498 
00499    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00500    list_idx = IL_NEXT_LIST_IDX(list_idx);
00501    IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00502    IR_LIST_CNT_R(ir_idx) = 5;
00503 
00504    make_io_type_code(ATD_TYPE_IDX(base_attr), the_constant); /* BRIANJ */
00505    IL_FLD(list_idx) = CN_Tbl_Idx;
00506 
00507 # if defined(GENERATE_WHIRL) && ! defined(_TYPE_CODE_64_BIT)
00508    /* the type information goes in a 64 bit thing for mongoose */
00509    the_constant[1] = the_constant[0];
00510    the_constant[0] = 0;
00511    type_idx = Integer_8;
00512 # else
00513    type_idx = IO_TYPE_CODE_TYPE;
00514 # endif
00515 
00516   /* BRIANJ - KAYKAY */
00517 
00518    IL_IDX(list_idx) = ntr_const_tbl(type_idx,
00519                                     FALSE,
00520                                     the_constant);
00521    IL_LINE_NUM(list_idx) = line;
00522    IL_COL_NUM(list_idx)  = col;
00523 
00524    exp_desc = init_exp_desc;
00525    exp_desc.type = TYP_TYPE(type_idx);
00526    exp_desc.linear_type = TYP_LINEAR(type_idx);
00527    exp_desc.type_idx = type_idx;
00528    exp_desc.constant = TRUE;
00529    exp_desc.foldable = TRUE;
00530 
00531    info_idx++;
00532    arg_info_list[info_idx]    = init_arg_info;
00533    arg_info_list[info_idx].ed = exp_desc;
00534    arg_info_list[info_idx].maybe_modified   = TRUE;
00535    IL_ARG_DESC_IDX(list_idx)                = info_idx;
00536 
00537    if (semantically_correct) {
00538       COPY_OPND(opnd, IR_OPND_R(ir_idx));
00539       semantically_correct = final_arg_work(&opnd,
00540                                             IR_IDX_L(ir_idx),
00541                                             IR_LIST_CNT_R(ir_idx),
00542                                             NULL);
00543       COPY_OPND(IR_OPND_R(ir_idx), opnd);
00544       create_io_call_descriptor(ir_idx, Buffer_Desc);
00545 # if 0
00546 # if defined(_FILE_IO_OPRS)
00547       if (buffer_in) {
00548          IR_OPR(ir_idx) = Buffer_In_Opr;
00549       }
00550       else {
00551          IR_OPR(ir_idx) = Buffer_Out_Opr;
00552       }
00553 # endif
00554 # endif
00555    }
00556 
00557    /* restore arg_info_list to previous "stack frame" */
00558 
00559    arg_info_list_top  = arg_info_list_base;
00560    arg_info_list_base = save_arg_info_list_base;
00561 
00562    TRACE (Func_Exit, "buffer_stmt_semantics", NULL);
00563 
00564    return;
00565 
00566 }  /* buffer_stmt_semantics */
00567 
00568 
00569 /******************************************************************************\
00570 |*                                                                            *|
00571 |* Description:                                                               *|
00572 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
00573 |*                                                                            *|
00574 |* Input parameters:                                                          *|
00575 |*      NONE                                                                  *|
00576 |*                                                                            *|
00577 |* Output parameters:                                                         *|
00578 |*      NONE                                                                  *|
00579 |*                                                                            *|
00580 |* Returns:                                                                   *|
00581 |*      NONE                                                                  *|
00582 |*                                                                            *|
00583 \******************************************************************************/
00584 
00585 void close_stmt_semantics (void)
00586 
00587 {
00588 
00589    int                  ir_idx;
00590    opnd_type            opnd;
00591    int                  save_arg_info_list_base;
00592    int                  save_curr_stmt_sh_idx;
00593    boolean              semantically_correct;
00594 
00595 # ifndef _NO_IO_ALTERNATE_RETURN
00596    int                  alt_return_tmp;
00597    int                  asg_idx;
00598    int                  br_true_idx;
00599    int                  col;
00600    int                  eq_idx;
00601    int                  line;
00602    int                  save_next_sh_idx;
00603 # endif
00604 
00605 
00606    TRACE (Func_Entry, "close_stmt_semantics", NULL);
00607 
00608    SCP_DOES_IO(curr_scp_idx) = TRUE;
00609 
00610    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00611 
00612    /* do memory management stuff to make sure the call tables are big enough */
00613 
00614    if (max_call_list_size >= arg_list_size) {
00615       enlarge_call_list_tables();
00616    }
00617 
00618    save_arg_info_list_base = arg_info_list_base;
00619 
00620    arg_info_list_base      = arg_info_list_top;
00621 
00622    arg_info_list_top       = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
00623 
00624    if (arg_info_list_top >= arg_info_list_size) {
00625       enlarge_info_list_table();
00626    }
00627 
00628 # ifndef _NO_IO_ALTERNATE_RETURN
00629    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
00630 # endif
00631 
00632    COPY_OPND(opnd, IR_OPND_R(ir_idx));
00633    semantically_correct = io_ctl_list_semantics(&opnd, Close, TRUE);
00634    COPY_OPND(IR_OPND_R(ir_idx), opnd);
00635 
00636    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00637 
00638 # ifndef _NO_IO_ALTERNATE_RETURN
00639    if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
00640 
00641       line = IR_LINE_NUM(ir_idx);
00642       col  = IR_COL_NUM(ir_idx);
00643 
00644       alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
00645       ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
00646       ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
00647       AT_REFERENCED(alt_return_tmp)     = Referenced;
00648       AT_DEFINED(alt_return_tmp)        = TRUE;
00649       AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
00650 
00651       NTR_IR_TBL(asg_idx);
00652       IR_OPR(asg_idx)        = Alt_Return_Opr;
00653       IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
00654       IR_LINE_NUM(asg_idx)   = line;
00655       IR_COL_NUM(asg_idx)    = col;
00656       IR_LINE_NUM_L(asg_idx) = line;
00657       IR_COL_NUM_L(asg_idx)  = col;
00658       IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
00659       IR_IDX_L(asg_idx)      = alt_return_tmp;
00660       IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
00661       IR_IDX_R(asg_idx)      = ir_idx;
00662 
00663       SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
00664 
00665       if (err_list_idx) {
00666          NTR_IR_TBL(br_true_idx);
00667          IR_OPR(br_true_idx)      = Br_True_Opr;
00668          IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
00669          IR_LINE_NUM(br_true_idx) = line;
00670          IR_COL_NUM(br_true_idx)  = col;
00671 
00672          NTR_IR_TBL(eq_idx);
00673          IR_OPR(eq_idx)           = Eq_Opr;
00674          IR_TYPE_IDX(eq_idx)      = LOGICAL_DEFAULT_TYPE;
00675          IR_LINE_NUM(eq_idx)      = line;
00676          IR_COL_NUM(eq_idx)       = col;
00677          IR_FLD_L(eq_idx)         = AT_Tbl_Idx;
00678          IR_IDX_L(eq_idx)         = alt_return_tmp;
00679          IR_LINE_NUM_L(eq_idx)    = line;
00680          IR_COL_NUM_L(eq_idx)     = col;
00681 
00682          IR_FLD_R(eq_idx)         = CN_Tbl_Idx;
00683          IR_IDX_R(eq_idx)         = CN_INTEGER_ONE_IDX;
00684          IR_LINE_NUM_R(eq_idx)    = line;
00685          IR_COL_NUM_R(eq_idx)     = col;
00686 
00687          IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
00688          IR_IDX_L(br_true_idx)    = eq_idx;
00689 
00690          COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
00691 
00692          curr_stmt_sh_idx = save_next_sh_idx;
00693 
00694          gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
00695 
00696          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = br_true_idx;
00697          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
00698 
00699          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00700       }
00701    }
00702 # endif
00703 
00704    if (semantically_correct) {
00705       COPY_OPND(opnd, IR_OPND_R(ir_idx));
00706       semantically_correct = final_arg_work(&opnd,
00707                                             IR_IDX_L(ir_idx),
00708                                             IR_LIST_CNT_R(ir_idx),
00709                                             NULL);
00710       COPY_OPND(IR_OPND_R(ir_idx), opnd);
00711       create_io_call_descriptor(ir_idx, Close_Desc);
00712 # if defined(_FILE_IO_OPRS)
00713       IR_OPR(ir_idx) = Close_Opr;
00714 # endif
00715    }
00716 
00717 # ifdef _NO_IO_ALTERNATE_RETURN
00718    add_alt_return_lbl(ir_idx, err_attr_idx);
00719 # endif
00720 
00721    /* restore arg_info_list to previous "stack frame" */
00722 
00723    arg_info_list_top  = arg_info_list_base;
00724    arg_info_list_base = save_arg_info_list_base;
00725 
00726    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00727 
00728    TRACE (Func_Exit, "close_stmt_semantics", NULL);
00729 
00730    return;
00731 
00732 }  /* close_stmt_semantics */
00733 
00734 
00735 /******************************************************************************\
00736 |*                                                                            *|
00737 |* Description:                                                               *|
00738 |*      Process the decode stmt. It is transformed into an internal Read.     *|
00739 |*      Process the encode stmt. It is transformed into an internal Write.    *|
00740 |*                                                                            *|
00741 |* Input parameters:                                                          *|
00742 |*      NONE                                                                  *|
00743 |*                                                                            *|
00744 |* Output parameters:                                                         *|
00745 |*      NONE                                                                  *|
00746 |*                                                                            *|
00747 |* Returns:                                                                   *|
00748 |*      NONE                                                                  *|
00749 |*                                                                            *|
00750 \******************************************************************************/
00751 
00752 void encode_decode_stmt_semantics (void)
00753 
00754 {
00755    int           attr_idx;
00756    int           cnt_list_idx;
00757    int           col;
00758    expr_arg_type exp_desc;
00759    int           free_list_idx;
00760    int           fmt_list_idx;
00761    int           intern_list_idx;
00762    int           ir_idx;
00763    opnd_type     left_opnd;
00764    int           line;
00765    int           list_idx;
00766    boolean       ok;
00767    opnd_type     opnd;
00768    int           pp_tmp = NULL_IDX;
00769    int           tmp_idx;
00770 
00771 
00772    TRACE (Func_Entry, "encode_decode_stmt_semantics", NULL);
00773 
00774    SCP_DOES_IO(curr_scp_idx) = TRUE;
00775 
00776    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00777 
00778    cnt_list_idx = IR_IDX_L(ir_idx);
00779 
00780    COPY_OPND(opnd, IL_OPND(cnt_list_idx));
00781    exp_desc.rank = 0;
00782    xref_state    = CIF_Symbol_Reference;
00783    ok = expr_semantics(&opnd, &exp_desc);
00784    COPY_OPND(IL_OPND(cnt_list_idx), opnd);
00785    find_opnd_line_and_column(&opnd, &line, &col);
00786 
00787    if (exp_desc.type != Integer) {
00788       PRINTMSG(line, 681, Error, col, stmt_type_str[stmt_type]);
00789    }
00790    else if (exp_desc.constant &&
00791             (CN_INT_TO_C(OPND_IDX(opnd)) <= 0 ||
00792              CN_INT_TO_C(OPND_IDX(opnd)) > 152)) {
00793 
00794       PRINTMSG(line, 682, Error, col, stmt_type_str[stmt_type]);
00795    }
00796    else if (exp_desc.rank > 0) {
00797       PRINTMSG(line, 683, Error, col, stmt_type_str[stmt_type]);
00798    }
00799 
00800    /* do I need the count ? */
00801 
00802    fmt_list_idx = IL_NEXT_LIST_IDX(cnt_list_idx);
00803 
00804    if (IL_FLD(fmt_list_idx) == IL_Tbl_Idx) {
00805 
00806       /* this was format character constant inline */
00807       /* do not send through expr_semantics.       */
00808       /* first item is format tmp, second is       */
00809       /* preparsed format tmp.                     */
00810 
00811       pp_tmp = IL_IDX(IL_NEXT_LIST_IDX(IL_IDX(fmt_list_idx)));
00812       FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(fmt_list_idx)));
00813       free_list_idx = IL_IDX(fmt_list_idx);
00814       COPY_OPND(IL_OPND(fmt_list_idx), IL_OPND(IL_IDX(fmt_list_idx)));
00815       FREE_IR_LIST_NODE(free_list_idx);
00816 
00817       ADD_TMP_TO_SHARED_LIST(IL_IDX(fmt_list_idx));
00818       ADD_TMP_TO_SHARED_LIST(pp_tmp);
00819    }
00820    else if (IL_FLD(fmt_list_idx)               == AT_Tbl_Idx &&
00821             AT_OBJ_CLASS(IL_IDX(fmt_list_idx)) == Label)     {
00822 
00823       if (ATL_CLASS(IL_IDX(fmt_list_idx)) == Lbl_Format) {
00824 
00825          pp_tmp = ATL_PP_FORMAT_TMP(IL_IDX(fmt_list_idx));
00826          /* replace label reference with format constant idx */
00827          IL_IDX(fmt_list_idx) = ATL_FORMAT_TMP(IL_IDX(fmt_list_idx));
00828          IL_FLD(fmt_list_idx) = AT_Tbl_Idx;
00829          IL_LINE_NUM(fmt_list_idx) = line;
00830          IL_COL_NUM(fmt_list_idx)  = col;
00831 
00832          ADD_TMP_TO_SHARED_LIST(ATL_FORMAT_TMP(IL_IDX(fmt_list_idx)));
00833 
00834          ADD_TMP_TO_SHARED_LIST(ATL_PP_FORMAT_TMP(IL_IDX(fmt_list_idx)));
00835 
00836       }
00837 
00838       /* if not a format label LRR will have already caught it */
00839    }
00840    else {
00841 
00842       COPY_OPND(opnd, IL_OPND(fmt_list_idx));
00843       exp_desc.rank = 0;
00844       xref_state    = CIF_Symbol_Reference;
00845       io_item_must_flatten = FALSE;
00846       ok = expr_semantics(&opnd, &exp_desc);
00847       COPY_OPND(IL_OPND(fmt_list_idx), opnd);
00848 
00849       /* do format checks */
00850    
00851       find_opnd_line_and_column(&opnd, &line, &col);
00852 
00853       if (exp_desc.type == Character) {
00854 
00855          if (io_item_must_flatten ||
00856              exp_desc.dist_reshape_ref ||
00857              exp_desc.vector_subscript) {
00858 
00859             tmp_idx = create_tmp_asg(&opnd, &exp_desc, &left_opnd, 
00860                                      Intent_In, TRUE, FALSE);
00861             COPY_OPND(IL_OPND(fmt_list_idx), left_opnd);
00862          }
00863       }
00864       else if (exp_desc.rank > 0                                &&
00865                (OPND_FLD(opnd)         != IR_Tbl_Idx ||
00866                 exp_desc.dope_vector                 ||
00867                 IR_OPR(OPND_IDX(opnd)) != Whole_Subscript_Opr)) {
00868   
00869          /* these are noncontiguous arrays, sections, dope vectors */
00870          /* error .. format error */
00871 
00872          PRINTMSG(line, 447, Error, col);
00873       }
00874       else if (exp_desc.type == Integer &&
00875                exp_desc.reference)      {
00876  
00877          if (exp_desc.rank == 0) {    /* check for ASSIGN */
00878 
00879             if (!exp_desc.reference) { /* error .. must be variable */
00880                PRINTMSG(line, 447, Error, col);
00881             }
00882             else if (exp_desc.linear_type != INTEGER_DEFAULT_TYPE) {
00883 
00884                /* must be default kind */
00885 
00886                PRINTMSG(line, 462, Error, col);
00887             }
00888             else {
00889  
00890                attr_idx = find_base_attr(&opnd, &line, &col);
00891 
00892                if (! ATD_IN_ASSIGN(attr_idx)) {
00893                   PRINTMSG(line, 1099, Error, col);
00894                }
00895 
00896 # if defined(GENERATE_WHIRL)
00897                if (ATD_ASSIGN_TMP_IDX(attr_idx) != NULL_IDX) {
00898                   OPND_FLD(opnd) = AT_Tbl_Idx;
00899                   OPND_IDX(opnd) = ATD_ASSIGN_TMP_IDX(attr_idx);
00900                   COPY_OPND(IL_OPND(fmt_list_idx), opnd);
00901                   ADD_TMP_TO_SHARED_LIST(ATD_ASSIGN_TMP_IDX(attr_idx));
00902                }
00903 # endif
00904             }
00905          }
00906          else { /* integer array is nonstandard */
00907             PRINTMSG(line, 778, Ansi, col);
00908          }
00909       }
00910       else if ((exp_desc.linear_type == REAL_DEFAULT_TYPE ||
00911                 exp_desc.type == Logical)                &&
00912                exp_desc.reference                        &&
00913                exp_desc.rank > 0)                        {
00914          PRINTMSG(line, 778, Ansi, col);
00915       }
00916       else if (exp_desc.type == Typeless &&
00917                exp_desc.rank == 0)       {
00918 
00919          /* intentionally blank */
00920          /* ansi msg already issued by lex */
00921       }
00922       else { /* error .. format error */
00923          PRINTMSG(line, 447, Error, col);
00924       }
00925    }
00926 
00927    intern_list_idx = IL_NEXT_LIST_IDX(fmt_list_idx);
00928 
00929    COPY_OPND(opnd, IL_OPND(intern_list_idx));
00930    exp_desc.rank = 0;
00931 
00932    if (stmt_type == Encode_Stmt) {
00933       xref_state = CIF_Symbol_Modification;
00934    }
00935    else {
00936       xref_state = CIF_Symbol_Reference;
00937    }
00938    ok = expr_semantics(&opnd, &exp_desc);
00939    COPY_OPND(IL_OPND(intern_list_idx), opnd);
00940 
00941    /* do internal unit semantics */
00942 
00943    if (stmt_type == Encode_Stmt) {
00944 
00945       /* check for live do loop variable definition for encode */
00946 
00947       if (! check_for_legal_define(&opnd)) {
00948          ok = FALSE;
00949       }
00950    }
00951 
00952    /* internal unit must be variable, array element or contiguous array */
00953 
00954    COPY_OPND(opnd, IL_OPND(intern_list_idx));
00955    find_opnd_line_and_column(&opnd, &line, &col);
00956 
00957    if (OPND_FLD(opnd) == IR_Tbl_Idx &&
00958        IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr) {
00959 
00960       COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
00961    }
00962 
00963    if (OPND_FLD(opnd) == IR_Tbl_Idx &&
00964        (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr ||
00965         IR_OPR(OPND_IDX(opnd)) == Subscript_Opr)) {
00966 
00967       COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
00968    }
00969 
00970    if (OPND_FLD(opnd) != AT_Tbl_Idx) {
00971       /* bad internal unit reference */
00972 
00973       PRINTMSG(line, 1112, Error, col, 
00974                (stmt_type == Encode_Stmt ? "destination" : "source"),
00975                (stmt_type == Encode_Stmt ? "ENCODE" : "DECODE"));
00976 
00977       ok = FALSE;
00978    }
00979    else if (AT_OBJ_CLASS(OPND_IDX(opnd)) != Data_Obj ||
00980             (ATD_CLASS(OPND_IDX(opnd)) != Variable &&
00981              ATD_CLASS(OPND_IDX(opnd)) != Dummy_Argument &&
00982              ATD_CLASS(OPND_IDX(opnd)) != Function_Result) ||
00983             ATD_POINTER(OPND_IDX(opnd)) ||
00984             ATD_ALLOCATABLE(OPND_IDX(opnd))) {
00985 
00986       /* bad internal unit */
00987       PRINTMSG(line, 1112, Error, col, 
00988                (stmt_type == Encode_Stmt ? "destination" : "source"),
00989                (stmt_type == Encode_Stmt ? "ENCODE" : "DECODE"));
00990       ok = FALSE;
00991    }
00992    
00993 
00994    /* put in correct order for pgdcs */
00995 
00996    /******************\
00997    |* start new list *|
00998    \******************/
00999 
01000    IR_IDX_L(ir_idx) = cnt_list_idx;
01001 # ifdef _NO_IO_ALTERNATE_RETURN
01002    IR_LIST_CNT_L(ir_idx) = NUM_PDG_CONTROL_LIST_ITEMS + 3;
01003 # else
01004    IR_LIST_CNT_L(ir_idx) = NUM_PDG_CONTROL_LIST_ITEMS;
01005 # endif
01006 
01007    /**************************\
01008    |* 1 - encode/decode flag *|
01009    \**************************/
01010 
01011    /* this is the cnt opnd */
01012    IL_PREV_LIST_IDX(cnt_list_idx) = NULL_IDX;
01013 
01014    /*********************\
01015    |* 2 - eeeflag value *|
01016    \*********************/
01017 
01018    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(cnt_list_idx));
01019    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(cnt_list_idx)) = cnt_list_idx;
01020    list_idx = IL_NEXT_LIST_IDX(cnt_list_idx);
01021 
01022    IL_FLD(list_idx)     = CN_Tbl_Idx;
01023    IL_IDX(list_idx)     = CN_INTEGER_ZERO_IDX;
01024    IL_LINE_NUM(list_idx) = line;
01025    IL_COL_NUM(list_idx)  = col;
01026 
01027    /**********************\
01028    |* 3 - flflag value   *|
01029    \**********************/
01030 
01031    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01032    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01033    list_idx = IL_NEXT_LIST_IDX(list_idx);
01034 
01035    /* This is the flag for split io */
01036    /* set to FL_IO_SINGLE for now   */
01037 
01038    IL_FLD(list_idx)     = CN_Tbl_Idx;
01039    IL_IDX(list_idx)     = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE);
01040    IL_LINE_NUM(list_idx) = line;
01041    IL_COL_NUM(list_idx)  = col;
01042 
01043 
01044    /**********************\
01045    |* 4 - UNIT specifier *|
01046    \**********************/
01047 
01048    IL_NEXT_LIST_IDX(list_idx) = intern_list_idx;
01049    IL_PREV_LIST_IDX(intern_list_idx) = list_idx;
01050    list_idx = IL_NEXT_LIST_IDX(list_idx);
01051 
01052    /***********************\
01053    |* 5 - IOSTAT variable *|
01054    \***********************/
01055 
01056    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01057    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01058    list_idx = IL_NEXT_LIST_IDX(list_idx);
01059 
01060    /**********************\
01061    |* 6 - REC expression *|
01062    \**********************/
01063 
01064    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01065    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01066    list_idx = IL_NEXT_LIST_IDX(list_idx);
01067 
01068    /*************************\
01069    |* 7 - pre-parsed format *|
01070    \*************************/
01071 
01072    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01073    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01074    list_idx = IL_NEXT_LIST_IDX(list_idx);
01075 
01076    /* get pre-parsed from somewhere */
01077 
01078    if (pp_tmp) {
01079       IL_FLD(list_idx) = AT_Tbl_Idx;
01080       IL_IDX(list_idx) = pp_tmp;
01081       IL_LINE_NUM(list_idx) = line;
01082       IL_COL_NUM(list_idx)  = col;
01083    }
01084 
01085    /*********************\
01086    |* 8 - format source *|
01087    \*********************/
01088 
01089    IL_NEXT_LIST_IDX(list_idx) = fmt_list_idx;
01090    IL_PREV_LIST_IDX(fmt_list_idx) = list_idx;
01091    list_idx = IL_NEXT_LIST_IDX(list_idx);
01092 
01093    /**************************\
01094    |* 9 - ADVANCE expression *|
01095    \**************************/
01096 
01097    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01098    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01099    list_idx = IL_NEXT_LIST_IDX(list_idx);
01100 
01101    /************************\
01102    |* 10 - SIZE expression *|
01103    \************************/
01104 
01105    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01106    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01107    list_idx = IL_NEXT_LIST_IDX(list_idx);
01108    IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
01109 
01110 # ifdef _NO_IO_ALTERNATE_RETURN
01111    /************************\
01112    |* 11 - ERR label       *|
01113    \************************/
01114 
01115    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01116    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01117    list_idx = IL_NEXT_LIST_IDX(list_idx);
01118 
01119    /************************\
01120    |* 12 - END label       *|
01121    \************************/
01122 
01123    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01124    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01125    list_idx = IL_NEXT_LIST_IDX(list_idx);
01126 
01127    /************************\
01128    |* 13 - EOR label       *|
01129    \************************/
01130 
01131    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01132    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01133    list_idx = IL_NEXT_LIST_IDX(list_idx);
01134 # endif
01135 
01136    
01137    /* now do io list */
01138 
01139   
01140    COPY_OPND(opnd, IR_OPND_R(ir_idx));
01141 
01142    defer_stmt_expansion = TRUE;
01143    number_of_functions  = 0;
01144    io_stmt_must_be_split = FALSE;
01145 
01146    if (stmt_type == Decode_Stmt) {
01147       ok = io_list_semantics(&opnd, Decode);
01148    }
01149    else {
01150       ok = io_list_semantics(&opnd, Encode);
01151    }
01152 
01153    COPY_OPND(IR_OPND_R(ir_idx), opnd);
01154 
01155    defer_stmt_expansion = FALSE;
01156 
01157    if (ok                       &&
01158        (number_of_functions > 0 ||
01159         tree_has_constructor    ||
01160         io_stmt_must_be_split   ||
01161         io_item_must_flatten))       {
01162       process_deferred_io_list();
01163    }
01164    else if (ok) {
01165       COPY_OPND(opnd, IR_OPND_R(ir_idx));
01166       gen_runtime_checks(&opnd);
01167    }
01168 
01169    TRACE (Func_Exit, "encode_decode_stmt_semantics", NULL);
01170 
01171    return;
01172 
01173 }  /* encode_decode_stmt_semantics */
01174 
01175 
01176 /******************************************************************************\
01177 |*                                                                            *|
01178 |* Description:                                                               *|
01179 |*      ADD A DESCRIPTION HERE, Brian.                                        *|
01180 |*                                                                            *|
01181 |* Input parameters:                                                          *|
01182 |*      NONE                                                                  *|
01183 |*                                                                            *|
01184 |* Output parameters:                                                         *|
01185 |*      NONE                                                                  *|
01186 |*                                                                            *|
01187 |* Returns:                                                                   *|
01188 |*      NONE                                                                  *|
01189 |*                                                                            *|
01190 \******************************************************************************/
01191 
01192 void endfile_stmt_semantics (void)
01193 
01194 {
01195    int                  ir_idx;
01196    opnd_type            opnd;
01197    int                  save_arg_info_list_base;
01198    int                  save_curr_stmt_sh_idx;
01199    boolean              semantically_correct;
01200 
01201 # ifndef _NO_IO_ALTERNATE_RETURN
01202    int                  alt_return_tmp;
01203    int                  asg_idx;
01204    int                  br_true_idx;
01205    int                  col;
01206    int                  eq_idx;
01207    int                  line;
01208    int                  save_next_sh_idx;
01209 # endif
01210 
01211 
01212    TRACE (Func_Entry, "endfile_stmt_semantics", NULL);
01213 
01214    SCP_DOES_IO(curr_scp_idx) = TRUE;
01215 
01216    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01217 
01218    /* do memory management stuff to make sure the call tables are big enough */
01219 
01220    if (max_call_list_size >= arg_list_size) {
01221       enlarge_call_list_tables();
01222    }
01223 
01224    save_arg_info_list_base = arg_info_list_base;
01225 
01226    arg_info_list_base      = arg_info_list_top;
01227 
01228    arg_info_list_top       = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
01229 
01230    if (arg_info_list_top >= arg_info_list_size) {
01231       enlarge_info_list_table();
01232    }
01233 
01234 # ifndef _NO_IO_ALTERNATE_RETURN
01235    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01236 # endif
01237 
01238    COPY_OPND(opnd, IR_OPND_R(ir_idx));
01239    semantically_correct = io_ctl_list_semantics(&opnd, Endfile, TRUE);
01240    COPY_OPND(IR_OPND_R(ir_idx), opnd);
01241 
01242    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01243 
01244 # ifndef _NO_IO_ALTERNATE_RETURN
01245    if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
01246 
01247       line = IR_LINE_NUM(ir_idx);
01248       col  = IR_COL_NUM(ir_idx);
01249 
01250       alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
01251       ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
01252       ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
01253       AT_REFERENCED(alt_return_tmp)     = Referenced;
01254       AT_DEFINED(alt_return_tmp)        = TRUE;
01255       AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01256 
01257       NTR_IR_TBL(asg_idx);
01258       IR_OPR(asg_idx)        = Alt_Return_Opr;
01259       IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
01260       IR_LINE_NUM(asg_idx)   = line;
01261       IR_COL_NUM(asg_idx)    = col;
01262       IR_LINE_NUM_L(asg_idx) = line;
01263       IR_COL_NUM_L(asg_idx)  = col;
01264       IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
01265       IR_IDX_L(asg_idx)      = alt_return_tmp;
01266       IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
01267       IR_IDX_R(asg_idx)      = ir_idx;
01268 
01269       SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
01270 
01271       if (err_list_idx) {
01272          NTR_IR_TBL(br_true_idx);
01273          IR_OPR(br_true_idx)      = Br_True_Opr;
01274          IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
01275          IR_LINE_NUM(br_true_idx) = line;
01276          IR_COL_NUM(br_true_idx)  = col;
01277 
01278          NTR_IR_TBL(eq_idx);
01279          IR_OPR(eq_idx)           = Eq_Opr;
01280          IR_TYPE_IDX(eq_idx)      = LOGICAL_DEFAULT_TYPE;
01281          IR_LINE_NUM(eq_idx)      = line;
01282          IR_COL_NUM(eq_idx)       = col;
01283          IR_FLD_L(eq_idx)         = AT_Tbl_Idx;
01284          IR_IDX_L(eq_idx)         = alt_return_tmp;
01285          IR_LINE_NUM_L(eq_idx)    = line;
01286          IR_COL_NUM_L(eq_idx)     = col;
01287 
01288          IR_FLD_R(eq_idx)         = CN_Tbl_Idx;
01289          IR_IDX_R(eq_idx)         = CN_INTEGER_ONE_IDX;
01290          IR_LINE_NUM_R(eq_idx)    = line;
01291          IR_COL_NUM_R(eq_idx)     = col;
01292 
01293          IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
01294          IR_IDX_L(br_true_idx)    = eq_idx;
01295 
01296          COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
01297 
01298          curr_stmt_sh_idx = save_next_sh_idx;
01299 
01300          gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
01301 
01302          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = br_true_idx;
01303          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01304 
01305          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01306       }
01307    }
01308 # endif
01309 
01310    if (semantically_correct) {
01311       COPY_OPND(opnd, IR_OPND_R(ir_idx));
01312       semantically_correct = final_arg_work(&opnd,
01313                                             IR_IDX_L(ir_idx),
01314                                             IR_LIST_CNT_R(ir_idx),
01315                                             NULL);
01316       COPY_OPND(IR_OPND_R(ir_idx), opnd);
01317 # if defined(_FILE_IO_OPRS)
01318       IR_OPR(ir_idx) = Endfile_Opr;
01319 # endif
01320    }
01321 
01322 # ifdef _NO_IO_ALTERNATE_RETURN
01323    add_alt_return_lbl(ir_idx, err_attr_idx);
01324 # endif
01325 
01326    /* restore arg_info_list to previous "stack frame" */
01327 
01328    arg_info_list_top  = arg_info_list_base;
01329    arg_info_list_base = save_arg_info_list_base;
01330 
01331    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01332 
01333    TRACE (Func_Exit, "endfile_stmt_semantics", NULL);
01334 
01335    return;
01336 
01337 }  /* endfile_stmt_semantics */
01338 
01339 
01340 /******************************************************************************\
01341 |*                                                                            *|
01342 |* Description:                                                               *|
01343 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
01344 |*                                                                            *|
01345 |* Input parameters:                                                          *|
01346 |*      NONE                                                                  *|
01347 |*                                                                            *|
01348 |* Output parameters:                                                         *|
01349 |*      NONE                                                                  *|
01350 |*                                                                            *|
01351 |* Returns:                                                                   *|
01352 |*      NONE                                                                  *|
01353 |*                                                                            *|
01354 \******************************************************************************/
01355 
01356 void inquire_stmt_semantics (void)
01357 
01358 { 
01359    int                  asg_idx;
01360    int                  attr_idx;
01361    int                  col;
01362    expr_arg_type        exp_desc;
01363    int                  ir_idx;
01364    int                  line;
01365    int                  list_idx;
01366    opnd_type            opnd;
01367    int                  save_arg_info_list_base;
01368    int                  save_curr_stmt_sh_idx;
01369    boolean              semantically_correct;
01370    int                  tmp_idx;
01371 
01372 # ifndef _NO_IO_ALTERNATE_RETURN
01373    int                  alt_return_tmp;
01374    int                  br_true_idx;
01375    int                  eq_idx;
01376    int                  save_next_sh_idx;
01377 # endif
01378 
01379 
01380    TRACE (Func_Entry, "inquire_stmt_semantics", NULL);
01381 
01382    SCP_DOES_IO(curr_scp_idx) = TRUE;
01383 
01384    ir_idx       = SH_IR_IDX(curr_stmt_sh_idx);
01385    line         = IR_LINE_NUM(ir_idx);
01386    col          = IR_COL_NUM(ir_idx);
01387 
01388    /* do memory management stuff to make sure the call tables are big enough */
01389 
01390    if (max_call_list_size >= arg_list_size) {
01391       enlarge_call_list_tables();
01392    }
01393 
01394    save_arg_info_list_base = arg_info_list_base;
01395 
01396    arg_info_list_base      = arg_info_list_top;
01397 
01398    arg_info_list_top       = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
01399 
01400    if (arg_info_list_top >= arg_info_list_size) {
01401       enlarge_info_list_table();
01402    }
01403 
01404    if (IR_OPR(ir_idx) == Call_Opr) {
01405 
01406 # ifndef _NO_IO_ALTERNATE_RETURN
01407       save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01408 # endif
01409 
01410       COPY_OPND(opnd, IR_OPND_R(ir_idx));
01411       semantically_correct = io_ctl_list_semantics(&opnd, Inquire, TRUE);
01412       COPY_OPND(IR_OPND_R(ir_idx), opnd);
01413 
01414       save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01415 
01416 # ifndef _NO_IO_ALTERNATE_RETURN
01417       if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
01418 
01419 
01420          alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
01421          ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
01422          ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
01423          AT_REFERENCED(alt_return_tmp)     = Referenced;
01424          AT_DEFINED(alt_return_tmp)        = TRUE;
01425          AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01426 
01427          NTR_IR_TBL(asg_idx);
01428          IR_OPR(asg_idx)        = Alt_Return_Opr;
01429          IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
01430          IR_LINE_NUM(asg_idx)   = line;
01431          IR_COL_NUM(asg_idx)    = col;
01432          IR_LINE_NUM_L(asg_idx) = line;
01433          IR_COL_NUM_L(asg_idx)  = col;
01434          IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
01435          IR_IDX_L(asg_idx)      = alt_return_tmp;
01436          IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
01437          IR_IDX_R(asg_idx)      = ir_idx;
01438 
01439          SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
01440 
01441          if (err_list_idx) {
01442             NTR_IR_TBL(br_true_idx);
01443             IR_OPR(br_true_idx)      = Br_True_Opr;
01444             IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
01445             IR_LINE_NUM(br_true_idx) = line;
01446             IR_COL_NUM(br_true_idx)  = col;
01447    
01448             NTR_IR_TBL(eq_idx);
01449             IR_OPR(eq_idx)           = Eq_Opr;
01450             IR_TYPE_IDX(eq_idx)      = LOGICAL_DEFAULT_TYPE;
01451             IR_LINE_NUM(eq_idx)      = line;
01452             IR_COL_NUM(eq_idx)       = col;
01453             IR_FLD_L(eq_idx)         = AT_Tbl_Idx;
01454             IR_IDX_L(eq_idx)         = alt_return_tmp;
01455             IR_LINE_NUM_L(eq_idx)    = line;
01456             IR_COL_NUM_L(eq_idx)     = col;
01457 
01458             IR_FLD_R(eq_idx)         = CN_Tbl_Idx;
01459             IR_IDX_R(eq_idx)         = CN_INTEGER_ONE_IDX;
01460             IR_LINE_NUM_R(eq_idx)    = line;
01461             IR_COL_NUM_R(eq_idx)     = col;
01462 
01463             IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
01464             IR_IDX_L(br_true_idx)    = eq_idx;
01465 
01466             COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
01467 
01468             curr_stmt_sh_idx = save_next_sh_idx;
01469 
01470             gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
01471 
01472             SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = br_true_idx;
01473             SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01474 
01475             curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01476          }
01477       }
01478 # endif
01479 
01480       if (semantically_correct) {
01481          COPY_OPND(opnd, IR_OPND_R(ir_idx));
01482          semantically_correct = final_arg_work(&opnd,
01483                                                IR_IDX_L(ir_idx),
01484                                                IR_LIST_CNT_R(ir_idx),
01485                                                NULL);
01486          COPY_OPND(IR_OPND_R(ir_idx), opnd);
01487          create_io_call_descriptor(ir_idx, Inquire_Desc);
01488 # if defined(_FILE_IO_OPRS)
01489          IR_OPR(ir_idx) = Inquire_Opr;
01490 # endif
01491       }
01492 
01493 # ifdef _NO_IO_ALTERNATE_RETURN
01494       add_alt_return_lbl(ir_idx, err_attr_idx);
01495 # endif
01496 
01497       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01498    }
01499    else {
01500 
01501       /* have IOLENGTH */
01502 
01503       NTR_IR_TBL(asg_idx);
01504       IR_OPR(asg_idx)             = Asg_Opr;
01505       IR_TYPE_IDX(asg_idx)        = CG_INTEGER_DEFAULT_TYPE;
01506       IR_LINE_NUM(asg_idx)        = IR_LINE_NUM(ir_idx);
01507       IR_COL_NUM(asg_idx)         = IR_COL_NUM(ir_idx);
01508       SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01509       IR_FLD_R(asg_idx)           = IR_Tbl_Idx;
01510       IR_IDX_R(asg_idx)           = ir_idx;
01511 
01512       /* put in correct order for pgdcs */
01513 
01514       list_idx = IR_IDX_L(ir_idx);
01515 
01516       /**********************\
01517       |* iolength variable  *|
01518       \**********************/
01519 
01520       
01521       COPY_OPND(opnd, IL_OPND(list_idx));
01522       exp_desc.rank = 0;
01523       xref_state    = CIF_Symbol_Modification;
01524       semantically_correct = expr_semantics(&opnd, &exp_desc);
01525       COPY_OPND(IR_OPND_L(asg_idx), opnd);
01526 
01527 
01528       if (exp_desc.rank != 0                       ||
01529           !exp_desc.reference                      ||
01530           exp_desc.type != Integer                 ||
01531           exp_desc.linear_type != INTEGER_DEFAULT_TYPE) {
01532 
01533          find_opnd_line_and_column(&opnd, &line, &col);
01534          PRINTMSG(line, 483, Error, col);
01535          semantically_correct = FALSE;
01536       }
01537       else if (! check_for_legal_define(&opnd)) {
01538          semantically_correct = FALSE;
01539       }
01540       else {
01541 
01542          attr_idx = find_left_attr(&opnd);
01543 
01544          /* create tmp for iolength */
01545 
01546          tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
01547          ATD_TYPE_IDX(tmp_idx) = ATD_TYPE_IDX(attr_idx);
01548          ATD_STOR_BLK_IDX(tmp_idx)  = SCP_SB_STACK_IDX(curr_scp_idx);
01549          AT_SEMANTICS_DONE(tmp_idx) = TRUE;
01550 
01551          IR_FLD_L(asg_idx) = AT_Tbl_Idx;
01552          IR_IDX_L(asg_idx) = tmp_idx;
01553          IR_LINE_NUM_L(asg_idx) = IR_LINE_NUM(ir_idx);
01554          IR_COL_NUM_L(asg_idx)  = IR_COL_NUM(ir_idx);
01555 
01556 
01557          /* gen the assignment to the iolength variable */
01558 
01559          NTR_IR_TBL(asg_idx);
01560          IR_OPR(asg_idx) = Asg_Opr;
01561          IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
01562          IR_LINE_NUM(asg_idx) = line;
01563          IR_COL_NUM(asg_idx)  = col;
01564 
01565          COPY_OPND(IR_OPND_L(asg_idx), opnd);
01566          IR_FLD_R(asg_idx) = AT_Tbl_Idx;
01567          IR_IDX_R(asg_idx) = tmp_idx;
01568          IR_LINE_NUM_R(asg_idx) = line;
01569          IR_COL_NUM_R(asg_idx)  = col;
01570 
01571          gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
01572 
01573          SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
01574          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
01575 
01576          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
01577 
01578       }
01579 
01580 
01581       /******************\
01582       |* flflag value   *|
01583       \******************/
01584 
01585       /* This is the flag for split io */
01586       /* set to FL_IO_SINGLE for now   */
01587 
01588 
01589       IL_FLD(list_idx)     = CN_Tbl_Idx;
01590       IL_IDX(list_idx)     = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE);
01591       IL_LINE_NUM(list_idx) = line;
01592       IL_COL_NUM(list_idx)  = col;
01593 
01594       /*******************\
01595       |* io list is next *|
01596       \*******************/
01597 
01598       defer_stmt_expansion = TRUE;
01599       number_of_functions  = 0;
01600       io_stmt_must_be_split = FALSE;
01601 
01602       COPY_OPND(opnd, IR_OPND_R(ir_idx));
01603       semantically_correct = io_list_semantics(&opnd, Inquire) &&
01604                              semantically_correct;
01605       COPY_OPND(IR_OPND_R(ir_idx), opnd);
01606 
01607       defer_stmt_expansion = FALSE;
01608 
01609       if (semantically_correct     &&
01610           (number_of_functions > 0 ||
01611            tree_has_constructor    ||
01612            io_stmt_must_be_split   ||
01613            io_item_must_flatten))       {
01614          process_deferred_io_list();
01615       }
01616       else if (semantically_correct) {
01617          COPY_OPND(opnd, IR_OPND_R(ir_idx));
01618          gen_runtime_checks(&opnd);
01619       }
01620    }
01621 
01622    /* restore arg_info_list to previous "stack frame" */
01623 
01624    arg_info_list_top  = arg_info_list_base;
01625    arg_info_list_base = save_arg_info_list_base;
01626 
01627    TRACE (Func_Exit, "inquire_stmt_semantics", NULL);
01628 
01629    return;
01630 
01631 }  /* inquire_stmt_semantics */
01632 
01633 
01634 /******************************************************************************\
01635 |*                                                                            *|
01636 |* Description:                                                               *|
01637 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
01638 |*                                                                            *|
01639 |* Input parameters:                                                          *|
01640 |*      NONE                                                                  *|
01641 |*                                                                            *|
01642 |* Output parameters:                                                         *|
01643 |*      NONE                                                                  *|
01644 |*                                                                            *|
01645 |* Returns:                                                                   *|
01646 |*      NONE                                                                  *|
01647 |*                                                                            *|
01648 \******************************************************************************/
01649 
01650 void open_stmt_semantics (void)
01651 
01652 {
01653    int                  ir_idx;
01654    opnd_type            opnd;
01655    int                  save_arg_info_list_base;
01656    int                  save_curr_stmt_sh_idx;
01657    boolean              semantically_correct;
01658 
01659 # ifndef _NO_IO_ALTERNATE_RETURN
01660    int                  alt_return_tmp;
01661    int                  asg_idx;
01662    int                  br_true_idx;
01663    int                  col;
01664    int                  eq_idx;
01665    int                  line;
01666    int                  save_next_sh_idx;
01667 # endif
01668 
01669    
01670    TRACE (Func_Entry, "open_stmt_semantics", NULL);
01671 
01672    SCP_DOES_IO(curr_scp_idx) = TRUE;
01673 
01674    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01675 
01676    /* do memory management stuff to make sure the call tables are big enough */
01677 
01678    if (max_call_list_size >= arg_list_size) {
01679       enlarge_call_list_tables();
01680    }
01681 
01682    save_arg_info_list_base = arg_info_list_base;
01683 
01684    arg_info_list_base      = arg_info_list_top;
01685 
01686    arg_info_list_top       = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
01687 
01688    if (arg_info_list_top >= arg_info_list_size) {
01689       enlarge_info_list_table();
01690    }
01691 
01692 # ifndef _NO_IO_ALTERNATE_RETURN
01693    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01694 # endif
01695 
01696    COPY_OPND(opnd, IR_OPND_R(ir_idx));
01697    semantically_correct = io_ctl_list_semantics(&opnd, Open, TRUE);
01698    COPY_OPND(IR_OPND_R(ir_idx), opnd);
01699 
01700    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01701 
01702 # ifndef _NO_IO_ALTERNATE_RETURN
01703    if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
01704 
01705       line = IR_LINE_NUM(ir_idx);
01706       col  = IR_COL_NUM(ir_idx);
01707 
01708       alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
01709       ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
01710       ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
01711       AT_REFERENCED(alt_return_tmp)     = Referenced;
01712       AT_DEFINED(alt_return_tmp)        = TRUE;
01713       AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01714 
01715       NTR_IR_TBL(asg_idx);
01716       IR_OPR(asg_idx)        = Alt_Return_Opr;
01717       IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
01718       IR_LINE_NUM(asg_idx)   = line;
01719       IR_COL_NUM(asg_idx)    = col;
01720       IR_LINE_NUM_L(asg_idx) = line;
01721       IR_COL_NUM_L(asg_idx)  = col;
01722       IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
01723       IR_IDX_L(asg_idx)      = alt_return_tmp;
01724       IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
01725       IR_IDX_R(asg_idx)      = ir_idx;
01726 
01727       SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
01728 
01729       if (err_list_idx) {
01730          NTR_IR_TBL(br_true_idx);
01731          IR_OPR(br_true_idx)      = Br_True_Opr;
01732          IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
01733          IR_LINE_NUM(br_true_idx) = line;
01734          IR_COL_NUM(br_true_idx)  = col;
01735 
01736          NTR_IR_TBL(eq_idx);
01737          IR_OPR(eq_idx)           = Eq_Opr;
01738          IR_TYPE_IDX(eq_idx)      = LOGICAL_DEFAULT_TYPE;
01739          IR_LINE_NUM(eq_idx)      = line;
01740          IR_COL_NUM(eq_idx)       = col;
01741          IR_FLD_L(eq_idx)         = AT_Tbl_Idx;
01742          IR_IDX_L(eq_idx)         = alt_return_tmp;
01743          IR_LINE_NUM_L(eq_idx)    = line;
01744          IR_COL_NUM_L(eq_idx)     = col;
01745 
01746          IR_FLD_R(eq_idx)         = CN_Tbl_Idx;
01747          IR_IDX_R(eq_idx)         = CN_INTEGER_ONE_IDX;
01748          IR_LINE_NUM_R(eq_idx)    = line;
01749          IR_COL_NUM_R(eq_idx)     = col;
01750 
01751          IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
01752          IR_IDX_L(br_true_idx)    = eq_idx;
01753 
01754          COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
01755 
01756          curr_stmt_sh_idx = save_next_sh_idx;
01757 
01758          gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
01759 
01760          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = br_true_idx;
01761          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01762 
01763          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01764       }
01765    }
01766 # endif
01767 
01768    if (semantically_correct) {
01769       COPY_OPND(opnd, IR_OPND_R(ir_idx));
01770       semantically_correct = final_arg_work(&opnd,
01771                                             IR_IDX_L(ir_idx),
01772                                             IR_LIST_CNT_R(ir_idx),
01773                                             NULL);
01774       COPY_OPND(IR_OPND_R(ir_idx), opnd);
01775       create_io_call_descriptor(ir_idx, Open_Desc);
01776 # if defined(_FILE_IO_OPRS)
01777       IR_OPR(ir_idx) = Open_Opr;
01778 # endif
01779    }
01780 
01781 # ifdef _NO_IO_ALTERNATE_RETURN
01782    add_alt_return_lbl(ir_idx, err_attr_idx);
01783 # endif
01784 
01785    /* restore arg_info_list to previous "stack frame" */
01786 
01787    arg_info_list_top  = arg_info_list_base;
01788    arg_info_list_base = save_arg_info_list_base;
01789 
01790    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01791 
01792    TRACE (Func_Exit, "open_stmt_semantics", NULL);
01793 
01794    return;
01795 
01796 }  /* open_stmt_semantics */
01797 
01798 
01799 /******************************************************************************\
01800 |*                                                                            *|
01801 |* Description:                                                               *|
01802 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
01803 |*                                                                            *|
01804 |* Input parameters:                                                          *|
01805 |*      NONE                                                                  *|
01806 |*                                                                            *|
01807 |* Output parameters:                                                         *|
01808 |*      NONE                                                                  *|
01809 |*                                                                            *|
01810 |* Returns:                                                                   *|
01811 |*      NONE                                                                  *|
01812 |*                                                                            *|
01813 \******************************************************************************/
01814 
01815 void print_stmt_semantics (void)
01816 
01817 {
01818    int                  col;
01819    int                  ir_idx;
01820    int                  line;
01821    int                  list_idx;
01822    int                  loc_idx;
01823    opnd_type            opnd;
01824    boolean              semantically_correct;
01825 
01826 
01827    TRACE (Func_Entry, "print_stmt_semantics", NULL);
01828 
01829    SCP_DOES_IO(curr_scp_idx) = TRUE;
01830 
01831    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01832 
01833    COPY_OPND(opnd, IR_OPND_L(ir_idx));
01834    semantically_correct = io_ctl_list_semantics(&opnd, Print, FALSE);
01835    COPY_OPND(IR_OPND_L(ir_idx), opnd);
01836 
01837    if (is_namelist) {
01838 
01839       if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) {
01840          find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)),
01841                                    &line,
01842                                    &col);
01843          PRINTMSG(line, 444, Error, col);
01844       }
01845 
01846       if (namelist_descriptor_attr) {
01847 
01848 # if 0
01849         /* call the namelist table dump routine */
01850 
01851         {int    _call_idx, _list_idx, _loc_idx;
01852          int    _dump_nml_idx;
01853         _dump_nml_idx = create_lib_entry_attr("DUMP_NML",
01854                                             8,
01855                                             stmt_start_line,
01856                                             stmt_start_col);
01857 
01858         ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx);
01859    
01860         NTR_IR_TBL(_call_idx);
01861         IR_OPR(_call_idx) = Call_Opr;
01862         IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE;
01863         IR_LINE_NUM(_call_idx) = stmt_start_line;
01864         IR_COL_NUM(_call_idx) = stmt_start_col;
01865         IR_FLD_L(_call_idx) = AT_Tbl_Idx;
01866         IR_IDX_L(_call_idx) = _dump_nml_idx;
01867         IR_LINE_NUM_L(_call_idx) = stmt_start_line;
01868         IR_COL_NUM_L(_call_idx) = stmt_start_col;
01869    
01870         NTR_IR_LIST_TBL(_list_idx);
01871         IR_FLD_R(_call_idx) = IL_Tbl_Idx;
01872         IR_IDX_R(_call_idx) = _list_idx;
01873         IR_LIST_CNT_R(_call_idx) = 1;
01874    
01875         NTR_IR_TBL(_loc_idx);
01876         IR_OPR(_loc_idx) = Aloc_Opr;
01877         IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8;
01878         IR_LINE_NUM(_loc_idx) = stmt_start_line;
01879         IR_COL_NUM(_loc_idx)  = stmt_start_col;
01880         IL_FLD(_list_idx) = IR_Tbl_Idx;
01881         IL_IDX(_list_idx) = _loc_idx;
01882    
01883         IR_FLD_L(_loc_idx) = AT_Tbl_Idx;
01884         IR_IDX_L(_loc_idx) = namelist_descriptor_attr;
01885         IR_LINE_NUM_L(_loc_idx) = stmt_start_line;
01886         IR_COL_NUM_L(_loc_idx)  = stmt_start_col;
01887    
01888         gen_sh(Before, Call_Stmt, stmt_start_line,
01889                 stmt_start_col, FALSE, FALSE, TRUE);
01890    
01891         SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = _call_idx;
01892         SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01893         }
01894    
01895 # endif
01896          NTR_IR_LIST_TBL(list_idx);
01897          IR_FLD_R(ir_idx)               = IL_Tbl_Idx;
01898          IR_LIST_CNT_R(ir_idx)          = 1;
01899          IR_IDX_R(ir_idx)               = list_idx;
01900          NTR_IR_TBL(loc_idx);
01901          IR_OPR(loc_idx)                = Loc_Opr;
01902          IR_TYPE_IDX(loc_idx)           = CRI_Ptr_8;
01903          IR_LINE_NUM(loc_idx)           = stmt_start_line;
01904          IR_COL_NUM(loc_idx)            = stmt_start_col;
01905          IR_FLD_L(loc_idx)              = AT_Tbl_Idx;
01906          IR_IDX_L(loc_idx)              = namelist_descriptor_attr;
01907          IR_LINE_NUM_L(loc_idx)         = stmt_start_line;
01908          IR_COL_NUM_L(loc_idx)          = stmt_start_col;
01909          IL_FLD(list_idx)               = IR_Tbl_Idx;
01910          IL_IDX(list_idx)               = loc_idx;
01911       }
01912    }
01913    else {
01914       defer_stmt_expansion = TRUE;
01915       number_of_functions  = 0;
01916       io_stmt_must_be_split = FALSE;
01917 
01918       COPY_OPND(opnd, IR_OPND_R(ir_idx));
01919       semantically_correct = io_list_semantics(&opnd, Print) &&
01920                              semantically_correct;
01921       COPY_OPND(IR_OPND_R(ir_idx), opnd);
01922 
01923       defer_stmt_expansion = FALSE;
01924 
01925       if (semantically_correct     &&
01926           (number_of_functions > 0 ||
01927            tree_has_constructor    ||
01928            io_stmt_must_be_split   ||
01929            io_item_must_flatten))       {
01930          process_deferred_io_list();
01931       }
01932       else if (semantically_correct) {
01933          COPY_OPND(opnd, IR_OPND_R(ir_idx));
01934          gen_runtime_checks(&opnd);
01935       }
01936    }
01937 
01938    TRACE (Func_Exit, "print_stmt_semantics", NULL);
01939 
01940    return;
01941 
01942 }  /* print_stmt_semantics */
01943 
01944 
01945 /******************************************************************************\
01946 |*                                                                            *|
01947 |* Description:                                                               *|
01948 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
01949 |*                                                                            *|
01950 |* Input parameters:                                                          *|
01951 |*      NONE                                                                  *|
01952 |*                                                                            *|
01953 |* Output parameters:                                                         *|
01954 |*      NONE                                                                  *|
01955 |*                                                                            *|
01956 |* Returns:                                                                   *|
01957 |*      NONE                                                                  *|
01958 |*                                                                            *|
01959 \******************************************************************************/
01960 
01961 void read_stmt_semantics (void)
01962 
01963 {
01964    int                  col;
01965    int                  ir_idx;
01966    int                  line;
01967    int                  list_idx;
01968    int                  loc_idx;
01969    opnd_type            opnd;
01970    boolean              semantically_correct;
01971 
01972 # ifndef _NO_IO_ALTERNATE_RETURN
01973    int                  alt_return_tmp;
01974    int                  asg_idx;
01975    int                  br_idx_idx = NULL_IDX;
01976    int                  br_true_idx;
01977    int                  drop_thru_label_idx;
01978    int                  jump_out_label;
01979    int                  lab_idx;
01980    int                  ne_idx;
01981    int                  save_next_sh_idx;
01982    int                  save_curr_stmt_sh_idx;
01983 # endif
01984 
01985    
01986    TRACE (Func_Entry, "read_stmt_semantics", NULL);
01987 
01988    SCP_DOES_IO(curr_scp_idx) = TRUE;
01989 
01990 # ifndef _NO_IO_ALTERNATE_RETURN
01991    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01992    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01993 # endif
01994 
01995    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01996 
01997    COPY_OPND(opnd, IR_OPND_L(ir_idx));
01998    semantically_correct = io_ctl_list_semantics(&opnd, Read, FALSE);
01999    COPY_OPND(IR_OPND_L(ir_idx), opnd);
02000 
02001    line = IR_LINE_NUM(ir_idx);
02002    col  = IR_COL_NUM(ir_idx);
02003 
02004 # ifndef _NO_IO_ALTERNATE_RETURN
02005    if (have_iostat              ||
02006        end_list_idx != NULL_IDX ||
02007        err_list_idx != NULL_IDX ||
02008        eor_list_idx != NULL_IDX) {
02009 
02010       if (end_list_idx == NULL_IDX ||
02011           err_list_idx == NULL_IDX ||
02012           eor_list_idx == NULL_IDX) {
02013 
02014          /* generate a label for drop through branch */
02015 
02016          drop_thru_label_idx = gen_internal_lbl(stmt_start_line);
02017 
02018          curr_stmt_sh_idx = save_next_sh_idx;
02019 
02020          gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
02021 
02022          NTR_IR_TBL(lab_idx);
02023          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = lab_idx;
02024          IR_OPR(lab_idx)                          = Label_Opr;
02025          IR_TYPE_IDX(lab_idx)                     = TYPELESS_DEFAULT_TYPE;
02026          IR_LINE_NUM(lab_idx)                     = line;
02027          IR_COL_NUM(lab_idx)                      = col;
02028          IR_FLD_L(lab_idx)                        = AT_Tbl_Idx;
02029          IR_IDX_L(lab_idx)                        = drop_thru_label_idx;
02030          IR_COL_NUM_L(lab_idx)                    = col;
02031          IR_LINE_NUM_L(lab_idx)                   = line;
02032 
02033          AT_DEFINED(drop_thru_label_idx)       = TRUE;
02034          ATL_DEF_STMT_IDX(drop_thru_label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
02035 
02036          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02037          save_next_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02038         
02039          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02040       }
02041 
02042       alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
02043       ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
02044       ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
02045       AT_REFERENCED(alt_return_tmp)     = Referenced;
02046       AT_DEFINED(alt_return_tmp)        = TRUE;
02047       AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
02048 
02049       NTR_IR_TBL(asg_idx);
02050       IR_OPR(asg_idx)        = Alt_Return_Opr;
02051       IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
02052       IR_LINE_NUM(asg_idx)   = line;
02053       IR_COL_NUM(asg_idx)    = col;
02054       IR_LINE_NUM_L(asg_idx) = line;
02055       IR_COL_NUM_L(asg_idx)  = col;
02056       IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
02057       IR_IDX_L(asg_idx)      = alt_return_tmp;
02058 
02059       IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
02060       IR_IDX_R(asg_idx)      = ir_idx;
02061 
02062       SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
02063 
02064       NTR_IR_TBL(br_idx_idx);
02065       IR_OPR(br_idx_idx) = Br_Index_Opr;
02066       IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE;
02067 
02068       IR_FLD_L(br_idx_idx)            = AT_Tbl_Idx;
02069       IR_IDX_L(br_idx_idx)            = alt_return_tmp;
02070       IR_LINE_NUM(br_idx_idx)         = line;
02071       IR_COL_NUM(br_idx_idx)          = col;
02072       IR_LINE_NUM_L(br_idx_idx)       = line;
02073       IR_COL_NUM_L(br_idx_idx)        = col;
02074       IR_FLD_R(br_idx_idx)            = IL_Tbl_Idx;
02075       IR_LIST_CNT_R(br_idx_idx)       = 3;
02076 
02077       NTR_IR_LIST_TBL(list_idx);
02078       IR_IDX_R(br_idx_idx)            = list_idx;
02079 
02080       if (err_list_idx) {
02081          COPY_OPND(IL_OPND(list_idx), IL_OPND(err_list_idx));
02082       }
02083       else {
02084          IL_FLD(list_idx) = AT_Tbl_Idx;
02085          IL_IDX(list_idx) = drop_thru_label_idx;
02086          IL_LINE_NUM(list_idx) = line;
02087          IL_COL_NUM(list_idx)  = col;
02088       }
02089 
02090       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02091       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02092       list_idx = IL_NEXT_LIST_IDX(list_idx);
02093 
02094       if (end_list_idx) {
02095          COPY_OPND(IL_OPND(list_idx), IL_OPND(end_list_idx));
02096       }
02097       else {
02098          IL_FLD(list_idx) = AT_Tbl_Idx;
02099          IL_IDX(list_idx) = drop_thru_label_idx;
02100          IL_LINE_NUM(list_idx) = line;
02101          IL_COL_NUM(list_idx)  = col;
02102       }
02103 
02104       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02105       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02106       list_idx = IL_NEXT_LIST_IDX(list_idx);
02107 
02108       if (eor_list_idx) {
02109          COPY_OPND(IL_OPND(list_idx), IL_OPND(eor_list_idx));
02110       }
02111       else {
02112          IL_FLD(list_idx) = AT_Tbl_Idx;
02113          IL_IDX(list_idx) = drop_thru_label_idx;
02114          IL_LINE_NUM(list_idx) = line;
02115          IL_COL_NUM(list_idx)  = col;
02116       }
02117 
02118       curr_stmt_sh_idx = save_next_sh_idx;
02119 
02120       gen_sh(Before, If_Stmt, line, col, FALSE, TRUE, TRUE);
02121       curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02122       SH_IR_IDX(curr_stmt_sh_idx) = br_idx_idx;
02123       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02124 
02125       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02126 
02127    }
02128 # endif
02129 
02130    if (is_namelist) {
02131 
02132       if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) {
02133          find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)),
02134                                    &line,
02135                                    &col);
02136          PRINTMSG(line, 444, Error, col);
02137       }
02138 
02139       if (namelist_descriptor_attr) {
02140 # if 0
02141         /* call the namelist table dump routine */
02142 
02143         {int    _call_idx, _list_idx, _loc_idx;
02144          int    _dump_nml_idx;
02145         _dump_nml_idx = create_lib_entry_attr("DUMP_NML",
02146                                             8,
02147                                             stmt_start_line,
02148                                             stmt_start_col);
02149 
02150         ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx);
02151    
02152         NTR_IR_TBL(_call_idx);
02153         IR_OPR(_call_idx) = Call_Opr;
02154         IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE;
02155         IR_LINE_NUM(_call_idx) = stmt_start_line;
02156         IR_COL_NUM(_call_idx) = stmt_start_col;
02157         IR_FLD_L(_call_idx) = AT_Tbl_Idx;
02158         IR_IDX_L(_call_idx) = _dump_nml_idx;
02159         IR_LINE_NUM_L(_call_idx) = stmt_start_line;
02160         IR_COL_NUM_L(_call_idx) = stmt_start_col;
02161    
02162         NTR_IR_LIST_TBL(_list_idx);
02163         IR_FLD_R(_call_idx) = IL_Tbl_Idx;
02164         IR_IDX_R(_call_idx) = _list_idx;
02165         IR_LIST_CNT_R(_call_idx) = 1;
02166    
02167         NTR_IR_TBL(_loc_idx);
02168         IR_OPR(_loc_idx) = Aloc_Opr;
02169         IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8;
02170         IR_LINE_NUM(_loc_idx) = stmt_start_line;
02171         IR_COL_NUM(_loc_idx) = stmt_start_col;
02172         IL_FLD(_list_idx) = IR_Tbl_Idx;
02173         IL_IDX(_list_idx) = _loc_idx;
02174    
02175         IR_FLD_L(_loc_idx) = AT_Tbl_Idx;
02176         IR_IDX_L(_loc_idx) = namelist_descriptor_attr;
02177         IR_LINE_NUM_L(_loc_idx) = stmt_start_line;
02178         IR_COL_NUM_L(_loc_idx) = stmt_start_col;
02179   
02180         gen_sh(Before, Call_Stmt, stmt_start_line,
02181                 stmt_start_col, FALSE, FALSE, TRUE);
02182   
02183         SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = _call_idx;
02184         SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02185         }
02186 
02187  # endif
02188 
02189          NTR_IR_LIST_TBL(list_idx);
02190          IR_FLD_R(ir_idx)               = IL_Tbl_Idx;
02191          IR_LIST_CNT_R(ir_idx)          = 1;
02192          IR_IDX_R(ir_idx)               = list_idx;
02193          NTR_IR_TBL(loc_idx);
02194          IR_OPR(loc_idx)                = Loc_Opr;
02195          IR_TYPE_IDX(loc_idx)           = CRI_Ptr_8;
02196          IR_LINE_NUM(loc_idx)           = stmt_start_line;
02197          IR_COL_NUM(loc_idx)            = stmt_start_col;
02198          IR_FLD_L(loc_idx)              = AT_Tbl_Idx;
02199          IR_IDX_L(loc_idx)              = namelist_descriptor_attr;
02200          IR_LINE_NUM_L(loc_idx)         = stmt_start_line;
02201          IR_COL_NUM_L(loc_idx)          = stmt_start_col;
02202          IL_FLD(list_idx)               = IR_Tbl_Idx;
02203          IL_IDX(list_idx)               = loc_idx;
02204       }
02205    }
02206    else {
02207       defer_stmt_expansion = TRUE;
02208       number_of_functions  = 0;
02209       io_stmt_must_be_split = FALSE;
02210 
02211       COPY_OPND(opnd, IR_OPND_R(ir_idx));
02212       semantically_correct = io_list_semantics(&opnd, Read) &&
02213                              semantically_correct;
02214       COPY_OPND(IR_OPND_R(ir_idx), opnd);
02215 
02216       defer_stmt_expansion = FALSE;
02217 
02218 # ifndef _NO_IO_ALTERNATE_RETURN
02219       if (semantically_correct &&
02220           io_stmt_must_be_split &&
02221           br_idx_idx != NULL_IDX) {
02222 
02223          /* we have to split the io and we had an alternate return */
02224          /* so generate the jump out label and the branch true     */
02225 
02226          jump_out_label = gen_internal_lbl(stmt_start_line);
02227 
02228          gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
02229 
02230          NTR_IR_TBL(lab_idx);
02231          SH_IR_IDX(curr_stmt_sh_idx) = lab_idx;
02232          IR_OPR(lab_idx)             = Label_Opr;
02233          IR_TYPE_IDX(lab_idx)        = TYPELESS_DEFAULT_TYPE;
02234          IR_LINE_NUM(lab_idx)        = line;
02235          IR_COL_NUM(lab_idx)         = col;
02236          IR_FLD_L(lab_idx)           = AT_Tbl_Idx;
02237          IR_IDX_L(lab_idx)           = jump_out_label;
02238          IR_COL_NUM_L(lab_idx)       = col;
02239          IR_LINE_NUM_L(lab_idx)      = line;
02240          AT_DEFINED(jump_out_label)      = TRUE;
02241          SH_IR_IDX(curr_stmt_sh_idx)     = lab_idx;
02242          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02243          ATL_DEF_STMT_IDX(jump_out_label) = curr_stmt_sh_idx;
02244 
02245          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02246 
02247          NTR_IR_TBL(br_true_idx);
02248          IR_OPR(br_true_idx)      = Br_True_Opr;
02249          IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
02250          IR_LINE_NUM(br_true_idx) = line;
02251          IR_COL_NUM(br_true_idx)  = col;
02252 
02253          NTR_IR_TBL(ne_idx);
02254          IR_OPR(ne_idx)           = Ne_Opr;
02255          IR_TYPE_IDX(ne_idx)      = LOGICAL_DEFAULT_TYPE;
02256          IR_LINE_NUM(ne_idx)      = line;
02257          IR_COL_NUM(ne_idx)       = col;
02258          IR_FLD_L(ne_idx)         = AT_Tbl_Idx;
02259          IR_IDX_L(ne_idx)         = alt_return_tmp;
02260          IR_LINE_NUM_L(ne_idx)    = line;
02261          IR_COL_NUM_L(ne_idx)     = col;
02262 
02263          IR_FLD_R(ne_idx)         = CN_Tbl_Idx;
02264          IR_IDX_R(ne_idx)         = CN_INTEGER_ZERO_IDX;
02265          IR_LINE_NUM_R(ne_idx)    = line;
02266          IR_COL_NUM_R(ne_idx)     = col;
02267 
02268          IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
02269          IR_IDX_L(br_true_idx)    = ne_idx;
02270 
02271          IR_FLD_R(br_true_idx) = AT_Tbl_Idx;
02272          IR_IDX_R(br_true_idx) = jump_out_label;
02273          IR_LINE_NUM_R(br_true_idx) = line;
02274          IR_COL_NUM_R(br_true_idx)  = col;
02275 
02276          gen_sh(After, If_Stmt, line, col, FALSE, FALSE, TRUE);
02277 
02278          SH_IR_IDX(curr_stmt_sh_idx)     = br_true_idx;
02279          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02280 
02281          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02282 
02283       }
02284 # endif
02285 
02286       if (semantically_correct     &&
02287           (number_of_functions > 0 ||
02288            tree_has_constructor    ||
02289            io_stmt_must_be_split   ||
02290            io_item_must_flatten))       {
02291          process_deferred_io_list();
02292       }
02293       else if (semantically_correct) {
02294          COPY_OPND(opnd, IR_OPND_R(ir_idx));
02295          gen_runtime_checks(&opnd);
02296       }
02297    }
02298    
02299    TRACE (Func_Exit, "read_stmt_semantics", NULL);
02300 
02301    return;
02302 
02303 }  /* read_stmt_semantics */
02304 
02305 
02306 /******************************************************************************\
02307 |*                                                                            *|
02308 |* Description:                                                               *|
02309 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
02310 |*                                                                            *|
02311 |* Input parameters:                                                          *|
02312 |*      NONE                                                                  *|
02313 |*                                                                            *|
02314 |* Output parameters:                                                         *|
02315 |*      NONE                                                                  *|
02316 |*                                                                            *|
02317 |* Returns:                                                                   *|
02318 |*      NONE                                                                  *|
02319 |*                                                                            *|
02320 \******************************************************************************/
02321 
02322 void rewind_stmt_semantics (void)
02323 
02324 {
02325    int                  ir_idx;
02326    opnd_type            opnd;
02327    int                  save_arg_info_list_base;
02328    int                  save_curr_stmt_sh_idx;
02329    boolean              semantically_correct;
02330 
02331 # ifndef _NO_IO_ALTERNATE_RETURN
02332    int                  alt_return_tmp;
02333    int                  asg_idx;
02334    int                  br_true_idx;
02335    int                  col;
02336    int                  eq_idx;
02337    int                  line;
02338    int                  save_next_sh_idx;
02339 # endif
02340 
02341 
02342    TRACE (Func_Entry, "rewind_stmt_semantics", NULL);
02343 
02344    SCP_DOES_IO(curr_scp_idx) = TRUE;
02345 
02346    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
02347 
02348    /* do memory management stuff to make sure the call tables are big enough */
02349 
02350    if (max_call_list_size >= arg_list_size) {
02351       enlarge_call_list_tables();
02352    }
02353 
02354    save_arg_info_list_base = arg_info_list_base;
02355 
02356    arg_info_list_base      = arg_info_list_top;
02357 
02358    arg_info_list_top       = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
02359 
02360    if (arg_info_list_top >= arg_info_list_size) {
02361       enlarge_info_list_table();
02362    }
02363 
02364 # ifndef _NO_IO_ALTERNATE_RETURN
02365    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
02366 # endif
02367 
02368    COPY_OPND(opnd, IR_OPND_R(ir_idx));
02369    semantically_correct = io_ctl_list_semantics(&opnd, Rewind, TRUE);
02370    COPY_OPND(IR_OPND_R(ir_idx), opnd);
02371 
02372    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02373 
02374 # ifndef _NO_IO_ALTERNATE_RETURN
02375 
02376    if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
02377 
02378       line = IR_LINE_NUM(ir_idx);
02379       col  = IR_COL_NUM(ir_idx);
02380 
02381       alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
02382       ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
02383       ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
02384       AT_REFERENCED(alt_return_tmp)     = Referenced;
02385       AT_DEFINED(alt_return_tmp)        = TRUE;
02386       AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
02387 
02388       NTR_IR_TBL(asg_idx);
02389       IR_OPR(asg_idx)        = Alt_Return_Opr;
02390       IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
02391       IR_LINE_NUM(asg_idx)   = line;
02392       IR_COL_NUM(asg_idx)    = col;
02393       IR_LINE_NUM_L(asg_idx) = line;
02394       IR_COL_NUM_L(asg_idx)  = col;
02395       IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
02396       IR_IDX_L(asg_idx)      = alt_return_tmp;
02397       IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
02398       IR_IDX_R(asg_idx)      = ir_idx;
02399 
02400       SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
02401 
02402       if (err_list_idx) {
02403          NTR_IR_TBL(br_true_idx);
02404          IR_OPR(br_true_idx)      = Br_True_Opr;
02405          IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
02406          IR_LINE_NUM(br_true_idx) = line;
02407          IR_COL_NUM(br_true_idx)  = col;
02408 
02409          NTR_IR_TBL(eq_idx);
02410          IR_OPR(eq_idx)           = Eq_Opr;
02411          IR_TYPE_IDX(eq_idx)      = LOGICAL_DEFAULT_TYPE;
02412          IR_LINE_NUM(eq_idx)      = line;
02413          IR_COL_NUM(eq_idx)       = col;
02414          IR_FLD_L(eq_idx)         = AT_Tbl_Idx;
02415          IR_IDX_L(eq_idx)         = alt_return_tmp;
02416          IR_LINE_NUM_L(eq_idx)    = line;
02417          IR_COL_NUM_L(eq_idx)     = col;
02418 
02419          IR_FLD_R(eq_idx)         = CN_Tbl_Idx;
02420          IR_IDX_R(eq_idx)         = CN_INTEGER_ONE_IDX;
02421          IR_LINE_NUM_R(eq_idx)    = line;
02422          IR_COL_NUM_R(eq_idx)     = col;
02423 
02424          IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
02425          IR_IDX_L(br_true_idx)    = eq_idx;
02426 
02427          COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
02428 
02429          curr_stmt_sh_idx = save_next_sh_idx;
02430 
02431          gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
02432 
02433          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = br_true_idx;
02434          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02435 
02436          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02437       }
02438    }
02439 # endif
02440 
02441    if (semantically_correct) {
02442       COPY_OPND(opnd, IR_OPND_R(ir_idx));
02443       semantically_correct = final_arg_work(&opnd,
02444                                             IR_IDX_L(ir_idx),
02445                                             IR_LIST_CNT_R(ir_idx),
02446                                             NULL);
02447       COPY_OPND(IR_OPND_R(ir_idx), opnd);
02448 # if defined(_FILE_IO_OPRS)
02449       IR_OPR(ir_idx) = Rewind_Opr;
02450 # endif
02451    }
02452 
02453 # ifdef _NO_IO_ALTERNATE_RETURN
02454    add_alt_return_lbl(ir_idx, err_attr_idx);
02455 # endif
02456 
02457    /* restore arg_info_list to previous "stack frame" */
02458 
02459    arg_info_list_top  = arg_info_list_base;
02460    arg_info_list_base = save_arg_info_list_base;
02461 
02462    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02463 
02464    TRACE (Func_Exit, "rewind_stmt_semantics", NULL);
02465 
02466    return;
02467 
02468 }  /* rewind_stmt_semantics */
02469 
02470 
02471 /******************************************************************************\
02472 |*                                                                            *|
02473 |* Description:                                                               *|
02474 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
02475 |*                                                                            *|
02476 |* Input parameters:                                                          *|
02477 |*      NONE                                                                  *|
02478 |*                                                                            *|
02479 |* Output parameters:                                                         *|
02480 |*      NONE                                                                  *|
02481 |*                                                                            *|
02482 |* Returns:                                                                   *|
02483 |*      NONE                                                                  *|
02484 |*                                                                            *|
02485 \******************************************************************************/
02486 
02487 void write_stmt_semantics (void)
02488 
02489 {
02490    int                  col;
02491    int                  ir_idx;
02492    int                  line;
02493    int                  list_idx;
02494    int                  loc_idx;
02495    opnd_type            opnd;
02496    boolean              semantically_correct;
02497 
02498 # ifndef _NO_IO_ALTERNATE_RETURN
02499    int                  alt_return_tmp;
02500    int                  asg_idx;
02501    int                  br_idx_idx = NULL_IDX;
02502    int                  br_true_idx;
02503    int                  drop_thru_label_idx;
02504    int                  jump_out_label;
02505    int                  lab_idx;
02506    int                  ne_idx;
02507    int                  save_curr_stmt_sh_idx;
02508    int                  save_next_sh_idx;
02509 # endif
02510 
02511    
02512    TRACE (Func_Entry, "write_stmt_semantics", NULL);
02513 
02514    SCP_DOES_IO(curr_scp_idx) = TRUE;
02515 
02516 # ifndef _NO_IO_ALTERNATE_RETURN
02517    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
02518    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02519 # endif
02520 
02521    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
02522    line = IR_LINE_NUM(ir_idx);
02523 
02524    COPY_OPND(opnd, IR_OPND_L(ir_idx));
02525    semantically_correct = io_ctl_list_semantics(&opnd, Write, FALSE);
02526    COPY_OPND(IR_OPND_L(ir_idx), opnd);
02527 
02528    line = IR_LINE_NUM(ir_idx);
02529    col  = IR_COL_NUM(ir_idx);
02530 
02531 # ifndef _NO_IO_ALTERNATE_RETURN
02532    if (have_iostat              ||
02533        end_list_idx != NULL_IDX ||
02534        err_list_idx != NULL_IDX ||
02535        eor_list_idx != NULL_IDX) {
02536 
02537       if (end_list_idx == NULL_IDX ||
02538           err_list_idx == NULL_IDX ||
02539           eor_list_idx == NULL_IDX) {
02540 
02541          /* generate a label for drop through branch */
02542 
02543          drop_thru_label_idx = gen_internal_lbl(stmt_start_line);
02544 
02545          curr_stmt_sh_idx = save_next_sh_idx;
02546 
02547          gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
02548 
02549          NTR_IR_TBL(lab_idx);
02550          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = lab_idx;
02551          IR_OPR(lab_idx)                          = Label_Opr;
02552          IR_TYPE_IDX(lab_idx)                     = TYPELESS_DEFAULT_TYPE;
02553          IR_LINE_NUM(lab_idx)                     = line;
02554          IR_COL_NUM(lab_idx)                      = col;
02555          IR_FLD_L(lab_idx)                        = AT_Tbl_Idx;
02556          IR_IDX_L(lab_idx)                        = drop_thru_label_idx;
02557          IR_COL_NUM_L(lab_idx)                    = col;
02558          IR_LINE_NUM_L(lab_idx)                   = line;
02559 
02560          AT_DEFINED(drop_thru_label_idx)       = TRUE;
02561          ATL_DEF_STMT_IDX(drop_thru_label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
02562 
02563          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02564          save_next_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02565 
02566          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02567       }
02568 
02569       alt_return_tmp                    = gen_compiler_tmp(1, 0, Priv, TRUE);
02570       ATD_TYPE_IDX(alt_return_tmp)      = CG_INTEGER_DEFAULT_TYPE;
02571       ATD_STOR_BLK_IDX(alt_return_tmp)  = SCP_SB_STACK_IDX(curr_scp_idx);
02572       AT_REFERENCED(alt_return_tmp)     = Referenced;
02573       AT_DEFINED(alt_return_tmp)        = TRUE;
02574       AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
02575 
02576       NTR_IR_TBL(asg_idx);
02577       IR_OPR(asg_idx)        = Alt_Return_Opr;
02578       IR_TYPE_IDX(asg_idx)   = CG_INTEGER_DEFAULT_TYPE;
02579       IR_LINE_NUM(asg_idx)   = line;
02580       IR_COL_NUM(asg_idx)    = col;
02581       IR_LINE_NUM_L(asg_idx) = line;
02582       IR_COL_NUM_L(asg_idx)  = col;
02583       IR_FLD_L(asg_idx)      = AT_Tbl_Idx;
02584       IR_IDX_L(asg_idx)      = alt_return_tmp;
02585 
02586       IR_FLD_R(asg_idx)      = IR_Tbl_Idx;
02587       IR_IDX_R(asg_idx)      = ir_idx;
02588 
02589       SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
02590 
02591       NTR_IR_TBL(br_idx_idx);
02592       IR_OPR(br_idx_idx) = Br_Index_Opr;
02593       IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE;
02594 
02595       IR_FLD_L(br_idx_idx)            = AT_Tbl_Idx;
02596       IR_IDX_L(br_idx_idx)            = alt_return_tmp;
02597       IR_LINE_NUM(br_idx_idx)         = line;
02598       IR_COL_NUM(br_idx_idx)          = col;
02599       IR_LINE_NUM_L(br_idx_idx)       = line;
02600       IR_COL_NUM_L(br_idx_idx)        = col;
02601       IR_FLD_R(br_idx_idx)            = IL_Tbl_Idx;
02602       IR_LIST_CNT_R(br_idx_idx)       = 3;
02603 
02604       NTR_IR_LIST_TBL(list_idx);
02605       IR_IDX_R(br_idx_idx)            = list_idx;
02606 
02607       if (err_list_idx) {
02608          COPY_OPND(IL_OPND(list_idx), IL_OPND(err_list_idx));
02609       }
02610       else {
02611          IL_FLD(list_idx) = AT_Tbl_Idx;
02612          IL_IDX(list_idx) = drop_thru_label_idx;
02613          IL_LINE_NUM(list_idx) = line;
02614          IL_COL_NUM(list_idx)  = col;
02615       }
02616 
02617       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02618       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02619       list_idx = IL_NEXT_LIST_IDX(list_idx);
02620 
02621       if (end_list_idx) {
02622          COPY_OPND(IL_OPND(list_idx), IL_OPND(end_list_idx));
02623       }
02624       else {
02625          IL_FLD(list_idx) = AT_Tbl_Idx;
02626          IL_IDX(list_idx) = drop_thru_label_idx;
02627          IL_LINE_NUM(list_idx) = line;
02628          IL_COL_NUM(list_idx)  = col;
02629       }
02630 
02631       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02632       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02633       list_idx = IL_NEXT_LIST_IDX(list_idx);
02634 
02635       if (eor_list_idx) {
02636          COPY_OPND(IL_OPND(list_idx), IL_OPND(eor_list_idx));
02637       }
02638       else {
02639          IL_FLD(list_idx) = AT_Tbl_Idx;
02640          IL_IDX(list_idx) = drop_thru_label_idx;
02641          IL_LINE_NUM(list_idx) = line;
02642          IL_COL_NUM(list_idx)  = col;
02643       }
02644 
02645       curr_stmt_sh_idx = save_next_sh_idx;
02646 
02647       gen_sh(Before, If_Stmt, line, col, FALSE, TRUE, TRUE);
02648       curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02649       SH_IR_IDX(curr_stmt_sh_idx) = br_idx_idx;
02650       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02651 
02652       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02653 
02654    }
02655 # endif
02656 
02657    if (is_namelist) {
02658 
02659       if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) {
02660          find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)),
02661                                    &line,
02662                                    &col);
02663          PRINTMSG(line, 444, Error, col);
02664       }
02665 
02666       if (namelist_descriptor_attr) {
02667 # if 0
02668         /* call the namelist table dump routine */
02669 
02670         {int    _call_idx, _list_idx, _loc_idx;
02671          int    _dump_nml_idx;
02672         _dump_nml_idx = create_lib_entry_attr("DUMP_NML",
02673                                             8,
02674                                             stmt_start_line,
02675                                             stmt_start_col);
02676 
02677         ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx);
02678    
02679         NTR_IR_TBL(_call_idx);
02680         IR_OPR(_call_idx) = Call_Opr;
02681         IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE;
02682         IR_LINE_NUM(_call_idx) = stmt_start_line;
02683         IR_COL_NUM(_call_idx) = stmt_start_col;
02684         IR_FLD_L(_call_idx) = AT_Tbl_Idx;
02685         IR_IDX_L(_call_idx) = _dump_nml_idx;
02686         IR_LINE_NUM_L(_call_idx) = stmt_start_line;
02687         IR_COL_NUM_L(_call_idx) = stmt_start_col;
02688    
02689         NTR_IR_LIST_TBL(_list_idx);
02690         IR_FLD_R(_call_idx) = IL_Tbl_Idx;
02691         IR_IDX_R(_call_idx) = _list_idx;
02692         IR_LIST_CNT_R(_call_idx) = 1;
02693    
02694         NTR_IR_TBL(_loc_idx);
02695         IR_OPR(_loc_idx) = Aloc_Opr;
02696         IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8;
02697         IR_LINE_NUM(_loc_idx) = stmt_start_line;
02698         IR_COL_NUM(_loc_idx) = stmt_start_col;
02699         IL_FLD(_list_idx) = IR_Tbl_Idx;
02700         IL_IDX(_list_idx) = _loc_idx;
02701    
02702         IR_FLD_L(_loc_idx) = AT_Tbl_Idx;
02703         IR_IDX_L(_loc_idx) = namelist_descriptor_attr;
02704         IR_LINE_NUM_L(_loc_idx) = stmt_start_line;
02705         IR_COL_NUM_L(_loc_idx) = stmt_start_col;
02706   
02707         gen_sh(Before, Call_Stmt, stmt_start_line,
02708                 stmt_start_col, FALSE, FALSE, TRUE);
02709   
02710         SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = _call_idx;
02711         SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02712         }
02713 
02714 # endif
02715 
02716          NTR_IR_LIST_TBL(list_idx);
02717          IR_FLD_R(ir_idx)               = IL_Tbl_Idx;
02718          IR_LIST_CNT_R(ir_idx)          = 1;
02719          IR_IDX_R(ir_idx)               = list_idx;
02720          NTR_IR_TBL(loc_idx);
02721          IR_OPR(loc_idx)                = Loc_Opr;
02722          IR_TYPE_IDX(loc_idx)           = CRI_Ptr_8;
02723          IR_LINE_NUM(loc_idx)           = stmt_start_line;
02724          IR_COL_NUM(loc_idx)            = stmt_start_col;
02725          IR_FLD_L(loc_idx)              = AT_Tbl_Idx;
02726          IR_IDX_L(loc_idx)              = namelist_descriptor_attr;
02727          IR_LINE_NUM_L(loc_idx)         = stmt_start_line;
02728          IR_COL_NUM_L(loc_idx)          = stmt_start_col;
02729          IL_FLD(list_idx)               = IR_Tbl_Idx;
02730          IL_IDX(list_idx)               = loc_idx;
02731       }
02732    }
02733    else {
02734       defer_stmt_expansion = TRUE;
02735       number_of_functions  = 0;
02736       io_stmt_must_be_split = FALSE;
02737 
02738       COPY_OPND(opnd, IR_OPND_R(ir_idx));
02739       semantically_correct = io_list_semantics(&opnd, Write) &&
02740                              semantically_correct;
02741       COPY_OPND(IR_OPND_R(ir_idx), opnd);
02742 
02743       defer_stmt_expansion = FALSE;
02744 
02745 # ifndef _NO_IO_ALTERNATE_RETURN
02746       if (semantically_correct &&
02747           io_stmt_must_be_split &&
02748           br_idx_idx != NULL_IDX) {
02749 
02750          /* we have to split the io and we had an alternate return */
02751          /* so generate the jump out label and the branch true     */
02752 
02753          jump_out_label = gen_internal_lbl(stmt_start_line);
02754 
02755          gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
02756          
02757          NTR_IR_TBL(lab_idx);
02758          SH_IR_IDX(curr_stmt_sh_idx) = lab_idx;
02759          IR_OPR(lab_idx)             = Label_Opr;
02760          IR_TYPE_IDX(lab_idx)        = TYPELESS_DEFAULT_TYPE;
02761          IR_LINE_NUM(lab_idx)        = line;
02762          IR_COL_NUM(lab_idx)         = col;
02763          IR_FLD_L(lab_idx)           = AT_Tbl_Idx;
02764          IR_IDX_L(lab_idx)           = jump_out_label;
02765          IR_COL_NUM_L(lab_idx)       = col;
02766          IR_LINE_NUM_L(lab_idx)      = line;
02767          AT_DEFINED(jump_out_label)      = TRUE;
02768          SH_IR_IDX(curr_stmt_sh_idx)     = lab_idx;
02769          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02770          ATL_DEF_STMT_IDX(jump_out_label) = curr_stmt_sh_idx;
02771 
02772          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02773 
02774          NTR_IR_TBL(br_true_idx);
02775          IR_OPR(br_true_idx)      = Br_True_Opr;
02776          IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
02777          IR_LINE_NUM(br_true_idx) = line;
02778          IR_COL_NUM(br_true_idx)  = col;
02779 
02780          NTR_IR_TBL(ne_idx);
02781          IR_OPR(ne_idx)           = Ne_Opr;
02782          IR_TYPE_IDX(ne_idx)      = LOGICAL_DEFAULT_TYPE;
02783          IR_LINE_NUM(ne_idx)      = line;
02784          IR_COL_NUM(ne_idx)       = col;
02785          IR_FLD_L(ne_idx)         = AT_Tbl_Idx;
02786          IR_IDX_L(ne_idx)         = alt_return_tmp;
02787          IR_LINE_NUM_L(ne_idx)    = line;
02788          IR_COL_NUM_L(ne_idx)     = col;
02789 
02790          IR_FLD_R(ne_idx)         = CN_Tbl_Idx;
02791          IR_IDX_R(ne_idx)         = CN_INTEGER_ZERO_IDX;
02792          IR_LINE_NUM_R(ne_idx)    = line;
02793          IR_COL_NUM_R(ne_idx)     = col;
02794 
02795          IR_FLD_L(br_true_idx)    = IR_Tbl_Idx;
02796          IR_IDX_L(br_true_idx)    = ne_idx;
02797 
02798          IR_FLD_R(br_true_idx) = AT_Tbl_Idx;
02799          IR_IDX_R(br_true_idx) = jump_out_label;
02800          IR_LINE_NUM_R(br_true_idx) = line;
02801          IR_COL_NUM_R(br_true_idx)  = col;
02802 
02803          gen_sh(After, If_Stmt, line, col, FALSE, FALSE, TRUE);
02804 
02805          SH_IR_IDX(curr_stmt_sh_idx)     = br_true_idx;
02806          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02807 
02808          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02809 
02810       }
02811 # endif
02812 
02813       if (semantically_correct     &&
02814           (number_of_functions > 0 ||
02815            tree_has_constructor    ||
02816            io_stmt_must_be_split   ||
02817            io_item_must_flatten))       {
02818          process_deferred_io_list();
02819       }
02820       else if (semantically_correct) {
02821          COPY_OPND(opnd, IR_OPND_R(ir_idx));
02822          gen_runtime_checks(&opnd);
02823       }
02824    }
02825 
02826    TRACE (Func_Exit, "write_stmt_semantics", NULL);
02827    
02828    return;
02829 
02830 }  /* write_stmt_semantics */
02831 
02832 
02833 /******************************************************************************\
02834 |*                                                                            *|
02835 |* Description:                                                               *|
02836 |*      <description>                                                         *|
02837 |*                                                                            *|
02838 |* Input parameters:                                                          *|
02839 |*      NONE                                                                  *|
02840 |*                                                                            *|
02841 |* Output parameters:                                                         *|
02842 |*      NONE                                                                  *|
02843 |*                                                                            *|
02844 |* Returns:                                                                   *|
02845 |*      NOTHING                                                               *|
02846 |*                                                                            *|
02847 \******************************************************************************/
02848 
02849 static boolean io_ctl_list_semantics(opnd_type     *list_opnd, 
02850                                      io_stmt_type   io_type,
02851                                      boolean        is_call)
02852 
02853 {
02854    int           attr_idx;
02855    int           ciitem_idx;
02856    int           col;
02857    long_type     constant_value;
02858    int           err_idx;
02859    expr_arg_type exp_desc;
02860    boolean       default_kind;
02861    boolean       format_expected;
02862    int           free_list_idx;
02863    int           i;
02864    int           info_idx;
02865    boolean       internal_file = FALSE;
02866    char          io_type_string[16];
02867    int           k;
02868    opnd_type     left_opnd;
02869    int           line;
02870    int           list_array[MAX_NUM_CIITEM + 1];
02871    int           list_idx;
02872    boolean       match;
02873    boolean       namelist_expected;
02874    opnd_type     opnd;
02875    int           pp_tmp = NULL_IDX;
02876    boolean       semantically_correct = TRUE;
02877    int           tmp_idx;
02878 int fm; 
02879 
02880 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
02881    int           ir_idx;
02882 # endif
02883 
02884 
02885    TRACE (Func_Entry, "io_ctl_list_semantics", NULL);
02886 
02887    list_directed = FALSE;
02888 
02889    io_type_string[0] = '\0';
02890    strcat(io_type_string, io_stmt_str[io_type]);
02891 
02892    end_list_idx = NULL_IDX;
02893    err_list_idx = NULL_IDX;
02894    err_attr_idx = NULL_IDX;
02895    eor_list_idx = NULL_IDX;
02896    have_iostat  = FALSE;
02897 
02898    if (io_type == Print) {
02899       io_type = Write;
02900    }
02901 
02902    if (io_type == Inquire) {
02903       err_idx = INQ_ERR_IDX;
02904    }
02905    else {
02906       err_idx = ERR_IDX;
02907    }
02908 
02909    is_namelist = FALSE;
02910 
02911    list_idx = OPND_IDX((*list_opnd));
02912 
02913    info_idx = arg_info_list_base;
02914 
02915    for (i = 1; i <= OPND_LIST_CNT((*list_opnd)); i++) {
02916 
02917       info_idx++;
02918 
02919       list_array[i] = list_idx;
02920 
02921       format_expected   = IL_FORMAT_EXPECTED(list_idx);
02922       namelist_expected = IL_NAMELIST_EXPECTED(list_idx);
02923   
02924 
02925       if (IL_FLD(list_idx) == NO_Tbl_Idx) {
02926          list_idx = IL_NEXT_LIST_IDX(list_idx);
02927          continue;
02928       }
02929       else if (IL_FLD(list_idx) == CN_Tbl_Idx &&
02930                IL_IDX(list_idx) == NULL_IDX) {
02931          /* had a * for format or unit */
02932 
02933          if (i == 1) {
02934             /* default unit */
02935 
02936             /* change to NO_Tbl_Idx */
02937             IL_FLD(list_idx) = NO_Tbl_Idx;
02938          }
02939          else if (i == 2) {
02940            /* list directed io */
02941             list_directed = TRUE;
02942 
02943          }
02944 # ifdef _DEBUG
02945          else {
02946             find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02947                                       &line,
02948                                       &col);
02949             PRINTMSG(line, 762, Internal, col);
02950          }
02951 # endif
02952          list_idx = IL_NEXT_LIST_IDX(list_idx);
02953          continue;
02954       }  
02955    else
02956        if (IL_FLD(list_idx) == AT_Tbl_Idx &&
02957                               i   == FMT_IDX &&
02958                               !(namelist_expected) &&
02959                ( io_type == Write || io_type == Read)){  
02960             if (AT_OBJ_CLASS(IL_IDX(list_idx)) ==  Data_Obj){
02961                 if (ATD_CLASS(IL_IDX(list_idx)) == Constant)
02962                     IL_IDX(list_idx) = ATD_CONST_IDX(IL_IDX(list_idx));
02963                 else 
02964                 if (ATD_CLASS(IL_IDX(list_idx)) ==Atd_Unknown &&
02965                    AT_ATTR_LINK(IL_IDX(list_idx)) != NULL   &&
02966                    ATD_CLASS(AT_ATTR_LINK(IL_IDX(list_idx)))== Constant )
02967                    IL_IDX(list_idx) = ATD_CONST_IDX(AT_ATTR_LINK(IL_IDX(list_idx)));
02968                 else
02969                    IL_IDX(list_idx)=ATD_TMP_IDX(ATL_FORMAT_TMP(IL_IDX(list_idx))); 
02970                }
02971             else 
02972              IL_IDX(list_idx)=ATD_TMP_IDX(ATL_FORMAT_TMP(IL_IDX(list_idx)));
02973 
02974              IL_FLD(list_idx) = CN_Tbl_Idx; 
02975 
02976        }
02977       else if (i                == FMT_IDX &&
02978                IL_FLD(list_idx) == IL_Tbl_Idx) {
02979          /* this was format character constant inline */
02980          /* do not send through expr_semantics.       */
02981          /* first item is format tmp, second is       */
02982          /* preparsed format tmp.                     */
02983 
02984          pp_tmp = IL_IDX(IL_NEXT_LIST_IDX(IL_IDX(list_idx)));
02985          FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(list_idx)));
02986          free_list_idx = IL_IDX(list_idx);
02987          COPY_OPND(IL_OPND(list_idx), IL_OPND(IL_IDX(list_idx)));
02988          FREE_IR_LIST_NODE(free_list_idx);
02989 
02990          ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
02991          ADD_TMP_TO_SHARED_LIST(pp_tmp);
02992 
02993          list_idx = IL_NEXT_LIST_IDX(list_idx);
02994          continue;
02995       }
02996 
02997       ciitem_idx = arg_idx_tbl[io_type][i];
02998 
02999       exp_desc.rank = 0;
03000       COPY_OPND(opnd, IL_OPND(list_idx));
03001 
03002       if (i == NML_IDX) {
03003          namelist_illegal = FALSE;
03004       }
03005 
03006       io_item_must_flatten = FALSE;
03007 
03008       if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form
03009                                                     == Var_Only_Form) {
03010          xref_state = CIF_Symbol_Modification;
03011       }
03012       else if (i                              == FMT_IDX    &&
03013                IL_FLD(list_idx)               == AT_Tbl_Idx &&
03014                AT_OBJ_CLASS(IL_IDX(list_idx)) == Label)     {
03015 
03016          xref_state = CIF_No_Usage_Rec;
03017       }
03018       else {
03019          xref_state = CIF_Symbol_Reference;
03020       }
03021 
03022       if (i == UNIT_IDX) {
03023          in_call_list = TRUE;
03024       }
03025 
03026       if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form
03027                                                     == Label_Form ||
03028           ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form
03029                                                     == Format_Form) {
03030 
03031          label_allowed = TRUE;
03032       }
03033 
03034       if (!expr_semantics(&opnd, &exp_desc)) {
03035          namelist_illegal     = TRUE;
03036          label_allowed        = FALSE;
03037          semantically_correct = FALSE;
03038          list_idx             = IL_NEXT_LIST_IDX(list_idx);
03039          in_call_list = FALSE;
03040          continue;
03041       }
03042 
03043       in_call_list = FALSE;
03044       label_allowed = FALSE;
03045 
03046       COPY_OPND(IL_OPND(list_idx), opnd);
03047 
03048       namelist_illegal = TRUE;
03049 
03050       if (! is_call) {
03051 
03052          if (io_item_must_flatten ||
03053              exp_desc.dist_reshape_ref ||
03054              exp_desc.vector_subscript) {
03055 
03056             tmp_idx = create_tmp_asg(&opnd, &exp_desc, &left_opnd, 
03057                                      Intent_In, TRUE, FALSE);
03058             COPY_OPND(IL_OPND(list_idx), left_opnd);
03059          }
03060       }
03061       else  {
03062          arg_info_list[info_idx]    = init_arg_info;
03063          arg_info_list[info_idx].ed = exp_desc;
03064          arg_info_list[info_idx].maybe_modified   = TRUE;
03065          IL_ARG_DESC_IDX(list_idx)                = info_idx;
03066       }
03067 
03068       if (exp_desc.rank != 0          &&
03069           i             != FMT_IDX    &&
03070           exp_desc.type != Character) {
03071 
03072          find_opnd_line_and_column(&opnd, &line, &col);
03073          PRINTMSG(line, 449, Error, col,
03074                   exp_desc.rank,
03075                   ciitem_tbl[io_type].ciitem_list[ciitem_idx].name);
03076          semantically_correct = FALSE;
03077       }
03078 
03079       if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].scalar &&
03080           exp_desc.rank > 0) {
03081 
03082          find_opnd_line_and_column(&opnd, &line, &col);
03083          PRINTMSG(line, 1113, Error, col,
03084                   ciitem_tbl[io_type].ciitem_list[ciitem_idx].name);
03085          semantically_correct = FALSE;
03086       }
03087 
03088       switch (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form) {
03089          case Exp_Form      :
03090 
03091             match = FALSE;
03092 
03093             for (k = 0; 
03094                  k < ciitem_tbl[io_type].ciitem_list[ciitem_idx].num_types; 
03095                  k++){
03096 
03097                if (exp_desc.type == 
03098                    ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03099                                                   allowed_types[k]) {
03100                   match = TRUE;
03101                   break;
03102                }
03103             }
03104 
03105             find_opnd_line_and_column(&opnd, &line, &col);
03106 
03107             if (!match) {
03108                PRINTMSG(line, 441, Error, col,
03109                         get_basic_type_str(exp_desc.type_idx),
03110                         ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03111                         io_type_string);            
03112 
03113                semantically_correct = FALSE;
03114             }
03115             else if (exp_desc.type == Typeless) {
03116            
03117                if (exp_desc.linear_type == Long_Typeless) {
03118                   find_opnd_line_and_column(&opnd, &line, &col);
03119                   PRINTMSG(line, 1133, Error, col);
03120                   semantically_correct = FALSE;
03121                }
03122                else if (exp_desc.linear_type == Short_Typeless_Const) {
03123                   IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
03124                                                            INTEGER_DEFAULT_TYPE,
03125                                                            line,
03126                                                            col);
03127                   exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
03128                   exp_desc.type_idx    = INTEGER_DEFAULT_TYPE;
03129                   exp_desc.type        = Integer;
03130                   COPY_OPND(opnd, IL_OPND(list_idx));
03131                } 
03132             }
03133             else if (exp_desc.type                       == Character &&
03134                      ! exp_desc.constant                              &&
03135                      ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03136                                         allowed_types[0] == Integer   &&
03137                      (io_type == Rewind ||
03138                       io_type == Backspace ||
03139                       io_type == Endfile)) {
03140 
03141                /* It is an error to have a character variable UNIT for */
03142                /* endfile, backspace or rewind.                        */
03143 
03144                PRINTMSG(line, 441, Error, col,
03145                         get_basic_type_str(exp_desc.type_idx),
03146                         ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03147                         io_type_string);
03148 
03149                semantically_correct = FALSE;
03150 
03151             }
03152             else if (exp_desc.type                       == Character &&
03153                      exp_desc.constant                                &&
03154                      ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03155                                         allowed_types[0] == Integer)  { 
03156 
03157                /* This combination of factors assumes we are  */
03158                /* talking about a character constant UNIT,    */
03159                /* this is a file name, not internal write.    */
03160                /* change to Typeless here. check length first */
03161 
03162 # ifdef _DEBUG
03163                if (strcmp(ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03164                            "UNIT") != 0) {
03165                   PRINTMSG(line, 606, Internal, col);
03166                }
03167 # endif
03168 
03169               if (compare_cn_and_value(TYP_IDX(exp_desc.type_idx),
03170                                        TARGET_BYTES_PER_WORD,
03171                                        Lt_Opr)) {
03172 
03173                   /* BRIANJ - Why convert since it is going back to const */
03174                   /*          table.  Can we use it directly?             */
03175 
03176                   constant_value = (long_type) CN_INT_TO_C(OPND_IDX(opnd));
03177                   IL_IDX(list_idx) = ntr_const_tbl(TYPELESS_DEFAULT_TYPE,
03178                                                    FALSE,
03179                                                   &constant_value);
03180 
03181                   exp_desc.type = Typeless;
03182                   exp_desc.linear_type = TYPELESS_DEFAULT_TYPE;
03183                   exp_desc.type_idx = TYPELESS_DEFAULT_TYPE;
03184 
03185                   PRINTMSG(line, 485, Ansi, col);
03186 
03187                   if (is_call) {
03188                      arg_info_list[info_idx].ed = exp_desc;
03189                   }
03190                }
03191                else {
03192                   PRINTMSG(line, 216, Error, col,
03193                            TARGET_BYTES_PER_WORD);
03194                   semantically_correct = FALSE;
03195                }
03196             }
03197 
03198             if (semantically_correct) {
03199                
03200                COPY_OPND(opnd, IL_OPND(list_idx));
03201                cast_to_cg_default(&opnd, &exp_desc);
03202                COPY_OPND(IL_OPND(list_idx), opnd);
03203 
03204                if (is_call) {
03205                   arg_info_list[info_idx].ed = exp_desc;
03206                }
03207             }
03208 
03209             if (is_call) {
03210                arg_info_list[info_idx].maybe_modified = FALSE;
03211             }
03212             break;
03213 
03214          case Label_Form    :
03215 
03216             if (i == err_idx) {
03217                err_list_idx = list_idx;
03218                err_attr_idx = IL_IDX(list_idx);
03219             }
03220             else if (i == END_IDX) {
03221                end_list_idx = list_idx;
03222             }
03223             else if (i == EOR_IDX) {
03224                eor_list_idx = list_idx;
03225             }
03226 
03227             if (OPND_FLD(opnd) == AT_Tbl_Idx &&
03228                 AT_OBJ_CLASS(OPND_IDX(opnd)) == Label) {
03229             }
03230             else {
03231                find_opnd_line_and_column(&opnd, &line, &col);
03232                PRINTMSG(line, 448, Error, col);
03233                semantically_correct = FALSE;
03234             }
03235 
03236             break;
03237 
03238          case Namelist_Form :
03239 
03240             /* never be here */
03241             break;
03242 
03243          case Var_Only_Form :
03244 
03245             find_opnd_line_and_column(&opnd, &line, &col);
03246             if (exp_desc.reference) {
03247 
03248                default_kind = TRUE;
03249                switch (exp_desc.type) {
03250                case Integer   :
03251                   default_kind = (exp_desc.linear_type == INTEGER_DEFAULT_TYPE);
03252                   break;
03253 
03254                case Logical   :
03255                   default_kind = (exp_desc.linear_type == LOGICAL_DEFAULT_TYPE);
03256                   break;
03257                case Real      :
03258                   default_kind = (exp_desc.linear_type == REAL_DEFAULT_TYPE);
03259                   break;
03260                case Complex   :
03261                   default_kind = (exp_desc.linear_type == COMPLEX_DEFAULT_TYPE);
03262                   break;
03263                case Character :
03264                   default_kind = TRUE;
03265                   break;
03266                }
03267 
03268                if (exp_desc.type != ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03269                                                             allowed_types[0]) {
03270                   PRINTMSG(line, 459, Error, col,
03271                            get_basic_type_str(exp_desc.type_idx),
03272                            ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03273                            io_type_string);
03274 
03275                   semantically_correct = FALSE;
03276                }
03277                else if (!default_kind) {
03278                   PRINTMSG(line, 461, Error, col,
03279                            ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03280                            io_type_string);
03281                   semantically_correct = FALSE;
03282                }
03283                else if (! check_for_legal_define(&opnd)) {
03284                   semantically_correct = FALSE;
03285                }
03286                else {
03287 
03288                   attr_idx = find_left_attr(&opnd);
03289 
03290 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
03291                   if ((exp_desc.type == Integer &&
03292                        storage_bit_size_tbl[exp_desc.linear_type] !=
03293                        storage_bit_size_tbl[
03294                                    TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)]) ||
03295                       (exp_desc.type == Logical &&
03296                        storage_bit_size_tbl[exp_desc.linear_type] !=
03297                        storage_bit_size_tbl[
03298                                    TYP_LINEAR(CG_LOGICAL_DEFAULT_TYPE)])) {
03299 
03300 
03301                      /* must be word size int/logical, else copy out */
03302 
03303                      tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
03304 
03305                      if (exp_desc.type == Integer) {
03306                         ATD_TYPE_IDX(tmp_idx)     = CG_INTEGER_DEFAULT_TYPE;
03307                      }
03308                      else {
03309                         ATD_TYPE_IDX(tmp_idx)     = CG_LOGICAL_DEFAULT_TYPE;
03310                      }
03311 
03312                      ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03313                      AT_SEMANTICS_DONE(tmp_idx)= TRUE;
03314 
03315 
03316                      NTR_IR_TBL(ir_idx);
03317                      IR_OPR(ir_idx) = Asg_Opr;
03318                      IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(tmp_idx);
03319                      IR_LINE_NUM(ir_idx) = line;
03320                      IR_COL_NUM(ir_idx)  = col;
03321 
03322                      IR_FLD_R(ir_idx) = AT_Tbl_Idx;
03323                      IR_IDX_R(ir_idx) = tmp_idx;
03324                      IR_LINE_NUM_R(ir_idx) = line;
03325                      IR_COL_NUM_R(ir_idx)  = col;
03326 
03327                      COPY_OPND(IR_OPND_L(ir_idx), opnd);
03328                      gen_sh(After, Assignment_Stmt, line,
03329                             col, FALSE, FALSE, TRUE);
03330                      SH_IR_IDX(curr_stmt_sh_idx)     = ir_idx;
03331                      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
03332                      curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03333 
03334                      IL_FLD(list_idx) = AT_Tbl_Idx;
03335                      IL_IDX(list_idx) = tmp_idx;
03336                      IL_LINE_NUM(list_idx) = line;
03337                      IL_COL_NUM(list_idx)  = col;
03338 
03339                      COPY_OPND(opnd, IL_OPND(list_idx));
03340 
03341                      exp_desc.tmp_reference = TRUE;
03342                      exp_desc.type_idx = ATD_TYPE_IDX(tmp_idx);
03343                      exp_desc.linear_type = TYP_LINEAR(ATD_TYPE_IDX(tmp_idx));
03344 
03345                      if (is_call) {
03346                         arg_info_list[info_idx].ed = exp_desc;
03347                      }
03348 
03349                   }
03350 # endif
03351                }
03352             }
03353             else { /* must be variable */
03354                PRINTMSG(line, 460, Error, col,
03355                         ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03356                         basic_type_str[ciitem_tbl[io_type].
03357                                       ciitem_list[ciitem_idx].allowed_types[0]],
03358                         io_type_string);
03359                semantically_correct = FALSE;
03360             }
03361             
03362             break;
03363 
03364          case Format_Form   :
03365 
03366             /* assume format for now */
03367 
03368             find_opnd_line_and_column(&opnd, &line, &col);
03369 
03370         fm = OPND_IDX(opnd); 
03371 
03372             if (!format_expected                              &&
03373                 OPND_FLD(opnd)               == AT_Tbl_Idx    &&
03374                 AT_OBJ_CLASS(OPND_IDX(opnd)) == Namelist_Grp ) { 
03375                is_namelist = TRUE;
03376 
03377                if (io_type == Read) {
03378                   semantically_correct = do_read_namelist_semantics(&opnd)
03379                                          && semantically_correct;
03380                }
03381                else {
03382                   do_write_namelist_semantics(&opnd);
03383                }
03384 
03385                if (ATN_NAMELIST_DESC(OPND_IDX(opnd)) == NULL_IDX) {
03386 /*               create_namelist_descriptor(OPND_IDX(opnd)); */
03387                }
03388 
03389                namelist_descriptor_attr = ATN_NAMELIST_DESC(OPND_IDX(opnd));
03390 
03391                ADD_TMP_TO_SHARED_LIST(namelist_descriptor_attr);
03392 
03393             }
03394             else if (namelist_expected) {
03395 
03396                /* must be namelist group, had NML = */
03397 
03398                PRINTMSG(line, 446, Error, col);
03399                semantically_correct = FALSE;
03400 
03401                is_namelist = TRUE;
03402             }
03403             else if (OPND_FLD(opnd)               == AT_Tbl_Idx &&
03404                      AT_OBJ_CLASS(OPND_IDX(opnd)) == Label)     {
03405 
03406                if (ATL_CLASS(OPND_IDX(opnd)) == Lbl_Format) {
03407                   /* replace label reference with format constant idx */
03408                   IL_IDX(list_idx) = ATL_FORMAT_TMP(OPND_IDX(opnd));
03409                   IL_FLD(list_idx) = AT_Tbl_Idx;
03410                   IL_LINE_NUM(list_idx) = line;
03411                   IL_COL_NUM(list_idx)  = col;
03412 
03413                   pp_tmp = ATL_PP_FORMAT_TMP(OPND_IDX(opnd));
03414 
03415                   ADD_TMP_TO_SHARED_LIST(ATL_FORMAT_TMP(OPND_IDX(opnd)));
03416                   ADD_TMP_TO_SHARED_LIST(ATL_PP_FORMAT_TMP(OPND_IDX(opnd)));
03417                }
03418 
03419                /* if not a format label larry will have already caught it */
03420                
03421             }
03422             else if (exp_desc.type == Character) {
03423 
03424             }
03425             else if (exp_desc.rank > 0                                &&
03426                      (OPND_FLD(opnd)         != IR_Tbl_Idx ||
03427                       exp_desc.dope_vector                 ||
03428                       IR_OPR(OPND_IDX(opnd)) != Whole_Subscript_Opr)) {
03429 
03430                /* these are noncontiguous arrays, sections, dope vectors */
03431                /* error .. format error */
03432 
03433                PRINTMSG(line, 447, Error, col);
03434                semantically_correct = FALSE;
03435             }
03436             else if (exp_desc.type == Integer &&
03437                      exp_desc.reference)      {
03438 
03439                if (exp_desc.rank == 0) { /* check for ASSIGN */
03440 
03441                   if (!exp_desc.reference) { /* error .. must be variable */
03442                      PRINTMSG(line, 447, Error, col);
03443                      semantically_correct = FALSE;
03444                   }
03445                   else if (exp_desc.linear_type != INTEGER_DEFAULT_TYPE) {
03446 
03447                      /* must be default kind */
03448 
03449                      PRINTMSG(line, 462, Error, col);
03450                      semantically_correct = FALSE;
03451                   }
03452                   else {
03453 
03454                      attr_idx = find_base_attr(&opnd, &line, &col);
03455 
03456                      if (! ATD_IN_ASSIGN(attr_idx)) {
03457                         PRINTMSG(line, 1099, Error, col);
03458                      }
03459 
03460 # if defined(GENERATE_WHIRL)
03461                      if (ATD_ASSIGN_TMP_IDX(attr_idx) != NULL_IDX) {
03462                         OPND_FLD(opnd) = AT_Tbl_Idx;
03463                         OPND_IDX(opnd) = ATD_ASSIGN_TMP_IDX(attr_idx);
03464                         COPY_OPND(IL_OPND(list_idx), opnd);
03465                         ADD_TMP_TO_SHARED_LIST(ATD_ASSIGN_TMP_IDX(attr_idx));
03466                      }
03467 # endif
03468                   }
03469                }
03470                else { /* integer array is nonstandard */
03471                   PRINTMSG(line, 778, Ansi, col);
03472                }
03473             }
03474             else if ((exp_desc.linear_type == REAL_DEFAULT_TYPE ||
03475                       exp_desc.type == Logical)                &&
03476                      exp_desc.reference                        &&
03477                      exp_desc.rank > 0)                        {
03478                PRINTMSG(line, 778, Ansi, col);
03479             }
03480             else if (exp_desc.type == Typeless &&
03481                      exp_desc.rank == 0)       {
03482             
03483                /* intentionally blank */
03484                /* ansi msg already issued by lex */
03485             }
03486             else { /* error .. format error */
03487                PRINTMSG(line, 447, Error, col);
03488                semantically_correct = FALSE;
03489             }
03490 
03491             break;
03492       } /* switch */
03493 
03494       /* put checks here that require that the exp_desc be valid */
03495       /* these checks are done for each list item.               */
03496 
03497       if (io_type == Read || io_type == Write) {
03498 
03499          if (i == UNIT_IDX) {
03500 
03501             if (exp_desc.type == Character &&
03502                 !exp_desc.constant         &&
03503                 exp_desc.reference)        {
03504 
03505                internal_file = TRUE;
03506 
03507                if (io_type == Write) {
03508                   mark_attr_defined(&opnd);
03509 
03510                   if (! check_for_legal_define(&opnd)) {
03511                      semantically_correct = FALSE;
03512                   }
03513                }
03514 
03515                if (exp_desc.vector_subscript) {
03516                   find_opnd_line_and_column(&opnd, &line, &col);
03517                   PRINTMSG(line, 467, Error, col);
03518                   semantically_correct = FALSE;
03519                }
03520                else if (OPND_FLD(opnd) == AT_Tbl_Idx &&
03521                         ATD_ARRAY_IDX(OPND_IDX(opnd)) != NULL_IDX &&
03522                         BD_ARRAY_CLASS(ATD_ARRAY_IDX(OPND_IDX(opnd))) ==
03523                                                      Assumed_Size) {
03524 
03525                   PRINTMSG(line, 1302, Ansi, col);
03526                }
03527             }
03528          }
03529       }
03530 
03531       list_idx = IL_NEXT_LIST_IDX(list_idx);
03532    } /* end of for loop for list items */
03533 
03534    /* put checks here that can be done after all list items */
03535    /* are processed. They are only done once.               */
03536 
03537    if (internal_file && is_namelist) {
03538       find_opnd_line_and_column((opnd_type *) &IL_OPND(list_array[FMT_IDX]),
03539                                 &line, &col);
03540       PRINTMSG(line, 472, Error, col);
03541       semantically_correct = FALSE;
03542    }
03543 
03544    if (is_call) {
03545       /* copy list_array to arg_list */
03546       for (k = 1; k <= OPND_LIST_CNT((*list_opnd)); k++) {
03547          arg_list[k]          = list_array[k];
03548       }
03549    }
03550    else {
03551       /* read, write, print */
03552 
03553       /* If PURE/ELEMENTAL subprogram, can only read/write to internal file. */
03554 
03555       if (!internal_file && 
03556            (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
03557             ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) &&
03558           (io_type == Read || io_type == Write)) {
03559          PRINTMSG(line, 1263, Error, col, 
03560                   io_type == Read ? "READ" : "WRITE",
03561                   ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))?"elemental":"pure",
03562                   AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
03563          semantically_correct = FALSE;
03564       }
03565 
03566 
03567       if (internal_file) {
03568       }
03569 
03570       /* if had advance specifier => check this stuff */
03571 
03572       if (IL_FLD(list_array[ADVANCE_IDX]) != NO_Tbl_Idx) {
03573 
03574          if (IL_FLD(list_array[FMT_IDX]) == NO_Tbl_Idx || is_namelist) {
03575             find_opnd_line_and_column((opnd_type *) 
03576                                       &IL_OPND(list_array[ADVANCE_IDX]),
03577                                       &line, &col);
03578             PRINTMSG(line, 468, Error, col);
03579             semantically_correct = FALSE;
03580          }
03581          else if (list_directed) {
03582             find_opnd_line_and_column((opnd_type *) 
03583                                       &IL_OPND(list_array[FMT_IDX]),
03584                                       &line, &col);
03585             PRINTMSG(line, 469, Error, col);
03586             semantically_correct = FALSE;
03587          }
03588 
03589          if (internal_file) {
03590             find_opnd_line_and_column((opnd_type *) 
03591                                       &IL_OPND(list_array[UNIT_IDX]),
03592                                       &line, &col);
03593             PRINTMSG(line, 470, Error, col);
03594             semantically_correct = FALSE;
03595          }
03596       }
03597 
03598       /* if REC specifier is present => check this stuff */
03599 
03600       if (IL_FLD(list_array[REC_IDX]) != NO_Tbl_Idx) {
03601 
03602          if (internal_file) {
03603             find_opnd_line_and_column((opnd_type *) 
03604                                       &IL_OPND(list_array[REC_IDX]),
03605                                       &line, &col);
03606             PRINTMSG(line, 471, Error, col);
03607             semantically_correct = FALSE;
03608          }
03609          else if (is_namelist) {
03610             find_opnd_line_and_column((opnd_type *) 
03611                                       &IL_OPND(list_array[FMT_IDX]),
03612                                       &line, &col);
03613             PRINTMSG(line, 466, Error, col,
03614                      io_type_string);
03615             semantically_correct = FALSE;
03616          }
03617       }
03618 
03619 
03620       if (is_namelist) {
03621          /* change opr */
03622          IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) = (operator_type)
03623                                       (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) + 2);
03624       }
03625       else if (IL_FLD(list_array[FMT_IDX]) == NO_Tbl_Idx) {
03626          /* unformatted */
03627          IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) = (operator_type)
03628                                       (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) + 1);
03629       }
03630 
03631       if (IL_FLD(list_array[IOSTAT_IDX]) != NO_Tbl_Idx) {
03632          have_iostat = TRUE;
03633       }
03634 
03635       /******************\
03636       |* start new list *|
03637       \******************/
03638 
03639       NTR_IR_LIST_TBL(list_idx);
03640       OPND_IDX((*list_opnd))      = list_idx;
03641 
03642 # ifdef _NO_IO_ALTERNATE_RETURN
03643       OPND_LIST_CNT((*list_opnd)) = NUM_PDG_CONTROL_LIST_ITEMS + 3;
03644 # else
03645       OPND_LIST_CNT((*list_opnd)) = NUM_PDG_CONTROL_LIST_ITEMS;
03646 # endif
03647 
03648       /**************************\
03649       |* 1 - encode/decode flag *|
03650       \**************************/
03651 
03652       IL_FLD(list_idx)     = CN_Tbl_Idx;
03653       IL_IDX(list_idx)     = CN_INTEGER_ZERO_IDX;
03654       IL_LINE_NUM(list_idx) = stmt_start_line;
03655       IL_COL_NUM(list_idx)  = stmt_start_col;
03656 
03657       /*********************\
03658       |* 2 - eeeflag value *|
03659       \*********************/
03660 
03661       constant_value = 0;
03662       constant_value |= (IL_FLD(list_array[err_idx]) != NO_Tbl_Idx) ?
03663                                  ERR_IS_PRESENT : 0;
03664       constant_value |= (IL_FLD(list_array[END_IDX]) != NO_Tbl_Idx) ?
03665                                  END_IS_PRESENT : 0;
03666       constant_value |= (IL_FLD(list_array[EOR_IDX]) != NO_Tbl_Idx) ?
03667                                  EOR_IS_PRESENT : 0;
03668       constant_value |= (IL_FLD(list_array[IOSTAT_IDX]) != NO_Tbl_Idx) ?
03669                                  IOSTAT_IS_PRESENT : 0;
03670 
03671       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03672       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03673       list_idx = IL_NEXT_LIST_IDX(list_idx);
03674 
03675       IL_FLD(list_idx) = CN_Tbl_Idx;
03676       IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, constant_value);
03677       IL_LINE_NUM(list_idx) = stmt_start_line;
03678       IL_COL_NUM(list_idx)  = stmt_start_col;
03679 
03680       /**********************\
03681       |* 3 - flflag value   *|
03682       \**********************/
03683 
03684       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03685       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03686       list_idx = IL_NEXT_LIST_IDX(list_idx);
03687 
03688       /* This is the flag for split io */
03689       /* set to FL_IO_SINGLE for now   */
03690 
03691       constant_value       = FL_IO_SINGLE;
03692 
03693       IL_FLD(list_idx)     = CN_Tbl_Idx;
03694       IL_IDX(list_idx)     = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE);
03695       IL_LINE_NUM(list_idx) = stmt_start_line;
03696       IL_COL_NUM(list_idx)  = stmt_start_col;
03697 
03698 
03699       /**********************\
03700       |* 4 - UNIT specifier *|
03701       \**********************/
03702 
03703       IL_NEXT_LIST_IDX(list_idx) = list_array[UNIT_IDX];
03704       IL_PREV_LIST_IDX(list_array[UNIT_IDX]) = list_idx;
03705       list_idx = IL_NEXT_LIST_IDX(list_idx);
03706 
03707       /***********************\
03708       |* 5 - IOSTAT variable *|
03709       \***********************/
03710 
03711       IL_NEXT_LIST_IDX(list_idx) = list_array[IOSTAT_IDX];
03712       IL_PREV_LIST_IDX(list_array[IOSTAT_IDX]) = list_idx;
03713       list_idx = IL_NEXT_LIST_IDX(list_idx);
03714 
03715       /**********************\
03716       |* 6 - REC expression *|
03717       \**********************/
03718 
03719       IL_NEXT_LIST_IDX(list_idx) = list_array[REC_IDX];
03720       IL_PREV_LIST_IDX(list_array[REC_IDX]) = list_idx;
03721       list_idx = IL_NEXT_LIST_IDX(list_idx);
03722       
03723       /*************************\
03724       |* 7 - pre-parsed format *|
03725       \*************************/
03726 
03727       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03728       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03729       list_idx = IL_NEXT_LIST_IDX(list_idx);
03730 
03731       /* get pre-parsed from somewhere */
03732 
03733       if (! is_namelist    && 
03734           ! list_directed) {
03735 
03736          if (pp_tmp) {
03737             IL_FLD(list_idx) = AT_Tbl_Idx;
03738             IL_IDX(list_idx) = pp_tmp;
03739             IL_LINE_NUM(list_idx) = stmt_start_line;
03740             IL_COL_NUM(list_idx)  = stmt_start_col;
03741          }
03742       }
03743 
03744       /*********************\
03745       |* 8 - format source *|
03746       \*********************/
03747 
03748       IL_NEXT_LIST_IDX(list_idx) = list_array[FMT_IDX];
03749       IL_PREV_LIST_IDX(list_array[FMT_IDX]) = list_idx;
03750       list_idx = IL_NEXT_LIST_IDX(list_idx);
03751       
03752       if (list_directed)
03753       {
03754          IL_OPND(list_idx) = null_opnd;
03755       }
03756 
03757       /**************************\
03758       |* 9 - ADVANCE expression *|
03759       \**************************/
03760 
03761       IL_NEXT_LIST_IDX(list_idx) = list_array[ADVANCE_IDX];
03762       IL_PREV_LIST_IDX(list_array[ADVANCE_IDX]) = list_idx;
03763       list_idx = IL_NEXT_LIST_IDX(list_idx);
03764 
03765       /************************\
03766       |* 10 - SIZE expression *|
03767       \************************/
03768 
03769       IL_NEXT_LIST_IDX(list_idx) = list_array[SIZE_IDX];
03770       IL_PREV_LIST_IDX(list_array[SIZE_IDX]) = list_idx;
03771       list_idx = IL_NEXT_LIST_IDX(list_idx);
03772       IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
03773 
03774 # ifdef _NO_IO_ALTERNATE_RETURN
03775       /************************\
03776       |* 11 - ERR label       *|
03777       \************************/
03778 
03779       if (err_list_idx == NULL_IDX) {
03780          NTR_IR_LIST_TBL(err_list_idx);
03781       }
03782 
03783       IL_NEXT_LIST_IDX(list_idx) = err_list_idx;
03784       IL_PREV_LIST_IDX(err_list_idx) = list_idx;
03785       list_idx = IL_NEXT_LIST_IDX(list_idx);
03786 
03787       /************************\
03788       |* 12 - END label       *|
03789       \************************/
03790 
03791       if (end_list_idx == NULL_IDX) {
03792          NTR_IR_LIST_TBL(end_list_idx);
03793       }
03794 
03795       IL_NEXT_LIST_IDX(list_idx) = end_list_idx;
03796       IL_PREV_LIST_IDX(end_list_idx) = list_idx;
03797       list_idx = IL_NEXT_LIST_IDX(list_idx);
03798 
03799       /************************\
03800       |* 13 - EOR label       *|
03801       \************************/
03802 
03803       if (eor_list_idx == NULL_IDX) {
03804          NTR_IR_LIST_TBL(eor_list_idx);
03805       }
03806 
03807       IL_NEXT_LIST_IDX(list_idx) = eor_list_idx;
03808       IL_PREV_LIST_IDX(eor_list_idx) = list_idx;
03809       list_idx = IL_NEXT_LIST_IDX(list_idx);
03810       IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
03811 # endif
03812 
03813    }
03814 
03815    TRACE (Func_Exit, "io_ctl_list_semantics", NULL);
03816 
03817    return(semantically_correct);
03818 
03819 }  /* io_ctl_list_semantics */
03820 
03821 /******************************************************************************\
03822 |*                                                                            *|
03823 |* Description:                                                               *|
03824 |*      <description>                                                         *|
03825 |*                                                                            *|
03826 |* Input parameters:                                                          *|
03827 |*      NONE                                                                  *|
03828 |*                                                                            *|
03829 |* Output parameters:                                                         *|
03830 |*      NONE                                                                  *|
03831 |*                                                                            *|
03832 |* Returns:                                                                   *|
03833 |*      NOTHING                                                               *|
03834 |*                                                                            *|
03835 \******************************************************************************/
03836 
03837 static boolean io_list_semantics(opnd_type     *top_opnd, 
03838                                  io_stmt_type   io_type)
03839 
03840 {
03841    int                  asg_idx;
03842    int                  attr_idx;
03843    int                  cnt;
03844    int                  col;
03845    boolean              do_var_ok;
03846    expr_arg_type        exp_desc;
03847    expr_arg_type        lcv_exp_desc;
03848    expr_arg_type        start_exp_desc;
03849    expr_arg_type        end_exp_desc;
03850    expr_arg_type        inc_exp_desc;
03851    boolean              have_seen_must_flatten = FALSE;
03852    boolean              have_seen_constructor = FALSE;
03853    int                  imp_idx;
03854    int                  line;
03855    int                  list_idx;
03856    int                  list2_idx;
03857    boolean              needs_expansion = FALSE;
03858    int                  new_do_var_idx;
03859    opnd_type            opnd;
03860    boolean              save_in_implied_do;
03861    boolean              semantically_correct = TRUE;
03862    int                  struct_list_idx;
03863    long_type            the_constant;
03864    int                  type_idx;
03865 
03866 
03867    TRACE (Func_Entry, "io_list_semantics", NULL);
03868 
03869    if (OPND_FLD((*top_opnd)) == NO_Tbl_Idx) {
03870       goto EXIT;
03871    }
03872    if (OPND_FLD((*top_opnd)) == IL_Tbl_Idx) {
03873       list_idx = OPND_IDX((*top_opnd));
03874    }
03875    else {
03876       find_opnd_line_and_column(top_opnd, &line, &col);
03877       PRINTMSG(line, 637, Internal, col);
03878    }
03879 
03880    io_item_must_flatten = FALSE;
03881    tree_has_constructor = FALSE;
03882 
03883 # ifdef _THREE_CALL_IO
03884    io_stmt_must_be_split = TRUE;
03885    three_call_model = TRUE;
03886 # endif
03887 
03888    while (list_idx != NULL_IDX) {
03889 
03890       IL_HAS_FUNCTIONS(list_idx) = FALSE;
03891       IL_MUST_BE_LOOP(list_idx)  = FALSE;
03892 
03893       if (IL_FLD(list_idx)         == IR_Tbl_Idx      &&
03894           IR_OPR(IL_IDX(list_idx)) == Implied_Do_Opr) {
03895 
03896 # ifdef _THREE_CALL_IO
03897          IL_MUST_BE_LOOP(list_idx) = TRUE;
03898 # endif
03899 
03900          /* skip do variable processing until the control values are done. */
03901 
03902          /***********************\
03903          |* do do initial value *|
03904          \***********************/
03905 
03906          list2_idx = IL_NEXT_LIST_IDX(IR_IDX_R(IL_IDX(list_idx)));
03907 
03908          COPY_OPND(opnd, IL_OPND(list2_idx));
03909          start_exp_desc.rank = 0;
03910          number_of_functions = 0;
03911          xref_state          = CIF_Symbol_Reference;
03912          semantically_correct = expr_semantics(&opnd, &start_exp_desc) &&
03913                                 semantically_correct;
03914          COPY_OPND(IL_OPND(list2_idx), opnd);
03915 
03916          if (item_has_bounds_chk(&opnd)) {
03917             number_of_functions++;
03918          }
03919 
03920          if (number_of_functions > 0) {
03921             IL_HAS_FUNCTIONS(list2_idx) = TRUE;
03922             IL_HAS_FUNCTIONS(list_idx)  = TRUE;
03923             needs_expansion             = TRUE;
03924 
03925             if (io_type == Read &&
03926                 list_idx != OPND_IDX((*top_opnd))) {
03927                io_stmt_must_be_split       = TRUE;
03928             }
03929          }
03930          else {
03931             IL_HAS_FUNCTIONS(list2_idx) = FALSE;
03932          }
03933 
03934          find_opnd_line_and_column(&opnd, &line, &col);
03935 
03936          if (start_exp_desc.rank != 0) {
03937             PRINTMSG(line, 476, Error, col);
03938             semantically_correct = FALSE;
03939          }
03940 
03941          if (start_exp_desc.linear_type == Long_Typeless) {
03942             PRINTMSG(line, 1133, Error, col);
03943             semantically_correct = FALSE;
03944          }
03945          else if (start_exp_desc.type != Integer                      &&
03946                   start_exp_desc.type != Typeless                     &&
03947                   (start_exp_desc.type != Real || 
03948                    (start_exp_desc.linear_type != REAL_DEFAULT_TYPE    &&
03949                     start_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) {
03950 
03951             PRINTMSG(line, 477, Error, col);
03952             semantically_correct = FALSE;
03953          }
03954          else if (start_exp_desc.type == Real) {
03955             PRINTMSG(line, 943, Comment, col);
03956          }
03957 
03958          COPY_OPND(opnd, IL_OPND(list2_idx));
03959          cast_to_cg_default(&opnd, &start_exp_desc);
03960          COPY_OPND(IL_OPND(list2_idx), opnd);
03961 
03962          /************************\
03963          |* do do terminal value *|
03964          \************************/
03965 
03966          list2_idx = IL_NEXT_LIST_IDX(list2_idx);
03967 
03968          COPY_OPND(opnd, IL_OPND(list2_idx));
03969          end_exp_desc.rank = 0;
03970          number_of_functions = 0;
03971