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

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_ctl_flow.c        5.13    10/12/99 10:54:10\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 # include "fmath.h"             /* Get HUGE values for various kind types.    */
00046 
00047 # include "globals.m"
00048 # include "tokens.m"
00049 # include "sytb.m"
00050 # include "s_globals.m"
00051 # include "debug.m"
00052 
00053 # include "globals.h"
00054 # include "tokens.h"
00055 # include "sytb.h"
00056 # include "s_globals.h"
00057 
00058 
00059 /*****************************************************************\
00060 |* Function prototypes of static functions declared in this file *|
00061 \*****************************************************************/
00062 
00063 static void     case_value_range_semantics (int, int, int);
00064 static void     chk_for_unlabeled_stmt (void);
00065 static boolean  do_loop_expr_semantics (int, int, opnd_type *);
00066 static void     insert_on_left (int, int, int);
00067 static void     setup_interchange_level_list(opnd_type);
00068 static void     clear_cdir_switches(void);
00069 static void     short_circuit_high_level_if(void);
00070 static boolean  check_stat_variable(int, opnd_type *, int);
00071 static void     asg_opnd_to_tmp(int, opnd_type *, int, int, sh_position_type);
00072 static void     gen_Dv_Set_stmt(opnd_type *, operator_type, int, opnd_type *,
00073                                 sh_position_type);
00074 static boolean  check_forall_triplet_for_index(opnd_type *);
00075 static boolean  gen_forall_max_expr(int, opnd_type *);
00076 static void     gen_forall_branch_around(opnd_type *);
00077 static boolean  gen_forall_tmp_bd_entry(expr_arg_type *,int *, int, int);
00078 static void     determine_lb_ub(int, int, int);
00079 static boolean  forall_mask_needs_tmp(opnd_type *);
00080 static void     process_attr_links(opnd_type *);
00081 static int      gen_forall_derived_type(int, int, int, int);
00082 
00083 static int      calculate_iteration_count (int, int, int, int, int);
00084 static int      convert_to_do_var_type (int, int); 
00085 
00086 /***************************************\
00087 |* Static variables used in this file. *|
00088 \***************************************/
00089 
00090 # ifndef _HIGH_LEVEL_DO_LOOP_FORM
00091 static int      preamble_start_sh_idx;
00092 static int      preamble_end_sh_idx;
00093 # endif
00094 
00095 static int      dt_counter = 0;
00096 
00097 extern void     (*stmt_semantics[]) ();
00098 
00099 extern boolean  processing_do_var;
00100 extern boolean  has_present_opr;
00101 
00102 # ifdef _WHIRL_HOST64_TARGET64
00103 extern int double_stride;
00104 # endif /* _WHIRL_HOST64_TARGET64 */
00105 
00106 
00107 /******************************************************************************\
00108 |*                                                                            *|
00109 |* Description:                                                               *|
00110 |*      BNF        - ALLOCATE ( allocation-list [, STAT = stat-variable] )    *|
00111 |*                                                                            *|
00112 |* Input parameters:                                                          *|
00113 |*      NONE                                                                  *|
00114 |*                                                                            *|
00115 |* Output parameters:                                                         *|
00116 |*      NONE                                                                  *|
00117 |*                                                                            *|
00118 |* Returns:                                                                   *|
00119 |*      NONE                                                                  *|
00120 |*                                                                            *|
00121 \******************************************************************************/
00122 
00123 void allocate_stmt_semantics (void)
00124 
00125 {
00126    int                  alloc_obj_idx;
00127    int                  attr_idx;
00128    int                  bd_idx;
00129    int                  bd_list_idx;
00130    int                  cn_idx;
00131    int                  col = 0;
00132    opnd_type            dope_opnd;
00133    int                  dv_idx;
00134    expr_arg_type        exp_desc;
00135    boolean              has_pe_ref = FALSE;
00136    boolean              has_normal_ref = FALSE;
00137    int                  i;
00138    int                  ir_idx;
00139    int                  lb_list_idx;
00140    opnd_type            len_opnd;
00141    int                  line = 0;
00142    int                  list_idx;
00143    int                  list_idx2;
00144    int                  loc_idx;
00145    int                  max_idx;
00146    int                  mult_idx;
00147    opnd_type            opnd;
00148    opnd_type            opnd2;
00149    int                  pe_bd_idx = NULL_IDX;
00150    int                  plus_idx;
00151    opnd_type            prev_xt_opnd;
00152    int                  ptee_bd_idx = NULL_IDX;
00153    int                  save_curr_stmt_sh_idx;
00154    boolean              semantically_correct    = TRUE;
00155    int                  stat_col;
00156    int                  stat_line;
00157    int                  stat_list_idx;
00158    opnd_type            stat_opnd;
00159    size_offset_type     stride;
00160    opnd_type            stride_opnd;
00161    int                  tmp_idx;
00162    int                  ub_list_idx;
00163    opnd_type            xt_opnd;
00164 
00165    TRACE (Func_Entry, "allocate_stmt_semantics", NULL);
00166 
00167 
00168    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00169 
00170    /* check stat var */
00171 
00172    NTR_IR_LIST_TBL(stat_list_idx);
00173    IL_FLD(stat_list_idx) = CN_Tbl_Idx;
00174    IL_IDX(stat_list_idx) = CN_INTEGER_ZERO_IDX;
00175    IL_LINE_NUM(stat_list_idx) = IR_LINE_NUM(ir_idx);
00176    IL_COL_NUM(stat_list_idx) = IR_COL_NUM(ir_idx);
00177 
00178    if (IR_FLD_R(ir_idx) != NO_Tbl_Idx) {
00179       check_stat_variable(ir_idx, &stat_opnd, stat_list_idx);
00180       find_opnd_line_and_column(&stat_opnd, &stat_line, &stat_col);
00181    }
00182 
00183    list_idx = IR_IDX_L(ir_idx);
00184 
00185 
00186    while (list_idx != NULL_IDX ) { 
00187 
00188       COPY_OPND(opnd, IL_OPND(list_idx));
00189       exp_desc.rank = 0;
00190       xref_state    = CIF_Symbol_Modification;
00191       semantically_correct = expr_semantics(&opnd, &exp_desc)
00192                              && semantically_correct;
00193 # if 0
00194      COPY_OPND(IL_OPND(list_idx), opnd);
00195 
00196       if (exp_desc.rank != 0) {
00197          find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
00198                                    &line,
00199                                    &col);
00200 
00201          PRINTMSG(line, 404, Error, col);
00202          semantically_correct = FALSE;
00203       }
00204 
00205       if (IR_FLD_R(ir_idx) != NO_Tbl_Idx                              &&
00206           OPND_FLD(stat_opnd) != NO_Tbl_Idx                           &&
00207           cmp_ref_trees(&stat_opnd,
00208                         (opnd_type *)&IR_OPND_L(IL_IDX(list_idx)))) {
00209 
00210          /* stat var can't alloc obj in same stmt */
00211          PRINTMSG(stat_line, 413, Error, stat_col);
00212          semantically_correct = FALSE;
00213       }
00214 
00215       attr_idx  = find_left_attr(&opnd);
00216 
00217       if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)) {
00218          semantically_correct = FALSE;
00219          find_opnd_line_and_column(&opnd, &line, &col);
00220          PRINTMSG(line, 1270, Error, col,
00221                   AT_OBJ_NAME_PTR(attr_idx),
00222                   ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental");
00223          goto EXIT;
00224       }
00225 
00226       if (!semantically_correct) {
00227          goto EXIT;
00228       }
00229 
00230       attr_idx                          = find_base_attr(&opnd, &line, &col);
00231       ATD_PTR_ASSIGNED(attr_idx)        = TRUE;
00232       bd_idx                            = ATD_ARRAY_IDX(attr_idx);
00233 
00234 # ifdef COARRAY_FORTRAN
00235       if (ATD_ALLOCATABLE(attr_idx) &&
00236           ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
00237          pe_bd_idx = ATD_PE_ARRAY_IDX(ATD_VARIABLE_TMP_IDX(attr_idx));
00238          ptee_bd_idx = ATD_ARRAY_IDX(ATD_VARIABLE_TMP_IDX(attr_idx));
00239          has_pe_ref = TRUE;
00240       }
00241       else {
00242          has_normal_ref = TRUE;
00243          pe_bd_idx = NULL_IDX;
00244          ptee_bd_idx = NULL_IDX;
00245       }
00246 # endif
00247 
00248       /* fill in bound info for each dimension */
00249 
00250       while (OPND_FLD(opnd) == IR_Tbl_Idx &&
00251              (IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr ||
00252               IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr)) {
00253          COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
00254       }
00255 
00256       if (OPND_FLD(opnd)         == IR_Tbl_Idx     &&
00257           IR_OPR(OPND_IDX(opnd)) == Alloc_Obj_Opr) {
00258 
00259          alloc_obj_idx = OPND_IDX(opnd);
00260          COPY_OPND(dope_opnd, IR_OPND_L(OPND_IDX(opnd)));
00261 
00262          bd_list_idx = IR_IDX_R(OPND_IDX(opnd));
00263 
00264           if (OPND_FLD(dope_opnd) == IR_Tbl_Idx &&
00265              IR_OPR(OPND_IDX(dope_opnd)) == Dv_Deref_Opr) {
00266     
00267             COPY_OPND(dope_opnd, IR_OPND_L(OPND_IDX(dope_opnd)));
00268          }
00269          else {
00270             find_opnd_line_and_column(&opnd, &line, &col);
00271             PRINTMSG(line, 626, Internal, col,
00272                      "Dv_Deref_Opr", "allocate_stmt_semantics");
00273          }  
00274            COPY_OPND(dope_opnd, IR_OPND_L(OPND_IDX(dope_opnd))); 
00275       }
00276       else {
00277          find_opnd_line_and_column(&opnd, &line, &col);
00278          PRINTMSG(line, 626, Internal, col,
00279                   "Alloc_Obj_Opr", "allocate_stmt_semantics");
00280       }
00281 
00282 
00283       find_opnd_line_and_column(&dope_opnd, &line, &col);
00284 
00285       if (bd_idx || pe_bd_idx) {
00286 
00287          /* set the a_contig flag to TRUE */
00288 
00289          OPND_FLD(opnd2) = CN_Tbl_Idx;
00290          OPND_IDX(opnd2) = CN_INTEGER_ONE_IDX;
00291          OPND_LINE_NUM(opnd2) = line;
00292          OPND_COL_NUM(opnd2)  = col;
00293 
00294          gen_Dv_Set_stmt(&dope_opnd, Dv_Set_A_Contig, 0, &opnd2, Before);
00295 
00296          for (i = 1; i <= IR_LIST_CNT_R(OPND_IDX(opnd)); i++) {
00297 
00298             if (IL_FLD(bd_list_idx) == IL_Tbl_Idx) {
00299                /* have a colon */
00300 
00301                if (IL_FLD(IL_IDX(bd_list_idx)) == NO_Tbl_Idx) {
00302                   /* have just upper bound */
00303                   lb_list_idx = NULL_IDX;
00304                }
00305                else {
00306                   lb_list_idx = IL_IDX(bd_list_idx);
00307                }
00308 
00309                if (IL_FLD(IL_NEXT_LIST_IDX(IL_IDX(bd_list_idx)))
00310                                                       == NO_Tbl_Idx) {
00311 
00312                   /* have :*    */
00313                   ub_list_idx = NULL_IDX;
00314                }
00315                else {
00316                   ub_list_idx = IL_NEXT_LIST_IDX(IL_IDX(bd_list_idx));
00317                }
00318             }
00319             else if (IL_FLD(bd_list_idx) == NO_Tbl_Idx) {
00320                /* have [*] */
00321                lb_list_idx = NULL_IDX;
00322                ub_list_idx = NULL_IDX;
00323             }
00324             else {
00325                /* have just upper bound */
00326                lb_list_idx = NULL_IDX;
00327                ub_list_idx = bd_list_idx;
00328             }
00329 
00330             if (! IL_PE_SUBSCRIPT(bd_list_idx)) {
00331                if (lb_list_idx == NULL_IDX) {
00332                   OPND_FLD(opnd2) = CN_Tbl_Idx;
00333                   OPND_IDX(opnd2) = CN_INTEGER_ONE_IDX;
00334                   OPND_LINE_NUM(opnd2) = line;
00335                   OPND_COL_NUM(opnd2)  = col;
00336                }
00337                else {
00338                   COPY_OPND(opnd2, IL_OPND(lb_list_idx));
00339                }
00340 
00341                gen_Dv_Set_stmt(&dope_opnd, Dv_Set_Low_Bound, i, &opnd2, Before);
00342             }
00343 
00344             if (pe_bd_idx) {
00345                if (IL_PE_SUBSCRIPT(bd_list_idx)) {
00346                   tmp_idx = BD_LB_IDX(pe_bd_idx, i - BD_RANK(bd_idx));
00347                }
00348                else {
00349                   tmp_idx = BD_LB_IDX(ptee_bd_idx, i);
00350                }
00351 
00352                if (lb_list_idx == NULL_IDX) {
00353                   OPND_FLD(opnd2) = CN_Tbl_Idx;
00354                   OPND_IDX(opnd2) = CN_INTEGER_ONE_IDX;
00355                   OPND_LINE_NUM(opnd2) = line;
00356                   OPND_COL_NUM(opnd2)  = col;
00357                }
00358                else {
00359                   COPY_OPND(opnd2, IL_OPND(lb_list_idx));
00360                }
00361 
00362                asg_opnd_to_tmp(tmp_idx, &opnd2, line, col, Before);
00363 
00364                if (IL_PE_SUBSCRIPT(bd_list_idx)) {
00365                   tmp_idx = BD_UB_IDX(pe_bd_idx, i - BD_RANK(bd_idx));
00366                }
00367                else {
00368                   tmp_idx = BD_UB_IDX(ptee_bd_idx, i);
00369                }
00370 
00371                if (ub_list_idx != NULL_IDX) {
00372                   asg_opnd_to_tmp(tmp_idx, &IL_OPND(ub_list_idx),
00373                                   line, col, Before);
00374                }
00375             }
00376 
00377             if (ub_list_idx == NULL_IDX) {
00378                /* intentionally blank */
00379             }
00380             else if (lb_list_idx) {
00381                /* make expression for extent */
00382                /* upper - lower + 1 */
00383                plus_idx = gen_ir(IR_Tbl_Idx,
00384                               gen_ir(IL_FLD(ub_list_idx), IL_IDX(ub_list_idx),
00385                                   Minus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
00386                                      IL_FLD(lb_list_idx), IL_IDX(lb_list_idx)),
00387                                Plus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
00388                                  CN_Tbl_Idx, CN_INTEGER_ONE_IDX);
00389 
00390                NTR_IR_TBL(max_idx);
00391                IR_OPR(max_idx) = Max_Opr;
00392                IR_TYPE_IDX(max_idx) = SA_INTEGER_DEFAULT_TYPE;
00393                IR_LINE_NUM(max_idx) = line;
00394                IR_COL_NUM(max_idx) = col;
00395                IR_FLD_L(max_idx) = IL_Tbl_Idx;
00396                IR_LIST_CNT_L(max_idx) = 2;
00397 
00398                NTR_IR_LIST_TBL(list_idx2);
00399                IR_IDX_L(max_idx) = list_idx2;
00400                IL_FLD(list_idx2) = CN_Tbl_Idx;
00401                IL_IDX(list_idx2) = CN_INTEGER_ZERO_IDX;
00402                IL_LINE_NUM(list_idx2) = line;
00403                IL_COL_NUM(list_idx2) = col;
00404 
00405                NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
00406                IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
00407                list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
00408 
00409                IL_FLD(list_idx2) = IR_Tbl_Idx;
00410                IL_IDX(list_idx2) = plus_idx;
00411 
00412                OPND_FLD(xt_opnd) = IR_Tbl_Idx;
00413                OPND_IDX(xt_opnd) = max_idx;
00414 
00415                exp_desc.rank        = 0;
00416                xref_state           = CIF_No_Usage_Rec;
00417                semantically_correct = expr_semantics(&xt_opnd, &exp_desc);
00418             }
00419             else {
00420                /* use upper bound for extent */
00421 
00422                NTR_IR_TBL(max_idx);
00423                IR_OPR(max_idx) = Max_Opr;
00424                IR_TYPE_IDX(max_idx) = SA_INTEGER_DEFAULT_TYPE;
00425                IR_LINE_NUM(max_idx) = line;
00426                IR_COL_NUM(max_idx) = col;
00427                IR_FLD_L(max_idx) = IL_Tbl_Idx;
00428                IR_LIST_CNT_L(max_idx) = 2;
00429 
00430                NTR_IR_LIST_TBL(list_idx2);
00431                IR_IDX_L(max_idx) = list_idx2;
00432                IL_FLD(list_idx2) = CN_Tbl_Idx;
00433                IL_IDX(list_idx2) = CN_INTEGER_ZERO_IDX;
00434                IL_LINE_NUM(list_idx2) = line;
00435                IL_COL_NUM(list_idx2) = col;
00436 
00437                NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
00438                IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
00439                list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
00440 
00441                COPY_OPND(IL_OPND(list_idx2), IL_OPND(ub_list_idx));
00442 
00443                OPND_FLD(xt_opnd) = IR_Tbl_Idx;
00444                OPND_IDX(xt_opnd) = max_idx;
00445 
00446                exp_desc.rank        = 0;
00447                xref_state           = CIF_No_Usage_Rec;
00448                semantically_correct = expr_semantics(&xt_opnd, &exp_desc);
00449             }
00450 
00451             if (! IL_PE_SUBSCRIPT(bd_list_idx)) {
00452                gen_Dv_Set_stmt(&dope_opnd, Dv_Set_Extent, i, &xt_opnd, Before);
00453             }
00454 
00455             if (pe_bd_idx) {
00456                if (IL_PE_SUBSCRIPT(bd_list_idx)) {
00457                   tmp_idx = BD_XT_IDX(pe_bd_idx, i - BD_RANK(bd_idx));
00458                }
00459                else {
00460                   tmp_idx = BD_XT_IDX(ptee_bd_idx, i);
00461                }
00462 
00463                if (ub_list_idx == NULL_IDX) {
00464                   OPND_FLD(xt_opnd) = CN_Tbl_Idx;
00465                   OPND_IDX(xt_opnd) = CN_INTEGER_ONE_IDX;
00466                   OPND_LINE_NUM(xt_opnd) = line;
00467                   OPND_COL_NUM(xt_opnd) = col;
00468                }
00469                else {
00470                   asg_opnd_to_tmp(tmp_idx, &xt_opnd, line, col, Before);
00471                }
00472 
00473                if (i == 1 ||
00474                    i == BD_RANK(bd_idx) + 1) {
00475 
00476                   COPY_OPND(len_opnd, xt_opnd);
00477                }
00478                else {
00479                   mult_idx = gen_ir(OPND_FLD(len_opnd), OPND_IDX(len_opnd),
00480                                  Mult_Opr, SA_INTEGER_DEFAULT_TYPE,line,col,
00481                                     OPND_FLD(xt_opnd), OPND_IDX(xt_opnd));
00482 
00483                   OPND_FLD(len_opnd)       = IR_Tbl_Idx;
00484                   OPND_IDX(len_opnd)       = mult_idx;
00485                }
00486 
00487                if (i == BD_RANK(bd_idx) ||
00488                    i == BD_RANK(bd_idx) + BD_RANK(pe_bd_idx)) {
00489 
00490                   if (IL_PE_SUBSCRIPT(bd_list_idx)) {
00491                      tmp_idx = BD_LEN_IDX(pe_bd_idx);
00492                   }
00493                   else {
00494                      tmp_idx = BD_LEN_IDX(ptee_bd_idx);
00495                   }
00496                   exp_desc.rank            = 0;
00497                   xref_state               = CIF_No_Usage_Rec;
00498                   semantically_correct = expr_semantics(&len_opnd, &exp_desc) &&
00499                                          semantically_correct;
00500 
00501                   asg_opnd_to_tmp(tmp_idx, &len_opnd, line, col, Before);
00502                }
00503             }
00504 
00505 
00506             if (i == 1) {
00507 # ifdef _WHIRL_HOST64_TARGET64
00508                double_stride = 1;
00509 # endif /* _WHIRL_HOST64_TARGET64 */
00510 
00511                set_stride_for_first_dim(ATD_TYPE_IDX(attr_idx), &stride);
00512 
00513 # ifdef _WHIRL_HOST64_TARGET64
00514                double_stride = 0;
00515 # endif /* _WHIRL_HOST64_TARGET64 */
00516 
00517                gen_opnd(&stride_opnd, stride.idx, stride.fld, line, col);
00518             }
00519             else if (pe_bd_idx &&
00520                      i == BD_RANK(bd_idx) + 1) {
00521               gen_opnd(&stride_opnd, CN_INTEGER_ONE_IDX, CN_Tbl_Idx, line, col);
00522             }
00523             else {
00524                /* Create Stride * Extent */
00525                mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd),
00526                               Mult_Opr, SA_INTEGER_DEFAULT_TYPE,line,col,
00527                                  OPND_FLD(prev_xt_opnd),OPND_IDX(prev_xt_opnd));
00528 
00529                OPND_FLD(stride_opnd)    = IR_Tbl_Idx;
00530                OPND_IDX(stride_opnd)    = mult_idx;
00531                exp_desc.rank            = 0;
00532                xref_state               = CIF_No_Usage_Rec;
00533 
00534                semantically_correct = expr_semantics(&stride_opnd, &exp_desc) &&
00535                                       semantically_correct;
00536             }
00537 
00538             if (! IL_PE_SUBSCRIPT(bd_list_idx)) {
00539                gen_Dv_Set_stmt(&dope_opnd, Dv_Set_Stride_Mult, i,
00540                                &stride_opnd, Before);
00541             }
00542 
00543             if (pe_bd_idx) {
00544                if (IL_PE_SUBSCRIPT(bd_list_idx)) {
00545                   tmp_idx = BD_SM_IDX(pe_bd_idx, i - BD_RANK(bd_idx));
00546                }
00547                else {
00548                   tmp_idx = BD_SM_IDX(ptee_bd_idx, i);
00549                }
00550 
00551                asg_opnd_to_tmp(tmp_idx, &stride_opnd, line, col, Before);
00552             }
00553 
00554 
00555             COPY_OPND(prev_xt_opnd, xt_opnd);
00556             bd_list_idx = IL_NEXT_LIST_IDX(bd_list_idx);
00557          }
00558       }
00559 
00560       if (pe_bd_idx) {
00561          /* set the ptr to BASE dope vector */
00562 
00563          save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00564 
00565          tmp_idx = ATD_PTR_IDX(ATD_VARIABLE_TMP_IDX(attr_idx));
00566 
00567          dv_idx = gen_ir(OPND_FLD(dope_opnd), OPND_IDX(dope_opnd),
00568                        Dv_Access_Base_Addr, CG_INTEGER_DEFAULT_TYPE,line,col,
00569                          NO_Tbl_Idx, NULL_IDX);
00570 
00571          OPND_FLD(opnd2) = IR_Tbl_Idx;
00572          OPND_IDX(opnd2) = dv_idx;
00573 
00574          asg_opnd_to_tmp(tmp_idx, &opnd2, line, col, After);
00575 
00576          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00577       }
00578 
00579       /* fill in new dope vectors */
00580 
00581       if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
00582           (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
00583            ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))))) {
00584 
00585          COPY_OPND(opnd, IR_OPND_L(alloc_obj_idx));
00586 
00587          if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
00588             semantically_correct = gen_whole_subscript(&opnd, &exp_desc)
00589                                    && semantically_correct;
00590          }
00591 
00592          save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00593 
00594          process_cpnt_inits(&opnd,
00595                             TYP_IDX(ATD_TYPE_IDX(attr_idx)),
00596                             gen_dv_whole_def_init,
00597                             Asg_Opr,
00598                             After);
00599 
00600          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00601       }
00602 
00603       /* replace allocate obj with loc of dope vector */
00604 
00605 /*       NTR_IR_TBL(loc_idx);
00606       IR_OPR(loc_idx) = Aloc_Opr;
00607       IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
00608       IR_LINE_NUM(loc_idx) = line;
00609       IR_COL_NUM(loc_idx)  = col;
00610       COPY_OPND(IR_OPND_L(loc_idx), dope_opnd);
00611 
00612       IL_FLD(list_idx) = IR_Tbl_Idx;
00613       IL_IDX(list_idx) = loc_idx;
00614 
00615       list_idx = IL_NEXT_LIST_IDX(list_idx);
00616 */
00617 
00618 # endif /* June */
00619 
00620       list_idx = IL_NEXT_LIST_IDX(list_idx); 
00621 
00622    }
00623 
00624    if (glb_tbl_idx[Allocate_Attr_Idx] == NULL_IDX) {
00625       glb_tbl_idx[Allocate_Attr_Idx] = create_lib_entry_attr(ALLOCATE_LIB_ENTRY,
00626                                                              ALLOCATE_NAME_LEN,
00627                                                              line,
00628                                                              col);
00629    }
00630 
00631    ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Allocate_Attr_Idx]);
00632 
00633    if (has_pe_ref && has_normal_ref) {
00634       /* must pull the normal refs off on their own call */
00635       gen_split_alloc(ir_idx,
00636                       glb_tbl_idx[Allocate_Attr_Idx],
00637                       stat_list_idx);
00638    }
00639 
00640 # ifdef _ALLOCATE_IS_CALL
00641    set_up_allocate_as_call(ir_idx,
00642                            glb_tbl_idx[Allocate_Attr_Idx],
00643                            stat_list_idx,
00644                            has_pe_ref);
00645 # else
00646 
00647    NTR_IR_LIST_TBL(list_idx);
00648    IR_FLD_R(ir_idx) = IL_Tbl_Idx;
00649    IR_IDX_R(ir_idx) = list_idx;
00650    IR_LIST_CNT_R(ir_idx) = 3;
00651 
00652    IL_FLD(list_idx) = AT_Tbl_Idx;
00653    IL_IDX(list_idx) = glb_tbl_idx[Allocate_Attr_Idx];
00654    IL_LINE_NUM(list_idx) = line;
00655    IL_COL_NUM(list_idx)  = col;
00656  
00657    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00658    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00659    list_idx = IL_NEXT_LIST_IDX(list_idx);
00660 
00661    IL_FLD(list_idx) = CN_Tbl_Idx;
00662    IL_IDX(list_idx) = gen_alloc_header_const(Integer_8,
00663                                              IR_LIST_CNT_L(ir_idx),
00664                                              has_pe_ref,
00665                                              &cn_idx);
00666    IL_LINE_NUM(list_idx) = line;
00667    IL_COL_NUM(list_idx)  = col;
00668 
00669    IL_NEXT_LIST_IDX(list_idx) = stat_list_idx;
00670    IL_PREV_LIST_IDX(stat_list_idx) = list_idx;
00671 
00672 # endif
00673 
00674 
00675 EXIT:
00676 
00677    TRACE (Func_Exit, "allocate_stmt_semantics", NULL);
00678 
00679    return;
00680 
00681 }  /* allocate_stmt_semantics */
00682 
00683 
00684 /******************************************************************************\
00685 |*                                                                            *|
00686 |* Description:                                                               *|
00687 |*      Check the conditional expression to make sure that it is of an        *|
00688 |*      acceptable numeric type and that it is scalar.                        *|
00689 |*                                                                            *|
00690 |* Input parameters:                                                          *|
00691 |*      NONE                                                                  *|
00692 |*                                                                            *|
00693 |* Output parameters:                                                         *|
00694 |*      NONE                                                                  *|
00695 |*                                                                            *|
00696 |* Returns:                                                                   *|
00697 |*      NONE                                                                  *|
00698 |*                                                                            *|
00699 \******************************************************************************/
00700 
00701 void arith_if_stmt_semantics (void)
00702 
00703 {
00704    int                  br_aif_idx;
00705    int                  col;
00706    opnd_type            cond_expr;
00707    expr_arg_type        exp_desc;
00708    int                  line;
00709 
00710 
00711    TRACE (Func_Entry, "arith_if_stmt_semantics", NULL);
00712    
00713    /* If the arithmetic IF is followed by a stmt that is not labeled, issue   */
00714    /* a warning message (at the following stmt) that the stmt can not be      */
00715    /* reached.                                                                */
00716 
00717    chk_for_unlabeled_stmt();
00718 
00719    /* The conditional expression must be scalar and of a numeric type other   */
00720    /* than complex.                                                           */
00721    
00722    br_aif_idx = SH_IR_IDX(curr_stmt_sh_idx);
00723    COPY_OPND(cond_expr, IR_OPND_L(br_aif_idx));
00724    exp_desc.rank = 0;
00725    xref_state    = CIF_Symbol_Reference;
00726 
00727    if (expr_semantics(&cond_expr, &exp_desc)) {
00728 
00729       COPY_OPND(IR_OPND_L(br_aif_idx), cond_expr);
00730 
00731       find_opnd_line_and_column(&cond_expr, &line, &col);
00732 
00733       if (exp_desc.type != Integer  &&  exp_desc.type != Real) {
00734 
00735          /* CRI extension:  The "type" of the expression may be typeless.     */
00736          /* PDGCS treats the expression (result) as an integer.               */
00737          /* If the expression is a typeless constant that is longer than a    */
00738          /* word, truncate it and reenter it as an integer.                   */
00739 
00740          if (exp_desc.type != Typeless) {
00741             PRINTMSG(line, 409, Error, col);
00742          }
00743          else if (exp_desc.linear_type == Long_Typeless) {
00744             IR_IDX_L(br_aif_idx) =
00745                ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE,
00746                              FALSE,
00747                              &CN_CONST(IR_IDX_L(br_aif_idx)));
00748          }
00749          else if (exp_desc.linear_type == Short_Typeless_Const) {
00750             IR_IDX_L(br_aif_idx) = 
00751                cast_typeless_constant(IR_IDX_L(br_aif_idx),
00752                                       INTEGER_DEFAULT_TYPE,
00753                                       line,
00754                                       col);
00755          }
00756       } 
00757 
00758       if (exp_desc.rank != 0) {
00759          PRINTMSG(IR_LINE_NUM(br_aif_idx), 410, Error,
00760                   IR_COL_NUM(br_aif_idx));
00761       }
00762 
00763    }
00764 
00765    TRACE (Func_Exit, "arith_if_stmt_semantics", NULL);
00766 
00767    return;
00768 
00769 }  /* arith_if_stmt_semantics */
00770 
00771 
00772 /******************************************************************************\
00773 |*                                                                            *|
00774 |* Description:                                                               *|
00775 |*      This procedure performs semantic checks on an ASSIGN statement:       *|
00776 |*                                                                            *|
00777 |*           ASSIGN label TO scalar-int-variable                              *|
00778 |*                                                                            *|
00779 |* Input parameters:                                                          *|
00780 |*      NONE                                                                  *|
00781 |*                                                                            *|
00782 |* Output parameters:                                                         *|
00783 |*      NONE                                                                  *|
00784 |*                                                                            *|
00785 |* Global data changed:                                                       *|
00786 |*      curr_stmt_category                                                    *|
00787 |*                                                                            *|
00788 |* Returns:                                                                   *|
00789 |*      NONE                                                                  *|
00790 |*                                                                            *|
00791 |* Algorithm notes:                                                           *|
00792 |*      The semantic checks made in this routine are very similar to those    *|
00793 |*      made in goto_stmt_semantics for the assigned GO TO.  If you make a    *|
00794 |*      change here, chances are the same (or similar) change will need to be *|
00795 |*      made to the assigned GO TO code.                                      *|
00796 |*                                                                            *|
00797 \******************************************************************************/
00798 
00799 void    assign_stmt_semantics (void)
00800 
00801 {
00802    expr_arg_type        asg_var_desc;
00803    opnd_type            asg_var_opnd;
00804    int                  attr_idx;
00805    int                  column;
00806    int                  ir_idx;
00807    int                  label_idx;
00808    int                  line;
00809    int                  loc_idx;
00810    int                  msg_num;
00811 
00812 # if defined(GENERATE_WHIRL)
00813    int                  tmp_idx;
00814 # endif
00815 
00816         
00817    TRACE (Func_Entry, "assign_stmt_semantics", NULL);
00818 
00819    ir_idx            = SH_IR_IDX(curr_stmt_sh_idx);
00820    COPY_OPND(asg_var_opnd, IR_OPND_R(ir_idx));
00821    asg_var_desc.rank = 0;
00822    xref_state        = CIF_Symbol_Reference;
00823 
00824    if (expr_semantics(&asg_var_opnd, &asg_var_desc)) {
00825 
00826       switch (OPND_FLD(asg_var_opnd)) {
00827 
00828          case AT_Tbl_Idx:
00829             COPY_OPND(IR_OPND_R(ir_idx), asg_var_opnd);
00830             attr_idx = OPND_IDX(asg_var_opnd);
00831 
00832             if (AT_OBJ_CLASS(attr_idx) == Data_Obj                          &&
00833 # ifdef _TARGET_OS_MAX   
00834                 /* addresses on MPP are > 32 bits !!  */
00835                 TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) == Integer_8             &&
00836 # else 
00837                 TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) == INTEGER_DEFAULT_TYPE  &&
00838 # endif
00839                 asg_var_desc.rank == 0) { 
00840 
00841                IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE;
00842 
00843                if ( ! check_for_legal_define(&asg_var_opnd)) {
00844                   /* intentionally blank */
00845                }
00846                else {
00847       
00848                   /* If the ASSIGN label is OK and it's defined on an         */
00849                   /* executable stmt and it doesn't already exist in the      */
00850                   /* ASSIGN label chain then add it to (the beginning of) the */
00851                   /* chain.  This chain is needed by PDGCS (the interface     */
00852                   /* gives it to them at each assigned GOTO).                 */
00853                   /* Note:  Can't use ATL_NEXT_ASG_LBL_IDX being NULL_IDX to  */
00854                   /* determine whether or not the label already exists in the */
00855                   /* chain because this field is NULL_IDX in the last entry   */
00856                   /* in the chain.  If the last label appeared in a second    */
00857                   /* ASSIGN stmt, the code would add it to the chain again.   */
00858  
00859                   label_idx = IR_IDX_L(ir_idx);
00860 
00861                   if (! AT_DCL_ERR(label_idx)  &&  ATL_EXECUTABLE(label_idx)  &&
00862                       ! ATL_IN_ASSIGN_LBL_CHAIN(label_idx)) {
00863                      ATL_NEXT_ASG_LBL_IDX(label_idx)     =
00864                         SCP_ASSIGN_LBL_CHAIN(curr_scp_idx);
00865                      SCP_ASSIGN_LBL_CHAIN(curr_scp_idx) = label_idx;
00866                      ATL_IN_ASSIGN_LBL_CHAIN(label_idx)  = TRUE;
00867                   }
00868 
00869                   if (! AT_DCL_ERR(label_idx)  &&
00870                       ATL_CLASS(label_idx) == Lbl_Format) {
00871                      IR_OPR(ir_idx)         = Asg_Opr;
00872 
00873 # if defined(GENERATE_WHIRL)
00874 
00875                      if (storage_bit_size_tbl[asg_var_desc.linear_type] !=
00876                             storage_bit_size_tbl[SA_INTEGER_DEFAULT_TYPE]) {
00877 
00878                         if (ATD_ASSIGN_TMP_IDX(attr_idx) == NULL_IDX) {
00879 
00880                            tmp_idx = gen_compiler_tmp(stmt_start_line, 
00881                                                       stmt_start_col,
00882                                                       Shared, TRUE);
00883                            AT_SEMANTICS_DONE(tmp_idx)= TRUE;
00884                            ATD_TYPE_IDX(tmp_idx)     = SA_INTEGER_DEFAULT_TYPE;
00885                            ATD_STOR_BLK_IDX(tmp_idx) =
00886                                               SCP_SB_STACK_IDX(curr_scp_idx);
00887                            ATD_ASSIGN_TMP_IDX(attr_idx) = tmp_idx;
00888                         }
00889                         else {
00890                            tmp_idx = ATD_ASSIGN_TMP_IDX(attr_idx);
00891                         }
00892 
00893                         IR_FLD_L(ir_idx) = AT_Tbl_Idx;
00894                         IR_IDX_L(ir_idx) = tmp_idx;
00895                      }
00896                      else {
00897                         COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
00898                      }
00899 # else
00900                      COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
00901 # endif
00902                      NTR_IR_TBL(loc_idx);
00903                      IR_OPR(loc_idx)        = Aloc_Opr;
00904                      IR_TYPE_IDX(loc_idx)   = CRI_Ptr_8;
00905                      IR_LINE_NUM(loc_idx)   = IR_LINE_NUM(ir_idx);
00906                      IR_COL_NUM(loc_idx)    = IR_COL_NUM(ir_idx);
00907                      IR_FLD_R(ir_idx)       = IR_Tbl_Idx;
00908                      IR_IDX_R(ir_idx)       = loc_idx;
00909 # ifdef _ACSET
00910                      /* For ACSET, ATL_FORMAT_TMP holds the CN idx */
00911                      IR_FLD_L(loc_idx)      = CN_Tbl_Idx;
00912 # else
00913                      IR_FLD_L(loc_idx)      = AT_Tbl_Idx;
00914 # endif
00915 
00916                      IR_IDX_L(loc_idx)      = ATL_FORMAT_TMP(label_idx);
00917                      IR_LINE_NUM_L(loc_idx) = IR_LINE_NUM(ir_idx);
00918                      IR_COL_NUM_L(loc_idx)  = IR_COL_NUM(ir_idx);
00919                   }
00920                }
00921             }
00922             else {
00923 # if defined(_TARGET_OS_MAX)
00924                msg_num =  (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) != Integer_8 &&
00925                            asg_var_desc.rank == 0) ? 1666 : 142;
00926 # else
00927                msg_num = 142;
00928 # endif
00929 
00930                PRINTMSG(IR_LINE_NUM_R(ir_idx), msg_num, Error,
00931                         IR_COL_NUM_R(ir_idx),
00932                         AT_OBJ_NAME_PTR(attr_idx));
00933             }
00934 
00935             break;
00936 
00937 
00938          case CN_Tbl_Idx:
00939             find_opnd_line_and_column(&asg_var_opnd, &line, &column);
00940             PRINTMSG(line, 569, Error, column,
00941                      AT_OBJ_NAME_PTR(IR_IDX_R(ir_idx)));
00942             break;
00943 
00944          case IR_Tbl_Idx:
00945             /* Only case should be a Whole_Subscript IR.                      */
00946 
00947             PRINTMSG(IR_LINE_NUM_R(ir_idx), 142, Error, IR_COL_NUM_R(ir_idx),
00948                      AT_OBJ_NAME_PTR(IR_IDX_R(ir_idx)));
00949             break;
00950 
00951          default:
00952             find_opnd_line_and_column(&asg_var_opnd, &line, &column);
00953             PRINTMSG(line, 179, Internal, column,
00954                      "assign_stmt_semantics");
00955 
00956       }
00957    }
00958 
00959    TRACE (Func_Exit, "assign_stmt_semantics", NULL);
00960 
00961    return;
00962 
00963 }  /* assign_stmt_semantics */
00964 
00965 
00966 /******************************************************************************\
00967 |*                                                                            *|
00968 |* Description:                                                               *|
00969 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
00970 |*                                                                            *|
00971 |* Input parameters:                                                          *|
00972 |*      NONE                                                                  *|
00973 |*                                                                            *|
00974 |* Output parameters:                                                         *|
00975 |*      NONE                                                                  *|
00976 |*                                                                            *|
00977 |* Returns:                                                                   *|
00978 |*      NONE                                                                  *|
00979 |*                                                                            *|
00980 \******************************************************************************/
00981 
00982 void call_stmt_semantics (void)
00983 
00984 {
00985    expr_arg_type  exp_desc;
00986    opnd_type      opnd;
00987 
00988    TRACE (Func_Entry, "call_stmt_semantics", NULL);
00989 
00990    OPND_FLD(opnd) = IR_Tbl_Idx;
00991    OPND_IDX(opnd) = SH_IR_IDX(curr_stmt_sh_idx);
00992 
00993    exp_desc = init_exp_desc;
00994 
00995    xref_state = CIF_Symbol_Reference;
00996    call_list_semantics(&opnd, &exp_desc, FALSE);
00997 
00998    SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(opnd);
00999        
01000    TRACE (Func_Exit, "call_stmt_semantics", NULL);
01001 
01002    return;
01003 
01004 }  /* call_stmt_semantics */
01005 
01006 
01007 /******************************************************************************\
01008 |*                                                                            *|
01009 |* Description:                                                               *|
01010 |*      This function performs semantics analysis on a CASE statement's       *|
01011 |*      case values.                                                          *|
01012 |*                                                                            *|
01013 |* Input parameters:                                                          *|
01014 |*      NONE                                                                  *|
01015 |*                                                                            *|
01016 |* Output parameters:                                                         *|
01017 |*      NONE                                                                  *|
01018 |*                                                                            *|
01019 |* Returns:                                                                   *|
01020 |*      NONE                                                                  *|
01021 |*                                                                            *|
01022 \******************************************************************************/
01023 
01024 void case_stmt_semantics (void)
01025 
01026 {
01027    int                  column;
01028    int                  curr_il_idx;
01029    expr_arg_type        expr_desc;
01030    int                  ir_idx;
01031    int                  line;
01032    int                  nested_select_ir_idx;
01033    int                  new_il_idx;
01034    opnd_type            opnd;
01035    int                  select_ir_idx;
01036    
01037   
01038    TRACE (Func_Entry, "case_stmt_semantics", NULL);
01039 
01040    /* Upon entry to this procedure, the SELECT CASE statement header points   */
01041    /* at a Select IR that is used as a temporary place to hang the info about */
01042    /* the entire SELECT CASE.  The left operand of the Select IR points at    */
01043    /* actual Select IR.                                                       */
01044    
01045    select_ir_idx        = SH_IR_IDX(SH_PARENT_BLK_IDX(curr_stmt_sh_idx));
01046    nested_select_ir_idx = IR_IDX_L(select_ir_idx);
01047    ir_idx               = SH_IR_IDX(curr_stmt_sh_idx);
01048 
01049 
01050    /* Get the type of the SELECT CASE expression and stuff it into the Case   */
01051    /* IR.  We'll still check later to make sure the user got the types right. */
01052    /* If the user got it wrong, putting the correct type into the IR won't    */
01053    /* matter 'cause we'll never get beyond the front-end.                     */
01054 
01055    if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))) {
01056 
01057       IR_TYPE_IDX(ir_idx) = IR_TYPE_IDX(nested_select_ir_idx);
01058    }
01059 
01060 
01061    COPY_OPND(opnd, IR_OPND_L(ir_idx));
01062 
01063    expr_mode      = Initialization_Expr;
01064    expr_desc.rank = 0;
01065 
01066    switch (OPND_FLD(opnd)) {
01067 
01068       case NO_Tbl_Idx:                                  /* CASE DEFAULT       */
01069          break;
01070 
01071       case CN_Tbl_Idx:
01072          expr_desc.type_idx     = CN_TYPE_IDX(OPND_IDX(opnd));
01073          expr_desc.type         = TYP_TYPE(expr_desc.type_idx);
01074          expr_desc.linear_type  = TYP_LINEAR(expr_desc.type_idx);
01075          break;
01076 
01077       case AT_Tbl_Idx:
01078          xref_state = CIF_Symbol_Reference;
01079 
01080          if (expr_semantics(&opnd, &expr_desc)) {
01081                   
01082             if (expr_desc.constant) {
01083                COPY_OPND(IR_OPND_L(ir_idx), opnd);
01084             }
01085             else {
01086 
01087                /* Did not resolve to a named constant.                        */
01088 
01089                find_opnd_line_and_column(&opnd, &line, &column);
01090                PRINTMSG(line, 811, Error, column);
01091                goto EXIT;
01092             }
01093          }
01094          else {
01095             goto EXIT;
01096          }
01097 
01098          break;
01099 
01100       case IR_Tbl_Idx:
01101          if (IR_OPR(OPND_IDX(opnd)) == Case_Range_Opr) {
01102 
01103             IR_TYPE_IDX(OPND_IDX(opnd)) = IR_TYPE_IDX(ir_idx);
01104 
01105             if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  &&
01106                 TYP_TYPE(IR_TYPE_IDX(nested_select_ir_idx)) == Logical) {
01107                find_opnd_line_and_column(&opnd, &line, &column);
01108                PRINTMSG(line, 764, Error, column);
01109             }
01110             else {
01111                NTR_IR_LIST_TBL(new_il_idx);
01112                COPY_OPND(IL_OPND(new_il_idx), opnd);
01113                case_value_range_semantics(OPND_IDX(opnd),
01114                                           new_il_idx,
01115                                           select_ir_idx);
01116             }
01117 
01118             goto EXIT;
01119          }
01120          else {
01121             xref_state = CIF_Symbol_Reference;
01122 
01123             if (expr_semantics(&opnd, &expr_desc)) {
01124 
01125                if (OPND_FLD(opnd) == CN_Tbl_Idx) {
01126                   COPY_OPND(IR_OPND_L(ir_idx), opnd);
01127                }
01128                else { /* Issue err if it did not resolve to a named constant. */
01129                   PRINTMSG(IR_LINE_NUM_L(ir_idx), 811, Error,
01130                            IR_COL_NUM_L(ir_idx));
01131                   goto EXIT;
01132                }
01133             }
01134             else {
01135                goto EXIT;
01136             }
01137 
01138          }
01139 
01140          break;
01141 
01142       default:
01143          PRINTMSG(IR_LINE_NUM_R(ir_idx), 179, Internal, 
01144                   IR_COL_NUM_R(ir_idx), "case_stmt_semantics");
01145    }  
01146 
01147    /* If this case-value is CASE DEFAULT, ignore it.                          */
01148 
01149    if (IR_FLD_L(ir_idx) == NO_Tbl_Idx) {
01150       goto EXIT;
01151    }
01152 
01153    /* The case-value expression must be scalar.                               */
01154    /* Note that if the current CASE is a case-value-range, it has already     */
01155    /* been completely processed by case_value_range_semantics.                */
01156 
01157    if (expr_desc.rank != 0) {
01158       find_opnd_line_and_column(&opnd, &line, &column);
01159       PRINTMSG(line, 766, Error, column);
01160    }
01161 
01162    /* The case-value must be type integer, character, or logical.             */
01163 
01164    if (expr_desc.type == Integer  ||  expr_desc.type == Character  ||
01165        expr_desc.type == Logical) {
01166 
01167       /* If the SELECT CASE stmt is OK, verify that the type of the           */
01168       /* case-value is the same as the SELECT CASE expression.                */
01169 
01170       if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  &&
01171           expr_desc.type != TYP_TYPE(IR_TYPE_IDX(nested_select_ir_idx))) {
01172          find_opnd_line_and_column(&opnd, &line, &column);
01173          PRINTMSG(line, 745, Error, column);
01174       }
01175 
01176    }
01177    else {
01178 
01179       /* Extension:  We'll also allow a BOZ constant (but NOT the X, trailing */
01180       /* B, Hollerith, or character used as Hollerith forms) to match an      */
01181       /* integer SELECT CASE expression.                                      */
01182 
01183       if (expr_desc.type == Typeless  &&  CN_BOZ_CONSTANT(OPND_IDX(opnd))) {
01184 
01185          if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  &&
01186              TYP_TYPE(IR_TYPE_IDX(nested_select_ir_idx)) != Integer) {
01187             find_opnd_line_and_column(&opnd, &line, &column);
01188             PRINTMSG(line, 745, Error, column);
01189          }
01190          else if (expr_desc.linear_type == Short_Typeless_Const) {
01191             find_opnd_line_and_column(&opnd, &line, &column);
01192             OPND_IDX(opnd) = cast_typeless_constant(OPND_IDX(opnd),
01193                                                     INTEGER_DEFAULT_TYPE,
01194                                                     line,
01195                                                     column);
01196             
01197             COPY_OPND(IR_OPND_L(ir_idx), opnd);
01198             expr_desc.linear_type = INTEGER_DEFAULT_TYPE;
01199             expr_desc.type_idx    = INTEGER_DEFAULT_TYPE;
01200             expr_desc.type        = Integer;
01201          }
01202       }
01203       else {
01204          find_opnd_line_and_column(&opnd, &line, &column);
01205          PRINTMSG(line, 768, Error, column);
01206       }
01207 
01208    }
01209 
01210    if (SH_ERR_FLG(curr_stmt_sh_idx)) {
01211       goto EXIT;
01212    }
01213 
01214    /* Determine whether or not this case-value is OK (it might conflict with  */
01215    /* another case-value or might fall within the range of a case-value-      */
01216    /* range).                                                                 */
01217 
01218    NTR_IR_LIST_TBL(new_il_idx);
01219    COPY_OPND(IL_OPND(new_il_idx), IR_OPND_L(ir_idx));
01220    
01221    /* If this is the first CASE, just attach the new IL to the dummy Select   */
01222    /* IR's right operand.                                                     */
01223 
01224    if (IR_FLD_R(select_ir_idx) == NO_Tbl_Idx) {
01225       ++IR_LIST_CNT_R(select_ir_idx);
01226       IR_FLD_R(select_ir_idx) = IL_Tbl_Idx;
01227       IR_IDX_R(select_ir_idx) = new_il_idx;
01228       goto EXIT;
01229    }
01230 
01231    /* See where this case-value fits in with existing case-values.            */
01232 
01233    curr_il_idx = IR_IDX_R(select_ir_idx);
01234 
01235    while (curr_il_idx != NULL_IDX) {
01236 
01237       /* Is the current IL a single value?                                    */
01238 
01239       if (IL_FLD(curr_il_idx) == CN_Tbl_Idx) {
01240          
01241          /* Yes.                                                              */
01242          /* Is the new value type logical?                                    */
01243          /*   Y: Is the new value = current value?                            */
01244          /*        Y: Error; duplicate case-values.                           */
01245          /*           {Quit}                                                  */
01246          /*        N: --|                                                     */
01247          /*   N: Is the new value < current value?                            */
01248          /*        Y: Insert the new IL ahead of the current IL.              */
01249          /*           {Done}                                                  */
01250          /*        N: Is the new value = current value?                       */
01251          /*             Y: Error; duplicate case-values.                      */
01252          /*                {Quit}                                             */
01253          /*             N: --|                                                */
01254          /* Is the current IL at the end of the list?                         */
01255          /*   Y: Append the new IL at the end of the list.                    */
01256          /*      {Done}                                                       */
01257          /*   N: Advance to the next IL in the list.                          */
01258 
01259          if (expr_desc.type == Logical) {
01260              
01261             if (THIS_IS_TRUE(&CN_CONST(IL_IDX(new_il_idx)),
01262                              CN_TYPE_IDX(IL_IDX(new_il_idx))) ==
01263                 THIS_IS_TRUE(&CN_CONST(IL_IDX(curr_il_idx)),
01264                              CN_TYPE_IDX(IL_IDX(curr_il_idx)))) {
01265 
01266                PRINTMSG(IL_LINE_NUM(new_il_idx), 746, Error, 
01267                         IL_COL_NUM(new_il_idx), IL_LINE_NUM(curr_il_idx));
01268                goto EXIT;
01269             }
01270         
01271          }
01272          else {
01273             if (fold_relationals(IL_IDX(new_il_idx),
01274                                  IL_IDX(curr_il_idx), Lt_Opr)) {
01275                   insert_on_left(new_il_idx, curr_il_idx, select_ir_idx);
01276                   goto EXIT;
01277             }
01278             else if (fold_relationals(IL_IDX(new_il_idx),
01279                                       IL_IDX(curr_il_idx), Eq_Opr)) {
01280                PRINTMSG(IL_LINE_NUM(new_il_idx), 746, Error, 
01281                         IL_COL_NUM(new_il_idx), IL_LINE_NUM(curr_il_idx));
01282                goto EXIT;
01283             }
01284 
01285          }
01286 
01287          if (IL_NEXT_LIST_IDX(curr_il_idx) == NULL_IDX) {
01288             IL_NEXT_LIST_IDX(curr_il_idx) = new_il_idx;
01289             IL_PREV_LIST_IDX(new_il_idx)  = curr_il_idx;
01290             ++IR_LIST_CNT_R(select_ir_idx);
01291             goto EXIT;
01292          }
01293 
01294       }
01295       else {
01296 
01297          /* Value in list is a case-value range.                              */
01298          /* Does the range in the list have a left value?                     */
01299          /*   Y: Is the new case value < the left value?                      */
01300          /*        Y: Insert the new IL ahead of the current IL.              */
01301          /*           {Done}                                                  */
01302          /*        N: --|                                                     */
01303          /*   N: --|                                                          */
01304 
01305          if (IR_FLD_L(IL_IDX(curr_il_idx)) != NO_Tbl_Idx) {
01306 
01307             if (fold_relationals(IL_IDX(new_il_idx), 
01308                                  IR_IDX_L(IL_IDX(curr_il_idx)), Lt_Opr)) {
01309                insert_on_left(new_il_idx, curr_il_idx, select_ir_idx);
01310                goto EXIT;
01311             }
01312 
01313          }
01314 
01315          /* Does the case-value range in the list have a right value?         */
01316          /*   Y: Is the new case value > the right value?                     */
01317          /*        Y: Is the IL in the list at the tail of the list?          */
01318          /*             Y: Append the new IL to the end of the list.          */
01319          /*                {Done}                                             */
01320          /*             N: Advance to the next IL in the list.                */
01321          /*        N: --|                                                     */
01322          /*   N:  --|                                                         */
01323          /* Error - overlap.                                                  */
01324          /* {Quit}                                                            */
01325 
01326          if (IR_FLD_R(IL_IDX(curr_il_idx)) != NO_Tbl_Idx) {
01327             
01328             if (fold_relationals(IL_IDX(new_il_idx), 
01329                                  IR_IDX_R(IL_IDX(curr_il_idx)), Gt_Opr)) { 
01330                
01331                if (IL_NEXT_LIST_IDX(curr_il_idx) == NULL_IDX) {
01332                   IL_NEXT_LIST_IDX(curr_il_idx) = new_il_idx;
01333                   IL_PREV_LIST_IDX(new_il_idx)  = curr_il_idx;
01334                   ++IR_LIST_CNT_R(select_ir_idx);
01335                   goto EXIT;
01336                }
01337                else {
01338                   goto ADVANCE_TO_NEXT_IL;
01339                }
01340 
01341             }
01342 
01343          }
01344          
01345          PRINTMSG(IL_LINE_NUM(new_il_idx), 747, Error,
01346                   IL_COL_NUM(new_il_idx), IR_LINE_NUM(IL_IDX(curr_il_idx)));
01347          goto EXIT;
01348       }
01349 
01350 ADVANCE_TO_NEXT_IL:
01351 
01352       curr_il_idx = IL_NEXT_LIST_IDX(curr_il_idx);
01353    }  /* while */
01354                
01355 EXIT:
01356 
01357    expr_mode = Regular_Expr;
01358 
01359    TRACE (Func_Exit, "case_stmt_semantics", NULL);
01360 
01361    return;
01362 
01363 }  /* case_stmt_semantics */
01364 
01365 
01366 /******************************************************************************\
01367 |*                                                                            *|
01368 |* Description:                                                               *|
01369 |*      This routine handles both a user CONTINUE stmt and a compiler-        *|
01370 |*      generated CONTINUE.  Nothing needs to be done for a user CONTINUE.    *|
01371 |*      For a compiler-generated CONTINUE, if the line number has not yet     *|
01372 |*      been filled in, the line and column info of the SH are filled in to   *|
01373 |*      reflect those of the following SH.  Also complete the compiler-       *|
01374 |*      generated label defined on the compiler-generated CONTINUE.           *|
01375 |*                                                                            *|
01376 |* Input parameters:                                                          *|
01377 |*      NONE                                                                  *|
01378 |*                                                                            *|
01379 |* Output parameters:                                                         *|
01380 |*      NONE                                                                  *|
01381 |*                                                                            *|
01382 |* Returns:                                                                   *|
01383 |*      NONE                                                                  *|
01384 |*                                                                            *|
01385 |* Algorithm notes:                                                           *|
01386 |*      The "next" SH that contains a nonzero line (and column) number must   *|
01387 |*      be searched for, as opposed to just looking at the next SH, because   *|
01388 |*      multiple SHs can exist with line numbers of 0.  For example:          *|
01389 |*                                                                            *|
01390 |*            IF (condition) THEN                                             *|
01391 |*              IF (condition) action-stmt                                    *|
01392 |*            ELSE                                                            *|
01393 |*                                                                            *|
01394 |*      produces the following SHs:                                           *|
01395 |*                                                                            *|
01396 |*            If_Cstrct_Stmt                                                  *|
01397 |*            If_Then_Stmt                                                    *|
01398 |*            If_Stmt                                                         *|
01399 |*            (action-stmt)                                                   *|
01400 |*            CG Continue_Stmt          ! Branch-around label for logical IF  *|
01401 |*            CG Goto_Stmt              ! Branch around ELSE                  *|
01402 |*            CG Continue_Stmt          ! Define label for ELSE               *|
01403 |*            If_Else_Stmt                                                    *|
01404 |*                                                                            *|
01405 \******************************************************************************/
01406 
01407 void continue_stmt_semantics (void)
01408 
01409 {
01410    int  col_num;
01411    int  line_num;
01412    int  sh_idx;
01413 
01414 
01415    TRACE (Func_Entry, "continue_stmt_semantics", NULL);
01416 
01417    if (SH_COMPILER_GEN(curr_stmt_sh_idx)   && 
01418        (SH_GLB_LINE(curr_stmt_sh_idx) == 0  ||
01419         IR_LINE_NUM_L(SH_IR_IDX(curr_stmt_sh_idx)) == 0)) { 
01420       sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01421     
01422 # ifdef _DEBUG
01423       if (sh_idx == NULL_IDX) {
01424          PRINTMSG(SH_GLB_LINE(SH_PREV_IDX(curr_stmt_sh_idx)), 236,
01425                   Internal, 0);
01426       }
01427 # endif
01428 
01429       while (SH_GLB_LINE(sh_idx) == 0  ||  SH_COMPILER_GEN(sh_idx)) {
01430          sh_idx = SH_NEXT_IDX(sh_idx);
01431 
01432 # ifdef _DEBUG
01433          if (sh_idx == NULL_IDX) {
01434             PRINTMSG(SH_GLB_LINE(SH_PREV_IDX(curr_stmt_sh_idx)), 236,
01435                      Internal, 0);
01436          }
01437 # endif
01438       }
01439 
01440       line_num = SH_GLB_LINE(sh_idx);
01441       col_num  = SH_COL_NUM(sh_idx);
01442 
01443       if (SH_GLB_LINE(curr_stmt_sh_idx) == 0) {
01444          SH_GLB_LINE(curr_stmt_sh_idx)            = line_num;
01445          SH_COL_NUM(curr_stmt_sh_idx)             = col_num;
01446          IR_LINE_NUM(SH_IR_IDX(curr_stmt_sh_idx)) = line_num;
01447          IR_COL_NUM(SH_IR_IDX(curr_stmt_sh_idx))  = col_num;
01448       }
01449 
01450       IR_LINE_NUM_L(SH_IR_IDX(curr_stmt_sh_idx))           = line_num;
01451       IR_COL_NUM_L(SH_IR_IDX(curr_stmt_sh_idx))            = col_num;
01452       AT_DEF_LINE(IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx)))   = line_num;
01453       AT_DEF_COLUMN(IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx))) = col_num;
01454    }
01455 
01456    TRACE (Func_Exit, "continue_stmt_semantics", NULL);
01457 
01458    return;
01459 
01460 }  /* continue_stmt_semantics */
01461 
01462 
01463 /******************************************************************************\
01464 |*                                                                            *|
01465 |* Description:                                                               *|
01466 |*      BNF       - DEALLOCATE ( allocation-list [, STAT = stat-variable] )   *|
01467 |*                                                                            *|
01468 |* Input parameters:                                                          *|
01469 |*      NONE                                                                  *|
01470 |*                                                                            *|
01471 |* Output parameters:                                                         *|
01472 |*      NONE                                                                  *|
01473 |*                                                                            *|
01474 |* Returns:                                                                   *|
01475 |*      NONE                                                                  *|
01476 |*                                                                            *|
01477 \******************************************************************************/
01478 
01479 void deallocate_stmt_semantics (void)
01480 
01481 {
01482    int            attr_idx;
01483    int            cn_idx;
01484    int            col;
01485    opnd_type      dope_opnd;
01486    expr_arg_type  exp_desc;
01487    boolean        has_pe_ref = FALSE;
01488    boolean        has_normal_ref = FALSE;
01489    int            ir_idx;
01490    int            line;
01491    int            list_idx;
01492    int            loc_idx;
01493    opnd_type      opnd;
01494    boolean        semantically_correct = TRUE;
01495    int            stat_col;
01496    int            stat_line;
01497    int            stat_list_idx;
01498    opnd_type      stat_opnd;
01499 
01500 /* # ifdef _SEPARATE_DEALLOCATES
01501     int           list_idx2;
01502    int            next_sh_idx;
01503    opnd_type      stat_loc_opnd;
01504 
01505 # endif
01506 */
01507 
01508    TRACE (Func_Entry, "deallocate_stmt_semantics", NULL);
01509 
01510    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01511 
01512    /* check stat var */
01513 
01514    NTR_IR_LIST_TBL(stat_list_idx);
01515    IL_FLD(stat_list_idx) = CN_Tbl_Idx;
01516    IL_IDX(stat_list_idx) = CN_INTEGER_ZERO_IDX;
01517    IL_LINE_NUM(stat_list_idx) = IR_LINE_NUM(ir_idx);
01518    IL_COL_NUM(stat_list_idx)  = IR_COL_NUM(ir_idx);
01519 
01520    if (IR_FLD_R(ir_idx) != NO_Tbl_Idx) {
01521       check_stat_variable(ir_idx, &stat_opnd, stat_list_idx);
01522       find_opnd_line_and_column(&stat_opnd, &stat_line, &stat_col);
01523    }
01524    else {
01525       stat_opnd = null_opnd;
01526    }
01527 
01528    list_idx = IR_IDX_L(ir_idx);
01529 
01530    while (list_idx != NULL_IDX ) {
01531 
01532       COPY_OPND(opnd, IL_OPND(list_idx));
01533       exp_desc.rank = 0;
01534       xref_state    = CIF_Symbol_Modification;
01535       semantically_correct = expr_semantics(&opnd, &exp_desc)
01536                              && semantically_correct;
01537       COPY_OPND(IL_OPND(list_idx), opnd);
01538 
01539       if (exp_desc.rank != 0) {
01540          find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 
01541                                    &line, &col);
01542          PRINTMSG(line, 429, Error, col);
01543          semantically_correct = FALSE;
01544       }
01545 
01546       if (IR_FLD_R(ir_idx) != NO_Tbl_Idx                              &&
01547           OPND_FLD(stat_opnd) != NO_Tbl_Idx                           &&
01548           cmp_ref_trees(&stat_opnd,
01549                         (opnd_type *)&IR_OPND_L(IL_IDX(list_idx)))) {
01550 
01551          /* stat var can't alloc obj in same stmt */
01552          PRINTMSG(stat_line, 427, Error, stat_col);
01553          semantically_correct = FALSE;
01554       }
01555 
01556       if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01557           ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
01558          attr_idx = find_left_attr(&opnd);
01559 
01560          if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)) {
01561             find_opnd_line_and_column(&opnd, &line, &col);
01562             semantically_correct = FALSE;
01563             PRINTMSG(line, 1270, Error, col,
01564                      AT_OBJ_NAME_PTR(attr_idx),
01565                      ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure":"elemental");
01566          }
01567       }
01568 
01569       if (! semantically_correct) {
01570          goto EXIT;
01571       }
01572 
01573       attr_idx = find_left_attr(&opnd);
01574 
01575       if (ATD_ALLOCATABLE(attr_idx) &&
01576           ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
01577           has_pe_ref = TRUE;
01578           has_normal_ref = FALSE;
01579 
01580       }
01581       else {
01582         if (!has_pe_ref)
01583             has_normal_ref = TRUE;
01584       }
01585 
01586       while (OPND_FLD(opnd) == IR_Tbl_Idx &&
01587              (IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr ||
01588               IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr)) {
01589          COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
01590       }
01591 
01592       if (OPND_FLD(opnd)         == IR_Tbl_Idx     &&
01593           IR_OPR(OPND_IDX(opnd)) == Dealloc_Obj_Opr) {
01594 
01595          COPY_OPND(dope_opnd, IR_OPND_L(OPND_IDX(opnd)));
01596 
01597          if (OPND_FLD(dope_opnd) == IR_Tbl_Idx &&
01598              IR_OPR(OPND_IDX(dope_opnd)) == Dv_Deref_Opr) {
01599 
01600             COPY_OPND(dope_opnd, IR_OPND_L(OPND_IDX(dope_opnd)));
01601          }
01602          else {
01603 ; 
01604 # if 0 /*fzhao */
01605             find_opnd_line_and_column(&opnd, &line, &col);
01606             PRINTMSG(line, 626, Internal, col,
01607                      "Dv_Deref_Opr", "deallocate_stmt_semantics");
01608 # endif
01609          }
01610       }
01611       else {
01612          find_opnd_line_and_column(&opnd, &line, &col);
01613          PRINTMSG(line, 626, Internal, col,
01614                   "Dealloc_Obj_Opr", "deallocate_stmt_semantics");
01615       }
01616 
01617       find_opnd_line_and_column(&dope_opnd, &line, &col);
01618 
01619       /* replace deallocate obj with loc of dope vector */
01620 
01621       NTR_IR_TBL(loc_idx);
01622       IR_OPR(loc_idx) = Aloc_Opr;
01623       IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
01624       IR_LINE_NUM(loc_idx) = line;
01625       IR_COL_NUM(loc_idx)  = col;
01626       COPY_OPND(IR_OPND_L(loc_idx), dope_opnd);
01627 
01628       IL_FLD(list_idx) = IR_Tbl_Idx;
01629       IL_IDX(list_idx) = loc_idx;
01630 
01631       list_idx = IL_NEXT_LIST_IDX(list_idx);
01632    }
01633 
01634    if (glb_tbl_idx[Deallocate_Attr_Idx] == NULL_IDX) {
01635       glb_tbl_idx[Deallocate_Attr_Idx] = create_lib_entry_attr(
01636                                                     DEALLOCATE_LIB_ENTRY,
01637                                                     DEALLOCATE_NAME_LEN,
01638                                                     line,
01639                                                     col);
01640    }
01641 
01642    ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Deallocate_Attr_Idx]);
01643 
01644 /* # ifdef _SEPARATE_DEALLOCATES
01645 
01646    list_idx = IR_IDX_L(ir_idx);
01647 
01648    if (list_idx) {
01649 
01650       attr_idx = find_left_attr(&IL_OPND(list_idx));
01651 
01652       if (ATD_ALLOCATABLE(attr_idx) &&
01653           ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
01654          has_pe_ref = TRUE;
01655       }
01656       else {
01657          has_pe_ref = FALSE;
01658       }
01659 
01660       list_idx2 = gen_il(3, FALSE, line, col,
01661                         AT_Tbl_Idx, glb_tbl_idx[Deallocate_Attr_Idx],
01662                         CN_Tbl_Idx, gen_alloc_header_const(Integer_8,
01663                                                            1, 
01664                                                            has_pe_ref,
01665                                                            &cn_idx),
01666                         IL_FLD(stat_list_idx), IL_IDX(stat_list_idx));
01667 
01668       IR_FLD_R(ir_idx) = IL_Tbl_Idx;
01669       IR_IDX_R(ir_idx) = list_idx2;
01670       IR_LIST_CNT_R(ir_idx) = 3;
01671 
01672       IR_IDX_L(ir_idx) = list_idx;
01673       IR_LIST_CNT_L(ir_idx) = 1;
01674 
01675       list_idx2 = IL_NEXT_LIST_IDX(list_idx);
01676       IL_PREV_LIST_IDX(list_idx) = NULL_IDX;
01677       IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
01678 
01679       list_idx = list_idx2;
01680    }
01681 
01682    COPY_OPND(stat_loc_opnd, IL_OPND(stat_list_idx));
01683 
01684    while (list_idx) {
01685 
01686       attr_idx = find_left_attr(&IL_OPND(list_idx));
01687 
01688       if (ATD_ALLOCATABLE(attr_idx) &&
01689           ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
01690          has_pe_ref = TRUE;
01691       }
01692       else {
01693          has_pe_ref = FALSE;
01694       }
01695 
01696       copy_subtree(&stat_loc_opnd, &stat_loc_opnd);
01697 
01698       list_idx2 = IL_NEXT_LIST_IDX(list_idx);
01699 
01700       IL_PREV_LIST_IDX(list_idx) = NULL_IDX;
01701       IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
01702 
01703       ir_idx = gen_ir(IL_Tbl_Idx, list_idx,
01704                   Deallocate_Opr, TYPELESS_DEFAULT_TYPE, line, col,
01705                       IL_Tbl_Idx, gen_il(3, FALSE, line, col,
01706                             AT_Tbl_Idx, glb_tbl_idx[Deallocate_Attr_Idx],
01707                             CN_Tbl_Idx, gen_alloc_header_const(Integer_8,
01708                                                                1, 
01709                                                                has_pe_ref,
01710                                                                &cn_idx),
01711                             OPND_FLD(stat_loc_opnd), OPND_IDX(stat_loc_opnd)));
01712 
01713       gen_sh(After, Deallocate_Stmt, line, col, FALSE, FALSE, TRUE);
01714       SH_P2_SKIP_ME(curr_stmt_sh_idx)     = TRUE;
01715       SH_IR_IDX(curr_stmt_sh_idx)         = ir_idx;
01716       next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01717 
01718       if (OPND_FLD(stat_opnd) != NO_Tbl_Idx) {
01719          copy_subtree(&stat_opnd, &stat_opnd);
01720          ir_idx = gen_ir(OPND_FLD(stat_opnd), OPND_IDX(stat_opnd),
01721                      Eq_Opr, LOGICAL_DEFAULT_TYPE, line, col,
01722                          CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
01723 
01724          gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, line, col);
01725          gen_if_stmt(&opnd, 
01726                      curr_stmt_sh_idx, 
01727                      curr_stmt_sh_idx, 
01728                      NULL_IDX,
01729                      NULL_IDX, 
01730                      line, 
01731                      col);
01732       }
01733 
01734       curr_stmt_sh_idx = SH_PREV_IDX(next_sh_idx);
01735       list_idx = list_idx2;
01736    }
01737 
01738 # else
01739 */
01740 
01741    if (has_pe_ref && has_normal_ref) {
01742       /* must pull the normal refs off on their own call */
01743       gen_split_alloc(ir_idx,
01744                       glb_tbl_idx[Deallocate_Attr_Idx],
01745                       stat_list_idx);
01746    }
01747 
01748 # ifdef _ALLOCATE_IS_CALL
01749    set_up_allocate_as_call(ir_idx,
01750                            glb_tbl_idx[Deallocate_Attr_Idx],
01751                            stat_list_idx,
01752                            has_pe_ref);
01753 # else
01754 
01755    NTR_IR_LIST_TBL(list_idx);
01756    IR_FLD_R(ir_idx) = IL_Tbl_Idx;
01757    IR_IDX_R(ir_idx) = list_idx;
01758    IR_LIST_CNT_R(ir_idx) = 3;
01759 
01760    IL_FLD(list_idx) = AT_Tbl_Idx;
01761    IL_IDX(list_idx) = glb_tbl_idx[Deallocate_Attr_Idx];
01762    IL_LINE_NUM(list_idx) = line;
01763    IL_COL_NUM(list_idx)  = col;
01764 
01765    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01766    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01767    list_idx = IL_NEXT_LIST_IDX(list_idx);
01768 
01769    IL_FLD(list_idx) = CN_Tbl_Idx;
01770    IL_IDX(list_idx) = gen_alloc_header_const(Integer_8,
01771                                              IR_LIST_CNT_L(ir_idx),
01772                                              has_pe_ref,
01773                                              &cn_idx);
01774    IL_LINE_NUM(list_idx) = line;
01775    IL_COL_NUM(list_idx)  = col;
01776 
01777    IL_NEXT_LIST_IDX(list_idx) = stat_list_idx;
01778    IL_PREV_LIST_IDX(stat_list_idx) = list_idx;
01779 
01780 # endif
01781 /*   # endif */
01782 
01783 EXIT:
01784 
01785    TRACE (Func_Exit, "deallocate_stmt_semantics", NULL);
01786 
01787    return;
01788 
01789 }  /* deallocate_stmt_semantics */
01790 
01791 
01792 /******************************************************************************\
01793 |*                                                                            *|
01794 |* Description:                                                               *|
01795 |*      Perform semantic checks on all forms of the DO statement.             *|
01796 |*                                                                            *|
01797 |* Input parameters:                                                          *|
01798 |*      NONE                                                                  *|
01799 |*                                                                            *|
01800 |* Output parameters:                                                         *|
01801 |*      NONE                                                                  *|
01802 |*                                                                            *|
01803 |* Returns:                                                                   *|
01804 |*      NONE                                                                  *|
01805 |*                                                                            *|
01806 \******************************************************************************/
01807 
01808 void do_stmt_semantics (void)
01809 
01810 {
01811    int                  column;
01812    int                  do_sh_idx;
01813    int                  do_var_col;
01814    int                  do_var_idx;
01815    int                  do_var_line;
01816    boolean              do_var_must_be_int = FALSE;
01817    opnd_type            do_var_opnd;
01818    int                  end_idx;
01819    int                  end_il_idx;
01820    expr_arg_type        exp_desc;
01821    int                  il_idx;
01822    int                  il_idx_2;
01823    int                  inc_idx;
01824    int                  inc_il_idx;
01825    int                  ir_idx;
01826    int                  label_attr;
01827    int                  lc_il_idx;
01828    int                  line;
01829    int                  loop_control_il_idx;
01830    int                  loop_info_idx;
01831    int                  loop_labels_il_idx;
01832    boolean              semantics_ok;
01833    int                  start_expr_sh_idx;
01834    int                  start_idx;
01835    int                  start_il_idx;
01836    opnd_type            temp_opnd;
01837    int                  tmp_idx;
01838 
01839 # if defined(_HIGH_LEVEL_DO_LOOP_FORM)
01840    int                  label_idx;
01841    int                  tmp_asg_ir_idx;
01842 # else
01843    int                  asg_idx;
01844    int                  cg_do_var_idx;
01845    int                  expr_ir_idx;
01846    int                  idx;
01847    int                  ir_idx_2;
01848    int                  lbl_il_idx;
01849    int                  loop_temps_il_idx;
01850    int                  opnd_column;
01851    int                  opnd_line;
01852    opnd_type            opnd;
01853    int                  save_curr_stmt_sh_idx;
01854    int                  trip_zero_sh_idx = NULL_IDX;
01855 # endif
01856 
01857 
01858    TRACE (Func_Entry, "do_stmt_semantics", NULL);
01859 
01860    do_sh_idx           = curr_stmt_sh_idx;
01861    loop_info_idx       = SH_IR_IDX(curr_stmt_sh_idx);
01862    loop_control_il_idx = IR_IDX_R(loop_info_idx);
01863    loop_labels_il_idx  = IL_NEXT_LIST_IDX(loop_control_il_idx);
01864 
01865 
01866 # ifndef _HIGH_LEVEL_DO_LOOP_FORM
01867 
01868    preamble_start_sh_idx = NULL_IDX;
01869    preamble_end_sh_idx   = NULL_IDX;
01870 
01871 # endif
01872 
01873 
01874    switch (stmt_type)  {
01875 
01876       /* -------------------------------------------------------------------- */
01877       /*                                                                      */
01878       /*                         Iterative DO statement                       */
01879       /*                                                                      */
01880       /* -------------------------------------------------------------------- */
01881 
01882       case Do_Iterative_Stmt:
01883 
01884 
01885          if (IR_IDX_L(SH_IR_IDX(do_sh_idx)) == NULL_IDX) {
01886 
01887             /* If this was a DOALL loop make sure that the parallel region    */
01888             /* is terminated and cdir_switches.doall_sh_idx is cleared.       */
01889             /* Clear all the other cdir_switches that would have been         */
01890             /* cleared by this loop.                                          */
01891 
01892             clear_cdir_switches();
01893          }
01894 
01895          if (cdir_switches.doall_sh_idx ||
01896              cdir_switches.doacross_sh_idx ||
01897              cdir_switches.pdo_sh_idx ||
01898              cdir_switches.do_omp_sh_idx ||
01899              cdir_switches.paralleldo_omp_sh_idx ||
01900              cdir_switches.paralleldo_sh_idx) {
01901 
01902             cdir_switches.parallel_region = TRUE;
01903             cdir_switches.no_internal_calls = TRUE;
01904             SH_DOALL_LOOP_END(IR_IDX_L(SH_IR_IDX(do_sh_idx))) = TRUE;
01905          }
01906 
01907          if (cdir_switches.do_omp_sh_idx ||
01908              cdir_switches.paralleldo_omp_sh_idx) {
01909 
01910             do_var_must_be_int = TRUE;
01911          }
01912 
01913          /* Verify that the data type of the DO-variable is acceptable and    */
01914          /* make sure the DO-variable is a named scalar.                      */
01915 
01916          lc_il_idx = IL_IDX(loop_control_il_idx);
01917 
01918          do_var_idx = (IL_FLD(lc_il_idx) == AT_Tbl_Idx) ?
01919                          IL_IDX(lc_il_idx) : NULL_IDX;
01920 
01921 # if defined(_HIGH_LEVEL_DO_LOOP_FORM)
01922          if (cdir_switches.doall_sh_idx) {
01923             IR_FLD_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) = AT_Tbl_Idx;
01924             IR_IDX_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) = do_var_idx;
01925 
01926             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) =
01927                                                                stmt_start_line;
01928             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) =
01929                                                                stmt_start_col;
01930             insert_sh_chain_before(cdir_switches.doall_sh_idx);
01931 
01932             if (do_var_idx != NULL_IDX &&
01933                 ATD_TASK_SHARED(do_var_idx)) {
01934 
01935                PRINTMSG(IL_LINE_NUM(lc_il_idx), 961, Error, 
01936                         IL_COL_NUM(lc_il_idx));
01937             }
01938 
01939             cdir_switches.doall_sh_idx = NULL_IDX;
01940          }
01941          else if (cdir_switches.doacross_sh_idx) {
01942             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.doacross_sh_idx)) =
01943                                                                stmt_start_line;
01944             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.doacross_sh_idx)) =
01945                                                                stmt_start_col;
01946             insert_sh_chain_before(cdir_switches.doacross_sh_idx);
01947 
01948 # if 0
01949             if (do_var_idx != NULL_IDX &&
01950                 ATD_TASK_SHARED(do_var_idx)) {
01951 
01952                PRINTMSG(IL_LINE_NUM(lc_il_idx), 961, Error, 
01953                         IL_COL_NUM(lc_il_idx));
01954             }
01955 # endif
01956 
01957             cdir_switches.doacross_sh_idx = NULL_IDX;
01958          }
01959          else if (cdir_switches.paralleldo_sh_idx) {
01960             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.paralleldo_sh_idx)) =
01961                                                                stmt_start_line;
01962             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.paralleldo_sh_idx)) =
01963                                                                stmt_start_col;
01964             insert_sh_chain_before(cdir_switches.paralleldo_sh_idx);
01965 
01966 # if 0
01967             if (do_var_idx != NULL_IDX &&
01968                 ATD_TASK_SHARED(do_var_idx)) {
01969 
01970                PRINTMSG(IL_LINE_NUM(lc_il_idx), 961, Error,
01971                         IL_COL_NUM(lc_il_idx));
01972             }
01973 # endif
01974 
01975             cdir_switches.paralleldo_sh_idx = NULL_IDX;
01976          }
01977          else if (cdir_switches.pdo_sh_idx) {
01978             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.pdo_sh_idx)) =
01979                                                                stmt_start_line;
01980             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.pdo_sh_idx)) =
01981                                                                stmt_start_col;
01982             insert_sh_chain_before(cdir_switches.pdo_sh_idx);
01983 
01984 # if 0
01985             if (do_var_idx != NULL_IDX &&
01986                 ATD_TASK_SHARED(do_var_idx)) {
01987 
01988                PRINTMSG(IL_LINE_NUM(lc_il_idx), 961, Error,
01989                         IL_COL_NUM(lc_il_idx));
01990             }
01991 # endif
01992 
01993             cdir_switches.pdo_sh_idx = NULL_IDX;
01994          }
01995          else if (cdir_switches.dopar_sh_idx) {
01996 
01997             IR_FLD_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) = AT_Tbl_Idx;
01998             IR_IDX_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) = do_var_idx;
01999 
02000             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) =
02001                                                              stmt_start_line;
02002             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) =
02003                                                              stmt_start_col;
02004             insert_sh_chain_before(cdir_switches.dopar_sh_idx);
02005             cdir_switches.dopar_sh_idx = NULL_IDX;
02006          }
02007          else if (cdir_switches.do_omp_sh_idx) {
02008 
02009             IR_FLD_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) = AT_Tbl_Idx;
02010             IR_IDX_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) = do_var_idx;
02011 
02012             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) =
02013                                                              stmt_start_line;
02014             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) =
02015                                                              stmt_start_col;
02016             insert_sh_chain_before(cdir_switches.do_omp_sh_idx);
02017             cdir_switches.do_omp_sh_idx = NULL_IDX;
02018          }
02019          else if (cdir_switches.paralleldo_omp_sh_idx) {
02020 
02021             IR_FLD_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) = 
02022                                                              AT_Tbl_Idx;
02023             IR_IDX_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) = 
02024                                                              do_var_idx;
02025 
02026             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) =
02027                                                              stmt_start_line;
02028             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) =
02029                                                              stmt_start_col;
02030             insert_sh_chain_before(cdir_switches.paralleldo_omp_sh_idx);
02031             cdir_switches.paralleldo_omp_sh_idx = NULL_IDX;
02032          }
02033 
02034          label_idx = gen_internal_lbl(stmt_start_line);
02035          NTR_IR_TBL(ir_idx);
02036          IR_OPR(ir_idx)              = Label_Opr;
02037          IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
02038          IR_LINE_NUM(ir_idx)         = stmt_start_line;
02039          IR_COL_NUM(ir_idx)          = stmt_start_col;
02040          IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
02041          IR_IDX_L(ir_idx)            = label_idx;
02042          IR_COL_NUM_L(ir_idx)        = stmt_start_col;
02043          IR_LINE_NUM_L(ir_idx)       = stmt_start_line;
02044 
02045          AT_DEFINED(label_idx)       = TRUE;
02046          ATL_TOP_OF_LOOP(label_idx)  = TRUE;
02047          AT_REFERENCED(label_idx)    = Not_Referenced;
02048 
02049          gen_sh(Before, Continue_Stmt, stmt_start_line, 
02050                 stmt_start_col, FALSE, FALSE, TRUE);
02051          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02052          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02053 
02054          ATL_DEF_STMT_IDX(label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
02055 
02056          set_directives_on_label(label_idx); 
02057 # endif
02058 
02059          if (AT_DCL_ERR(do_var_idx)) {
02060             SH_ERR_FLG(do_sh_idx) = TRUE;
02061             goto EXIT;
02062          }
02063 
02064          COPY_OPND(do_var_opnd, IL_OPND(lc_il_idx));
02065          exp_desc.rank = 0;
02066          xref_state    = CIF_Symbol_Modification;
02067          processing_do_var = TRUE;
02068 
02069          semantics_ok = expr_semantics(&do_var_opnd, &exp_desc);
02070 
02071          processing_do_var = FALSE;
02072 
02073          if (semantics_ok) {
02074 
02075             COPY_OPND(IL_OPND(lc_il_idx), do_var_opnd);
02076 
02077             /* Is it a named constant?                                        */
02078 
02079             if (exp_desc.constant) {
02080                semantics_ok = FALSE;
02081                PRINTMSG(IL_LINE_NUM(lc_il_idx), 194, Error,
02082                         IL_COL_NUM(lc_il_idx));
02083             }
02084 
02085             if (do_var_must_be_int &&
02086                 exp_desc.type != Integer) {
02087 
02088                PRINTMSG(IL_LINE_NUM(lc_il_idx), 1514, Error,
02089                         IL_COL_NUM(lc_il_idx));
02090             }
02091 
02092             /* Is it something of type integer?                               */
02093 
02094             if (exp_desc.type == Integer) {
02095 
02096                if (OPND_FLD(do_var_opnd) == AT_Tbl_Idx) {
02097 
02098                   /* Is it a function reference?                              */
02099 
02100                   if (ATD_CLASS(OPND_IDX(do_var_opnd)) == Compiler_Tmp) {
02101                      semantics_ok = FALSE;
02102                      PRINTMSG(IL_LINE_NUM(lc_il_idx), 194, Error,
02103                               IL_COL_NUM(lc_il_idx));
02104                   }
02105                }
02106                else {
02107               
02108                   if (do_var_idx == NULL_IDX) {
02109                      find_opnd_line_and_column(&do_var_opnd, &line, &column);
02110                      PRINTMSG(line, 199, Error, column);
02111                      semantics_ok = FALSE;
02112                   }
02113                }
02114             }
02115 
02116             /* Is it something of type default real or double precision?      */
02117              
02118             else if (exp_desc.type == Real  &&
02119                      (exp_desc.linear_type == REAL_DEFAULT_TYPE  ||
02120                       exp_desc.linear_type == DOUBLE_DEFAULT_TYPE)) { 
02121 
02122                if (OPND_FLD(do_var_opnd) == AT_Tbl_Idx) {
02123 
02124                   /* Is it a variable?                                        */
02125 
02126                   if (ATD_CLASS(OPND_IDX(do_var_opnd)) != Compiler_Tmp) {
02127                      PRINTMSG(IL_LINE_NUM(lc_il_idx), 1569, Ansi,
02128                               IL_COL_NUM(lc_il_idx));
02129                   }
02130                   else { 
02131                      semantics_ok = FALSE;
02132                      PRINTMSG(IL_LINE_NUM(lc_il_idx), 194, Error,
02133                               IL_COL_NUM(lc_il_idx));
02134                   }
02135                }
02136                else {
02137 
02138                   if (do_var_idx == NULL_IDX) {
02139                      find_opnd_line_and_column(&do_var_opnd, &line, &column);
02140                      PRINTMSG(line, 199, Error, column);
02141                      semantics_ok = FALSE;
02142                   }
02143                }
02144             }
02145       
02146             /* Is is a CRI pointer?                                           */
02147 
02148             else if (exp_desc.type == CRI_Ptr) {
02149                find_opnd_line_and_column(&do_var_opnd, &line, &column);
02150                PRINTMSG(line, 208, Ansi, column);
02151             }
02152 
02153             /* Nah, the DO variable is of an unapproved data type (like       */
02154             /* complex, character, or even derived type).                     */
02155 
02156             else {
02157                semantics_ok = FALSE;
02158                find_opnd_line_and_column(&do_var_opnd, &line, &column);
02159                PRINTMSG(line, 219, Error, column);
02160             }
02161 
02162             if (exp_desc.rank != 0) {
02163                semantics_ok = FALSE;
02164                find_opnd_line_and_column(&do_var_opnd, &line, &column);
02165                PRINTMSG(line, 223, Error, column);
02166             }
02167          }
02168 
02169          if (semantics_ok) {
02170 
02171             /* If the DO-variable is OK:                                      */
02172             /*   * The DO-variable may have been host associated or it may be */
02173             /*     a pointer so grab its possibly updated Attr index.         */
02174             /*   * Mark the DO variable's Attr as being a live DO-variable.   */
02175             /*     (Can only be done if the end-of-loop SH is also NOT marked */
02176             /*     in error because if it is, the driver will skip it and the */
02177             /*     "live DO-variable" flag will never get turned off).  So,   */
02178             /*     if the end-of-loop SH is in error, null the link back from */
02179             /*     the end-of-loop SH to the DO SH to signal to the driver    */
02180             /*     there is no DO-variable to turn off.                       */
02181             /*   * Make sure the DO-variable is not a dummy argument with     */
02182             /*     INTENT(IN).                                                */
02183 
02184             if (OPND_FLD(do_var_opnd) == AT_Tbl_Idx) {
02185                do_var_idx = OPND_IDX(do_var_opnd);
02186             }
02187             else {
02188                do_var_idx = IR_IDX_L(OPND_IDX(do_var_opnd));
02189             }
02190 
02191             do_var_line = OPND_LINE_NUM(do_var_opnd);
02192             do_var_col  = OPND_COL_NUM(do_var_opnd);
02193 
02194             if ( ! check_for_legal_define(&do_var_opnd)) {
02195                semantics_ok = FALSE;
02196             }
02197             else {
02198 
02199                if (IR_FLD_L(SH_IR_IDX(do_sh_idx)) == SH_Tbl_Idx  &&
02200                    ! SH_ERR_FLG(IR_IDX_L(SH_IR_IDX(do_sh_idx)))) {
02201                      if (do_var_idx != NULL_IDX) {
02202                         ATD_LIVE_DO_VAR(do_var_idx) = TRUE;
02203                      }
02204                }
02205             }
02206          }
02207 
02208          if (! semantics_ok) {
02209             goto CLEAR_CDIR_SWITCHES;
02210          }
02211 
02212          /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
02213          /* Check the start expression.                                       */
02214          /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
02215 
02216          start_il_idx = IL_NEXT_LIST_IDX(lc_il_idx);
02217          semantics_ok = do_loop_expr_semantics( start_il_idx,
02218                                                 do_var_idx,
02219                                                &temp_opnd);
02220 
02221          start_expr_sh_idx = curr_stmt_sh_idx;
02222 
02223          if (semantics_ok) {
02224 
02225             if (OPND_FLD(temp_opnd) == CN_Tbl_Idx) {
02226                start_idx = OPND_IDX(temp_opnd);
02227             }
02228             else {
02229                start_idx = NULL_IDX;
02230             }
02231          }
02232 
02233 
02234          /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
02235          /* Check the end expression.                                         */
02236          /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
02237 
02238          end_il_idx   = IL_NEXT_LIST_IDX(start_il_idx);
02239          semantics_ok =
02240             do_loop_expr_semantics(end_il_idx, do_var_idx, &temp_opnd)  && 
02241             semantics_ok;
02242 
02243          if (semantics_ok) {
02244 
02245             if (start_idx != NULL_IDX  &&  OPND_FLD(temp_opnd) == CN_Tbl_Idx) {
02246                end_idx = OPND_IDX(temp_opnd);
02247             }
02248             else {
02249                start_idx = NULL_IDX;           /* Yes, start_idx.  See below. */
02250             }
02251          }
02252 
02253 
02254          /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
02255          /* Check the increment expression.                                   */
02256          /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
02257 
02258          inc_idx      = NULL_IDX;
02259          inc_il_idx   = IL_NEXT_LIST_IDX(end_il_idx);
02260          semantics_ok =
02261             do_loop_expr_semantics(inc_il_idx, do_var_idx, &temp_opnd)  &&
02262             semantics_ok;
02263 
02264          if (semantics_ok) {
02265 
02266             if (OPND_FLD(temp_opnd) == CN_Tbl_Idx) {
02267                inc_idx = OPND_IDX(temp_opnd);
02268 
02269                if (fold_relationals(OPND_IDX(temp_opnd),
02270                                     CN_INTEGER_ZERO_IDX,
02271                                     Eq_Opr)) {
02272                   PRINTMSG(IL_LINE_NUM(inc_il_idx), 255, Error,
02273                            IL_COL_NUM(inc_il_idx));
02274                   semantics_ok = FALSE;
02275                }
02276 
02277             }
02278             else {
02279                start_idx = NULL_IDX;         /* Yes, start_idx.  See below.   */
02280             }
02281          }
02282 
02283          if (! semantics_ok) {
02284             SH_ERR_FLG(do_sh_idx) = TRUE;
02285 
02286             goto CLEAR_CDIR_SWITCHES;
02287 
02288          }
02289 
02290 
02291          /* Generate an assignment statement to initialize the DO-variable.   */
02292 
02293 # ifndef _HIGH_LEVEL_DO_LOOP_FORM
02294 
02295          gen_sh(After, Assignment_Stmt, stmt_start_line, stmt_start_col,
02296                 FALSE, FALSE, TRUE);
02297 
02298          NTR_IR_TBL(ir_idx);
02299          SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02300          IR_OPR(ir_idx)              = Asg_Opr;
02301          IR_TYPE_IDX(ir_idx)         = ATD_TYPE_IDX(do_var_idx);
02302          IR_LINE_NUM(ir_idx)         = stmt_start_line;
02303          IR_COL_NUM(ir_idx)          = stmt_start_col;
02304          COPY_OPND(IR_OPND_L(ir_idx), do_var_opnd);
02305          COPY_OPND(IR_OPND_R(ir_idx), IL_OPND(start_il_idx));
02306 
02307          if (cdir_switches.doall_sh_idx ||
02308              cdir_switches.paralleldo_omp_sh_idx) {
02309 
02310             if (preamble_end_sh_idx == NULL_IDX) {
02311                gen_opnd(&opnd, curr_stmt_sh_idx, SH_Tbl_Idx, 
02312                         stmt_start_line, stmt_start_col);
02313                copy_subtree(&opnd, &opnd);
02314                preamble_start_sh_idx = OPND_IDX(opnd);
02315                SH_COMPILER_GEN(preamble_start_sh_idx) = TRUE;
02316                SH_P2_SKIP_ME(preamble_start_sh_idx) = TRUE;
02317                preamble_end_sh_idx = preamble_start_sh_idx;
02318             }
02319             else {
02320                gen_opnd(&opnd, curr_stmt_sh_idx, SH_Tbl_Idx, 
02321                         stmt_start_line, stmt_start_col);
02322                copy_subtree(&opnd, &opnd);
02323                idx = OPND_IDX(opnd);
02324                SH_NEXT_IDX(preamble_end_sh_idx) = idx;
02325 
02326                if (SH_NEXT_IDX(preamble_end_sh_idx)) {
02327                   SH_PREV_IDX(SH_NEXT_IDX(preamble_end_sh_idx)) = 
02328                                                     preamble_end_sh_idx;
02329                }
02330                preamble_end_sh_idx = SH_NEXT_IDX(preamble_end_sh_idx);
02331                SH_COMPILER_GEN(preamble_end_sh_idx) = TRUE;
02332                SH_P2_SKIP_ME(preamble_end_sh_idx) = TRUE;
02333             }
02334          }
02335 
02336          /* Produce another IL node at the end of the IL list attached to the */
02337          /* Loop_Info IR.  The trip count will be saved in an IL attached to  */
02338          /* this "loop temps" IL node.  The trip count will either be a temp  */
02339          /* or a constant.                                                    */
02340 
02341          NTR_IR_LIST_TBL(loop_temps_il_idx);
02342 
02343          if (cif_flags & MISC_RECS) {
02344             il_idx = IL_NEXT_LIST_IDX(loop_labels_il_idx);
02345          }
02346          else {
02347             il_idx = loop_labels_il_idx;
02348          }
02349 
02350          IL_NEXT_LIST_IDX(il_idx)            = loop_temps_il_idx;
02351          IL_PREV_LIST_IDX(loop_temps_il_idx) = il_idx;
02352          ++IR_LIST_CNT_R(loop_info_idx); 
02353 
02354          NTR_IR_LIST_TBL(il_idx);
02355          IL_LIST_CNT(loop_temps_il_idx) = 1;
02356          IL_FLD(loop_temps_il_idx)      = IL_Tbl_Idx;
02357          IL_IDX(loop_temps_il_idx)      = il_idx;
02358          IL_LINE_NUM(il_idx)            = stmt_start_line;
02359          IL_COL_NUM(il_idx)             = stmt_start_col;
02360 
02361 # endif 
02362        
02363 
02364          /* If all 3 loop control expressions are constant, we can check the  */
02365          /* values to see if the loop will actually be executed and can       */
02366          /* calculate the iteration count at compile time.                    */
02367 
02368          if (start_idx != NULL_IDX) {
02369 
02370             /* The iteration count is zero for both of the following cases:   */
02371             /*     start-expr < end-expr  and  inc-expr < 0                   */
02372             /*     start-expr > end-expr  and  inc-expr > 0                   */
02373 
02374             if ((fold_relationals(start_idx, end_idx, Lt_Opr)  &&
02375                  fold_relationals(inc_idx, CN_INTEGER_ZERO_IDX, Lt_Opr))  ||
02376                 (fold_relationals(start_idx, end_idx, Gt_Opr)  &&
02377                  fold_relationals(inc_idx, CN_INTEGER_ZERO_IDX, Gt_Opr))  &&
02378                 ! on_off_flags.exec_doloops_once) {  
02379                PRINTMSG(stmt_start_line, 254, Caution, stmt_start_col);
02380                tmp_idx = CN_INTEGER_ZERO_IDX;
02381             }
02382 
02383 # ifndef _HIGH_LEVEL_DO_LOOP_FORM
02384 
02385             else {
02386                tmp_idx = calculate_iteration_count(do_sh_idx,
02387                                                    start_idx,
02388                                                    end_idx,
02389                                                    inc_idx,
02390                                                    do_var_idx);
02391             }
02392 
02393             IL_FLD(il_idx) = CN_Tbl_Idx;
02394             IL_IDX(il_idx) = tmp_idx;
02395             IL_LINE_NUM(il_idx) = stmt_start_line;
02396             IL_COL_NUM(il_idx) = stmt_start_col;
02397 
02398 # endif
02399 
02400          }
02401 
02402 
02403 # ifndef _HIGH_LEVEL_DO_LOOP_FORM
02404 
02405          /* Possibly generate the "skip the loop?" test.                      */
02406          /*                                                                   */
02407          /* * If the increment is constant and is positive, generate:         */
02408          /*                                                                   */
02409          /*      IF ((end - start) < 0) branch around loop                    */
02410          /*                                                                   */
02411          /* * If the increment is constant and is negative, generate:         */
02412          /*                                                                   */
02413          /*      IF ((end - start) > 0) branch around loop                    */
02414          /*                                                                   */
02415          /* * If the increment is unknown (a variable), generate:             */
02416          /*                                                                   */
02417          /*      IF (((end - start) .NE. 0)  .AND.                            */
02418          /*          (XOR(end - start, inc) .LT. 0)) branch around            */
02419          /*                                                                   */
02420          /* The test is generated only if:                                    */
02421          /*   - "one-trip" DO were loops were NOT specified, and              */
02422          /*   - at least one of the loop control expressions is               */
02423          /*   - the iteration count was calculated and found to be            */
02424          /*     nonconstant or they're all constant but the interation        */
02425          /*     count is <= 0 (if the iteration count <= 0, too bad - they    */
02426          /*     get the IF test for stupidity).                               */
02427 
02428          if (! on_off_flags.exec_doloops_once  &&
02429              (start_idx == NULL_IDX  ||
02430               fold_relationals(tmp_idx, CN_INTEGER_ZERO_IDX, Le_Opr))) {
02431 
02432             NTR_IR_TBL(expr_ir_idx);
02433             IR_OPR(expr_ir_idx)        = Minus_Opr;
02434             IR_TYPE_IDX(expr_ir_idx)   = ATD_TYPE_IDX(do_var_idx);
02435             IR_LINE_NUM(expr_ir_idx)   = stmt_start_line;
02436             IR_COL_NUM(expr_ir_idx)    = stmt_start_col;
02437             COPY_OPND(IR_OPND_L(expr_ir_idx), IL_OPND(end_il_idx));
02438             COPY_OPND(IR_OPND_R(expr_ir_idx), IL_OPND(start_il_idx));
02439 
02440             NTR_IR_TBL(ir_idx);
02441 
02442             if (inc_idx != NULL_IDX) {
02443 
02444                if (fold_relationals(inc_idx,
02445                                     CN_INTEGER_ZERO_IDX,
02446                                     Ge_Opr)) {
02447                   IR_OPR(ir_idx) = Lt_Opr;
02448                }
02449                else {
02450                   IR_OPR(ir_idx) = Gt_Opr;
02451                }
02452             }
02453             else {
02454                IR_OPR(ir_idx) = Ne_Opr;
02455             }
02456 
02457             IR_TYPE_IDX(ir_idx)   = LOGICAL_DEFAULT_TYPE;
02458             IR_LINE_NUM(ir_idx)   = stmt_start_line;
02459             IR_COL_NUM(ir_idx)    = stmt_start_col;
02460             IR_LINE_NUM_L(ir_idx) = stmt_start_line;
02461             IR_COL_NUM_L(ir_idx)  = stmt_start_col;
02462             IR_FLD_L(ir_idx)      = IR_Tbl_Idx;
02463             IR_IDX_L(ir_idx)      = expr_ir_idx;
02464             IR_LINE_NUM_R(ir_idx) = stmt_start_line;
02465             IR_COL_NUM_R(ir_idx)  = stmt_start_col;
02466             IR_FLD_R(ir_idx)      = CN_Tbl_Idx;
02467             IR_IDX_R(ir_idx)      = CN_INTEGER_ZERO_IDX;
02468 
02469             if (inc_idx != NULL_IDX) {
02470                expr_ir_idx = ir_idx;
02471             }
02472             else {
02473                NTR_IR_TBL(expr_ir_idx);
02474                IR_OPR(expr_ir_idx)        = Minus_Opr;
02475                IR_TYPE_IDX(expr_ir_idx)   = ATD_TYPE_IDX(do_var_idx);
02476                IR_LINE_NUM(expr_ir_idx)   = stmt_start_line;
02477                IR_COL_NUM(expr_ir_idx)    = stmt_start_col;
02478                COPY_OPND(IR_OPND_L(expr_ir_idx), IL_OPND(end_il_idx));
02479                COPY_OPND(IR_OPND_R(expr_ir_idx), IL_OPND(start_il_idx));
02480    
02481                NTR_IR_TBL(ir_idx_2);
02482                IR_OPR(ir_idx_2)        = Bneqv_Opr;
02483                IR_TYPE_IDX(ir_idx_2)   = TYPELESS_DEFAULT_TYPE;
02484                IR_LINE_NUM(ir_idx_2)   = stmt_start_line;
02485                IR_COL_NUM(ir_idx_2)    = stmt_start_col;
02486                IR_LINE_NUM_L(ir_idx_2) = stmt_start_line;
02487                IR_COL_NUM_L(ir_idx_2)  = stmt_start_col;
02488                IR_FLD_L(ir_idx_2)      = IR_Tbl_Idx;
02489                IR_IDX_L(ir_idx_2)      = expr_ir_idx;
02490                COPY_OPND(IR_OPND_R(ir_idx_2), IL_OPND(inc_il_idx));
02491 
02492                NTR_IR_TBL(expr_ir_idx);
02493                IR_OPR(expr_ir_idx)        = Lt_Opr;
02494                IR_TYPE_IDX(expr_ir_idx)   = LOGICAL_DEFAULT_TYPE;
02495                IR_LINE_NUM(expr_ir_idx)   = stmt_start_line;
02496                IR_COL_NUM(expr_ir_idx)    = stmt_start_col;
02497                IR_LINE_NUM_L(expr_ir_idx) = stmt_start_line;
02498                IR_COL_NUM_L(expr_ir_idx)  = stmt_start_col;
02499                IR_FLD_L(expr_ir_idx)      = IR_Tbl_Idx;
02500                IR_IDX_L(expr_ir_idx)      = ir_idx_2;
02501                IR_LINE_NUM_R(expr_ir_idx) = stmt_start_line;
02502                IR_COL_NUM_R(expr_ir_idx)  = stmt_start_col;
02503                IR_FLD_R(expr_ir_idx)      = CN_Tbl_Idx;
02504                IR_IDX_R(expr_ir_idx)      = CN_INTEGER_ZERO_IDX;
02505 
02506                NTR_IR_TBL(ir_idx_2);
02507                IR_OPR(ir_idx_2)        = And_Opr;
02508                IR_TYPE_IDX(ir_idx_2)   = LOGICAL_DEFAULT_TYPE;
02509                IR_LINE_NUM(ir_idx_2)   = stmt_start_line;
02510                IR_COL_NUM(ir_idx_2)    = stmt_start_col;
02511                IR_LINE_NUM_L(ir_idx_2) = stmt_start_line;
02512                IR_COL_NUM_L(ir_idx_2)  = stmt_start_col;
02513                IR_FLD_L(ir_idx_2)      = IR_Tbl_Idx;
02514                IR_IDX_L(ir_idx_2)      = ir_idx;
02515                IR_LINE_NUM_R(ir_idx_2) = stmt_start_line;
02516                IR_COL_NUM_R(ir_idx_2)  = stmt_start_col;
02517                IR_FLD_R(ir_idx_2)      = IR_Tbl_Idx;
02518                IR_IDX_R(ir_idx_2)      = expr_ir_idx;
02519 
02520                expr_ir_idx = ir_idx_2;
02521             }  
02522 
02523             NTR_IR_TBL(ir_idx);
02524             IR_OPR(ir_idx)        = Br_True_Opr;
02525             IR_TYPE_IDX(ir_idx)   = LOGICAL_DEFAULT_TYPE;
02526             IR_LINE_NUM(ir_idx)   = stmt_start_line;
02527             IR_COL_NUM(ir_idx)    = stmt_start_col;
02528             IR_LINE_NUM_L(ir_idx) = stmt_start_line;
02529             IR_COL_NUM_L(ir_idx)  = stmt_start_col;
02530             IR_FLD_L(ir_idx)      = IR_Tbl_Idx;
02531             IR_IDX_L(ir_idx)      = expr_ir_idx;
02532             COPY_OPND(IR_OPND_R(ir_idx),
02533                       IL_OPND(IL_NEXT_LIST_IDX(IL_IDX(loop_labels_il_idx))));
02534 
02535             gen_sh(After, If_Stmt, stmt_start_line, stmt_start_col,
02536                    FALSE, FALSE, TRUE);
02537 
02538             SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02539          }
02540 
02541 
02542          if (start_idx == NULL_IDX) {
02543 
02544             /* Generate the IR tree to calculate the trip count:              */
02545             /*                                                                */
02546             /*  trip-count-tmp = (end-tmp - start-tmp + inc-tmp) / inc-tmp    */
02547             /*                                                                */
02548             /* Even though the whole calculation is temps that have already   */
02549             /* been developed, the expression must be sent through            */
02550             /* expr_semantics so data types, etc. will be propagated.         */
02551             /* If the trip count expression result type is real (including    */
02552             /* double precision), on CRAYs it must be rounded so that the     */
02553             /* trip count will match the mathematical calculation.            */
02554 
02555             NTR_IR_TBL(expr_ir_idx);
02556             IR_OPR(expr_ir_idx)        = Minus_Opr;
02557             IR_TYPE_IDX(expr_ir_idx)   = ATD_TYPE_IDX(do_var_idx);
02558             IR_LINE_NUM(expr_ir_idx)   = stmt_start_line;
02559             IR_COL_NUM(expr_ir_idx)    = stmt_start_col;
02560             COPY_OPND(IR_OPND_L(expr_ir_idx), IL_OPND(end_il_idx));
02561             COPY_OPND(IR_OPND_R(expr_ir_idx), IL_OPND(start_il_idx));
02562 
02563             NTR_IR_TBL(ir_idx);
02564    
02565             IR_OPR(ir_idx)        = Plus_Opr;
02566             IR_TYPE_IDX(ir_idx)   = ATD_TYPE_IDX(do_var_idx);
02567             IR_LINE_NUM(ir_idx)   = stmt_start_line;
02568             IR_COL_NUM(ir_idx)    = stmt_start_col;
02569             IR_LINE_NUM_L(ir_idx) = stmt_start_line;
02570             IR_COL_NUM_L(ir_idx)  = stmt_start_col;
02571             IR_FLD_L(ir_idx)      = IR_Tbl_Idx;
02572             IR_IDX_L(ir_idx)      = expr_ir_idx;
02573             COPY_OPND(IR_OPND_R(ir_idx), IL_OPND(inc_il_idx));
02574 
02575             expr_ir_idx = ir_idx;
02576 
02577             NTR_IR_TBL(ir_idx);
02578             IR_OPR(ir_idx)        = Div_Opr;
02579             IR_TYPE_IDX(ir_idx)   = ATD_TYPE_IDX(do_var_idx);
02580             IR_LINE_NUM(ir_idx)   = stmt_start_line;
02581             IR_COL_NUM(ir_idx)    = stmt_start_col;
02582             IR_LINE_NUM_L(ir_idx) = stmt_start_line;
02583             IR_COL_NUM_L(ir_idx)  = stmt_start_col;
02584             IR_FLD_L(ir_idx)      = IR_Tbl_Idx;
02585             IR_IDX_L(ir_idx)      = expr_ir_idx;
02586             COPY_OPND(IR_OPND_R(ir_idx), IL_OPND(inc_il_idx));
02587 
02588             expr_ir_idx = ir_idx;
02589 
02590             if (on_off_flags.exec_doloops_once) {
02591                NTR_IR_TBL(ir_idx);
02592                IR_OPR(ir_idx)        = Max_Opr;
02593                IR_TYPE_IDX(ir_idx)   = INTEGER_DEFAULT_TYPE;
02594                IR_LINE_NUM(ir_idx)   = stmt_start_line;
02595                IR_COL_NUM(ir_idx)    = stmt_start_col;
02596                IR_LINE_NUM_L(ir_idx) = stmt_start_line;
02597                IR_COL_NUM_L(ir_idx)  = stmt_start_col;
02598    
02599                NTR_IR_LIST_TBL(il_idx);
02600                IR_FLD_L(ir_idx)      = IL_Tbl_Idx;
02601                IR_IDX_L(ir_idx)      = il_idx;
02602                IL_LINE_NUM(il_idx)   = stmt_start_line;
02603                IL_COL_NUM(il_idx)    = stmt_start_col;
02604                IL_FLD(il_idx)        = IR_Tbl_Idx;
02605                IL_IDX(il_idx)        = expr_ir_idx;
02606    
02607                NTR_IR_LIST_TBL(il_idx_2);
02608                IL_NEXT_LIST_IDX(il_idx)   = il_idx_2;
02609                IL_PREV_LIST_IDX(il_idx_2) = il_idx;
02610                IL_LINE_NUM(il_idx_2)      = stmt_start_line;
02611                IL_COL_NUM(il_idx_2)       = stmt_start_col;
02612                IL_FLD(il_idx_2)           = CN_Tbl_Idx;
02613                IL_IDX(il_idx_2)           = CN_INTEGER_ONE_IDX;
02614 
02615                IR_LIST_CNT_L(ir_idx) = 2;
02616 
02617                expr_ir_idx = ir_idx;
02618             }
02619 
02620             gen_sh(After, Assignment_Stmt, stmt_start_line, stmt_start_col,
02621                    FALSE, FALSE, TRUE);
02622 
02623 # ifdef _TARGET_OS_UNICOS
02624 
02625             GEN_COMPILER_TMP_ASG(ir_idx,
02626                                  tmp_idx,
02627                                  FALSE,                /* Do semantics on tmp */
02628                                  stmt_start_line,
02629                                  stmt_start_col,
02630                                  (target_triton) ?
02631                                     INTEGER_DEFAULT_TYPE :
02632                                     Integer_4,          /* At PDGCS' request. */
02633                                  Priv);
02634 
02635 # else
02636 
02637             GEN_COMPILER_TMP_ASG(ir_idx,
02638                                  tmp_idx,
02639                                  FALSE,       /* Do semantics on tmp */
02640                                  stmt_start_line,
02641                                  stmt_start_col,
02642                                  INTEGER_DEFAULT_TYPE,
02643                                  Priv);
02644 
02645 # endif
02646 
02647             SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02648             IR_LINE_NUM_R(ir_idx)       = stmt_start_line;
02649             IR_COL_NUM_R(ir_idx)        = stmt_start_col;
02650             IR_FLD_R(ir_idx)            = IR_Tbl_Idx;
02651             IR_IDX_R(ir_idx)            = expr_ir_idx;
02652 
02653 
02654             /* Save the temp that represents the iteration count in the list  */
02655             /* of loop temps.                                                 */
02656 
02657             il_idx              = IL_IDX(loop_temps_il_idx); 
02658             IL_FLD(il_idx)      = AT_Tbl_Idx;
02659             IL_IDX(il_idx)      = tmp_idx;
02660             IL_LINE_NUM(il_idx) = stmt_start_line;
02661             IL_COL_NUM(il_idx)  = stmt_start_col;
02662 
02663      
02664             /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
02665             /* Now submit the trip count calculation to expr_semantics.       */
02666             /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
02667 
02668             if (on_off_flags.exec_doloops_once) {           /* Get to Max IR. */
02669                ir_idx              = IR_IDX_R(ir_idx);
02670                IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 
02671                COPY_OPND(temp_opnd, IL_OPND(IR_IDX_L(ir_idx)));
02672             }
02673             else {
02674                COPY_OPND(temp_opnd, IR_OPND_R(ir_idx));
02675             }
02676 
02677             exp_desc.rank  = 0;
02678             xref_state     = CIF_No_Usage_Rec;
02679 
02680             if (expr_semantics(&temp_opnd, &exp_desc)) {
02681 
02682 # if defined(_TARGET_OS_UNICOS) 
02683 
02684                if (exp_desc.type == Real  && 
02685                    (exp_desc.linear_type == REAL_DEFAULT_TYPE  ||
02686                     exp_desc.linear_type == DOUBLE_DEFAULT_TYPE)) {
02687                   IR_OPR(OPND_IDX(temp_opnd)) = Real_Div_To_Int_Opr;
02688                }
02689 
02690 #endif 
02691 
02692                if (on_off_flags.exec_doloops_once) {
02693                   COPY_OPND(IL_OPND(IR_IDX_L(ir_idx)), temp_opnd);
02694                }
02695                else {
02696                   COPY_OPND(IR_OPND_R(ir_idx), temp_opnd);
02697                }
02698             }
02699             else {
02700                PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 224, Internal, 0);
02701             }
02702          }
02703  
02704 
02705          /* Generate the assignment of 0 to the induction temp.               */
02706 
02707          gen_sh(After, Assignment_Stmt, stmt_start_line, stmt_start_col,
02708                 FALSE, FALSE, TRUE);
02709 
02710 # ifdef _TARGET_OS_UNICOS
02711 
02712          GEN_COMPILER_TMP_ASG(ir_idx,
02713                               tmp_idx,
02714                               FALSE,                   /* Do semantics on tmp */
02715                               stmt_start_line,
02716                               stmt_start_col,
02717                               (target_triton) ?
02718                                  INTEGER_DEFAULT_TYPE :
02719                                  Integer_4,          /* At PDGCS' request. */
02720                                  Priv);
02721 
02722 # else
02723 
02724          GEN_COMPILER_TMP_ASG(ir_idx,
02725                               tmp_idx,
02726                               FALSE,       /* Do semantics on tmp */
02727                               stmt_start_line,
02728                               stmt_start_col,
02729                               INTEGER_DEFAULT_TYPE,
02730                               Priv);
02731 # endif
02732 
02733 # if defined(CDIR_INTERCHANGE)
02734 
02735          /* This is only necessary for pdgcs based platforms.  This     */
02736          /* sets up the level list to match the do list.  For example   */
02737          /* if the user specifies  interchange(k,i,j) and the do's are  */
02738          /* nested like  do i, do j, do k, then the level list should   */
02739          /* read 2, 3, 1 (as in i is 2nd in the list, j is 3rd in the   */
02740          /* list and k is 1st in the list).                             */
02741       
02742          setup_interchange_level_list(do_var_opnd);
02743 # endif
02744 
02745          SH_IR_IDX(curr_stmt_sh_idx)       = ir_idx;
02746          IR_LINE_NUM_R(ir_idx)             = stmt_start_line;
02747          IR_COL_NUM_R(ir_idx)              = stmt_start_col;
02748          IR_FLD_R(ir_idx)                  = CN_Tbl_Idx;
02749          IR_IDX_R(ir_idx)                  = CN_INTEGER_ZERO_IDX;
02750 
02751          trip_zero_sh_idx = curr_stmt_sh_idx;
02752 
02753          /* Add another IL to the list attached to the "loop temps" IL node   */
02754          /* to save the induction temp.                                       */
02755 
02756          NTR_IR_LIST_TBL(il_idx_2);
02757          ++IL_LIST_CNT(loop_temps_il_idx);
02758          il_idx                     = IL_IDX(loop_temps_il_idx);
02759          IL_NEXT_LIST_IDX(il_idx)   = il_idx_2;
02760          IL_PREV_LIST_IDX(il_idx_2) = il_idx;
02761          IL_LINE_NUM(il_idx_2)      = stmt_start_line;
02762          IL_COL_NUM(il_idx_2)       = stmt_start_col;
02763          IL_FLD(il_idx_2)           = AT_Tbl_Idx;
02764          IL_IDX(il_idx_2)           = tmp_idx;
02765 
02766  
02767          /* Save the induction temp for use with the DOALL or DOPARALLEL      */
02768          /* CMIC$.                                                            */
02769          /* If CMIC$ DOALL was specified:                                     */
02770          /*    (1) If the loop is being executed at least once (there is no   */
02771          /*        zero trip test), then the IR generated for the DOALL when  */
02772          /*        the CMIC DOALL was processed is inserted before the        */
02773          /*        compiler-generated assignment statement that freezes the   */
02774          /*        start expression in a temp,                                */
02775          /* or (2) If the loop might not be executed, the IR generated for    */
02776          /*        the DOALL is inserted ahead of the top-of-loop label and   */
02777          /*        the loop preamble IR is duplicated and inserted after the  */
02778          /*        DOALL IR (within the parallel region).                     */
02779          /*                                                                   */
02780          /* If CMIC$ DOPARALLEL was specified the IR generated for the        */
02781          /* DOPARALLEL is inserted before the top-of-loop label.              */
02782 
02783          cg_do_var_idx  = tmp_idx;
02784 
02785          if (cdir_switches.doall_sh_idx) {
02786 
02787             IR_FLD_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) = AT_Tbl_Idx;
02788             IR_IDX_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) = cg_do_var_idx;
02789             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) = 
02790                                                                stmt_start_line;
02791             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.doall_sh_idx)) = 
02792                                                                stmt_start_col;
02793             
02794 
02795             if (on_off_flags.exec_doloops_once) {
02796 
02797                save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02798                curr_stmt_sh_idx      = start_expr_sh_idx;                  
02799                insert_sh_chain_before(cdir_switches.doall_sh_idx);
02800                curr_stmt_sh_idx      = save_curr_stmt_sh_idx;
02801             }
02802             else {
02803 
02804                save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02805                curr_stmt_sh_idx      = trip_zero_sh_idx;
02806 
02807                insert_sh_chain_before(cdir_switches.doall_sh_idx);
02808 
02809                if (preamble_start_sh_idx != NULL_IDX) {
02810                   /* insert the preamble stmts before here */
02811                   insert_sh_chain(preamble_start_sh_idx,
02812                                   preamble_end_sh_idx,
02813                                   Before);
02814                }
02815 
02816                curr_stmt_sh_idx      = save_curr_stmt_sh_idx;
02817             }
02818 
02819             if (ATD_TASK_SHARED(do_var_idx)) {
02820                PRINTMSG(do_var_line, 961, Error, do_var_col);
02821             }
02822 
02823             cdir_switches.doall_sh_idx = NULL_IDX;
02824          }
02825          else if (cdir_switches.paralleldo_omp_sh_idx) {
02826 
02827             IR_FLD_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) = 
02828                                                       AT_Tbl_Idx;
02829             IR_IDX_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) = 
02830                                                       cg_do_var_idx;
02831             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) =
02832                                                              stmt_start_line;
02833             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)) =
02834                                                                stmt_start_col;
02835            
02836 
02837             if (on_off_flags.exec_doloops_once) {
02838 
02839                save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02840                curr_stmt_sh_idx      = start_expr_sh_idx;
02841                insert_sh_chain_before(cdir_switches.paralleldo_omp_sh_idx);
02842                curr_stmt_sh_idx      = save_curr_stmt_sh_idx;
02843             }
02844             else {
02845 
02846                save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02847                curr_stmt_sh_idx      = trip_zero_sh_idx;
02848 
02849                insert_sh_chain_before(cdir_switches.paralleldo_omp_sh_idx);
02850 
02851                if (preamble_start_sh_idx != NULL_IDX) {
02852                   /* insert the preamble stmts before here */
02853                   insert_sh_chain(preamble_start_sh_idx,
02854                                   preamble_end_sh_idx,
02855                                   Before);
02856                }
02857 
02858                curr_stmt_sh_idx      = save_curr_stmt_sh_idx;
02859             }
02860 
02861             if (ATD_TASK_SHARED(do_var_idx)) {
02862                PRINTMSG(do_var_line, 961, Error, do_var_col);
02863             }
02864 
02865             cdir_switches.paralleldo_omp_sh_idx = NULL_IDX;
02866          }
02867          else if (cdir_switches.dopar_sh_idx) {
02868 
02869             IR_FLD_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) = AT_Tbl_Idx;
02870             IR_IDX_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) = cg_do_var_idx;
02871             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) = 
02872                                                              stmt_start_line;
02873             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.dopar_sh_idx)) = 
02874                                                              stmt_start_col;
02875             insert_sh_chain_before(cdir_switches.dopar_sh_idx);
02876             cdir_switches.dopar_sh_idx = NULL_IDX;
02877          }
02878          else if (cdir_switches.do_omp_sh_idx) {
02879 
02880             IR_FLD_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) = AT_Tbl_Idx;
02881             IR_IDX_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) = cg_do_var_idx;
02882             IR_LINE_NUM_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) =
02883                                                              stmt_start_line;
02884             IR_COL_NUM_R(SH_IR_IDX(cdir_switches.do_omp_sh_idx)) =
02885                                                              stmt_start_col;
02886             insert_sh_chain_before(cdir_switches.do_omp_sh_idx);
02887             cdir_switches.do_omp_sh_idx = NULL_IDX;
02888          }
02889 
02890 
02891 
02892          /* Generate a CONTINUE stmt to define the top-of-loop label.  The    */
02893          /* "referenced" flag for the label will be set when the end of the   */
02894          /* loop IR is generated to make sure the label is really referenced. */
02895 
02896          gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col,
02897                 FALSE, FALSE, TRUE);
02898 
02899          NTR_IR_TBL(ir_idx);
02900          SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02901          IR_OPR(ir_idx)              = Label_Opr;
02902          IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
02903          IR_LINE_NUM(ir_idx)         = stmt_start_line;
02904          IR_COL_NUM(ir_idx)          = stmt_start_col;
02905          COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(IL_IDX(loop_labels_il_idx)));
02906          AT_DEFINED(IR_IDX_L(ir_idx))       = TRUE;
02907          AT_DEF_LINE(IR_IDX_L(ir_idx))      = SH_GLB_LINE(do_sh_idx);
02908          ATL_DEF_STMT_IDX(IR_IDX_L(ir_idx)) = curr_stmt_sh_idx;
02909 
02910 
02911          /* Set the loop info flags on the top-of-loop label.                 */
02912 
02913          label_attr = IL_IDX(IL_IDX(loop_labels_il_idx));
02914 
02915          set_directives_on_label(label_attr);
02916 
02917          /* Generate the assignment:                                          */
02918          /*   DO-variable = start_temp + induc_temp * inc_temp                */
02919          /* Like the trip count calculation, the DO-variable value            */
02920          /* calculation uses already-established temps.  The expression is    */
02921          /* sent through expression semantics to get the data types, etc.     */
02922          /* propagated.                                                       */
02923 
02924          NTR_IR_TBL(expr_ir_idx);
02925          IR_OPR(expr_ir_idx)        = Mult_Opr;
02926          IR_LINE_NUM(expr_ir_idx)   = stmt_start_line;
02927          IR_COL_NUM(expr_ir_idx)    = stmt_start_col;
02928          IR_LINE_NUM_L(expr_ir_idx) = stmt_start_line;
02929          IR_COL_NUM_L(expr_ir_idx)  = stmt_start_col;
02930          IR_FLD_L(expr_ir_idx)      = AT_Tbl_Idx;
02931          IR_IDX_L(expr_ir_idx)      = IL_IDX(il_idx_2);
02932          COPY_OPND(IR_OPND_R(expr_ir_idx), IL_OPND(inc_il_idx));
02933 
02934          NTR_IR_TBL(ir_idx);
02935          IR_OPR(ir_idx)        = Plus_Opr;
02936          IR_LINE_NUM(ir_idx)   = stmt_start_line;
02937          IR_COL_NUM(ir_idx)    = stmt_start_col;
02938          COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(start_il_idx));
02939          IR_LINE_NUM_R(ir_idx) = stmt_start_line;
02940          IR_COL_NUM_R(ir_idx)  = stmt_start_col;
02941          IR_FLD_R(ir_idx)      = IR_Tbl_Idx;
02942          IR_IDX_R(ir_idx)      = expr_ir_idx;
02943 
02944          expr_ir_idx = ir_idx;
02945 
02946          NTR_IR_TBL(ir_idx);
02947          IR_OPR(ir_idx)        = Asg_Opr;
02948          IR_LINE_NUM(ir_idx)   = stmt_start_line;
02949          IR_COL_NUM(ir_idx)    = stmt_start_col;
02950          COPY_OPND(IR_OPND_L(ir_idx), do_var_opnd);
02951          IR_LINE_NUM_R(ir_idx) = stmt_start_line;
02952          IR_COL_NUM_R(ir_idx)  = stmt_start_col;
02953          IR_FLD_R(ir_idx)      = IR_Tbl_Idx;
02954          IR_IDX_R(ir_idx)      = expr_ir_idx;
02955 
02956          gen_sh(After, Assignment_Stmt, stmt_start_line, stmt_start_col,
02957                 FALSE, TRUE, TRUE);
02958 
02959          SH_IR_IDX(curr_stmt_sh_idx)      = ir_idx;
02960 
02961 
02962          /* Now (finally) send the DO-variable value calculation through      */
02963          /* expr_semantics.                                                   */
02964 
02965          COPY_OPND(temp_opnd, IR_OPND_R(ir_idx));
02966          exp_desc.rank    = 0;
02967          xref_state       = CIF_No_Usage_Rec;
02968 
02969          if (expr_semantics(&temp_opnd, &exp_desc)) {
02970             IR_TYPE_IDX(ir_idx) = (OPND_FLD(do_var_opnd) == AT_Tbl_Idx) ?
02971                                      ATD_TYPE_IDX(OPND_IDX(do_var_opnd)) :
02972                                      IR_TYPE_IDX(OPND_IDX(do_var_opnd));
02973             COPY_OPND(IR_OPND_R(ir_idx), temp_opnd);
02974          }
02975          else {
02976             PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 224, Internal, 0);
02977          }
02978 
02979          break;
02980 
02981 # endif                         /* End long section that does not apply to    */
02982                                 /* high-level form of the iterative DO loop.  */
02983 
02984 CLEAR_CDIR_SWITCHES:
02985 
02986          /* If this was a DOALL loop make sure that the parallel region    */
02987          /* is terminated and cdir_switches.doall_sh_idx is cleared.       */
02988          /* Clear all the other cdir_switches that would have been         */
02989          /* cleared by this loop.                                          */
02990 
02991          clear_cdir_switches();
02992 
02993          goto EXIT;
02994 
02995 
02996       /* -------------------------------------------------------------------- */
02997       /*                                                                      */
02998       /*                       DO WHILE statement                             */
02999       /*                                                                      */
03000       /* -------------------------------------------------------------------- */
03001 
03002       case Do_While_Stmt:
03003 
03004          if (cdir_switches.do_omp_sh_idx) {
03005 
03006             PRINTMSG(IR_LINE_NUM(SH_IR_IDX(cdir_switches.do_omp_sh_idx)),
03007                      1544, Error,
03008                      IR_COL_NUM(SH_IR_IDX(cdir_switches.do_omp_sh_idx)),
03009                      "!$OMP DO");
03010 
03011             cdir_switches.do_omp_sh_idx = NULL_IDX;
03012          }
03013          else if (cdir_switches.paralleldo_omp_sh_idx) {
03014 
03015            PRINTMSG(IR_LINE_NUM(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)),
03016                      1544, Error,
03017                      IR_COL_NUM(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)),
03018                      "!$OMP PARALLEL DO");
03019 
03020             cdir_switches.paralleldo_omp_sh_idx = NULL_IDX;
03021          }
03022 
03023          /* Check the scalar-logical-expr.                                    */
03024 
03025          semantics_ok = TRUE;
03026 
03027 # ifdef _HIGH_LEVEL_DO_LOOP_FORM
03028 #if 0  /* do not generate unused label & continue stmt--FMZ */
03029          label_idx = gen_internal_lbl(stmt_start_line);
03030          NTR_IR_TBL(ir_idx);
03031          IR_OPR(ir_idx)              = Label_Opr;
03032          IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
03033          IR_LINE_NUM(ir_idx)         = stmt_start_line;
03034          IR_COL_NUM(ir_idx)          = stmt_start_col;
03035          IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
03036          IR_IDX_L(ir_idx)            = label_idx;
03037          IR_COL_NUM_L(ir_idx)        = stmt_start_col;
03038          IR_LINE_NUM_L(ir_idx)       = stmt_start_line;
03039 
03040          AT_DEFINED(label_idx)       = TRUE;
03041          ATL_TOP_OF_LOOP(label_idx)  = TRUE;
03042 
03043          gen_sh(Before, Continue_Stmt, stmt_start_line, 
03044                 stmt_start_col, FALSE, FALSE, TRUE);
03045          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03046          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
03047 
03048          ATL_DEF_STMT_IDX(label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
03049 
03050          set_directives_on_label(label_idx);
03051 #endif 
03052          il_idx = IL_IDX(loop_control_il_idx);
03053          COPY_OPND(temp_opnd, IL_OPND(il_idx));
03054 
03055          if (OPND_FLD(temp_opnd) == IR_Tbl_Idx) {
03056             copy_subtree(&temp_opnd, &temp_opnd);
03057          }
03058 
03059          /* Insert an assignment stmt ahead of the DO loop to capture the     */
03060          /* loop control expression in a temp.  We need to do this (and to    */
03061          /* repeat the assignment at the end of the loop) for the case where  */
03062          /* the expression contains a function reference.                     */
03063 
03064          curr_stmt_sh_idx = SH_PREV_IDX(do_sh_idx);
03065 
03066          gen_sh(After, 
03067                 Assignment_Stmt,
03068                 SH_GLB_LINE(do_sh_idx),
03069                 SH_COL_NUM(do_sh_idx),
03070                 FALSE,                          /* Error flag.                */
03071                 FALSE,                          /* Labeled.                   */
03072                 TRUE);                          /* Compiler-generated.        */
03073 
03074          GEN_COMPILER_TMP_ASG(ir_idx,
03075                               tmp_idx,
03076                               FALSE,            /* Value of AT_SEMANTICS_DONE */
03077                                                 /* for the temp.              */
03078                               SH_GLB_LINE(do_sh_idx),
03079                               SH_COL_NUM(do_sh_idx),
03080                               LOGICAL_DEFAULT_TYPE,
03081                               Priv);            /* ADD_TMP_TO_PRIVATE_LIST    */
03082                                                 /* for the temp.              */
03083 
03084          tmp_asg_ir_idx              = ir_idx;
03085          SH_IR_IDX(curr_stmt_sh_idx) = tmp_asg_ir_idx;
03086 
03087 # else
03088 
03089          /* For the low-level form of the DO WHILE loop:                      */
03090          /*   (1) the IF SH is generated BEFORE the expression is evaluated   */
03091          /*       so that any IR generated to represent the expression is     */
03092          /*       inserted between the DO SH and the IF SH; and               */
03093          /*   (2) the scalar-logical-expr is copied BEFORE calling            */
03094          /*       expr_semantics because the tree could be expanded into a    */
03095          /*       bunch of statements.  The tree must be sent through         */
03096          /*       expr_semantics again when the end-of-loop IR is generated.  */
03097 
03098          gen_sh(After, If_Stmt, stmt_start_line, stmt_start_col,
03099                 FALSE, FALSE, TRUE);
03100 
03101          il_idx = IL_IDX(loop_control_il_idx);
03102          COPY_OPND(temp_opnd, IL_OPND(il_idx));
03103          copy_subtree(&temp_opnd, &temp_opnd);
03104 
03105          defer_stmt_expansion = TRUE;
03106 # endif
03107 
03108          exp_desc.rank  = 0;
03109          xref_state     = CIF_Symbol_Reference;
03110 
03111          if (expr_semantics(&temp_opnd, &exp_desc)) {
03112 
03113             if (exp_desc.rank != 0) {
03114                PRINTMSG(IL_LINE_NUM(il_idx), 222, Error, IL_COL_NUM(il_idx));
03115                semantics_ok = FALSE;
03116             }
03117 
03118             if (exp_desc.type == Logical) {
03119 
03120                if (semantics_ok) {
03121 
03122 # ifdef _HIGH_LEVEL_DO_LOOP_FORM
03123 
03124                   COPY_OPND(IR_OPND_R(tmp_asg_ir_idx), temp_opnd);
03125                   curr_stmt_sh_idx = do_sh_idx;
03126 
03127                   /* Save the original expression index in an IL at the end   */
03128                   /* of the IL list attached to the Loop_Info IR.  Then plug  */
03129                   /* WHILE expression temp result into the IL where the       */
03130                   /* expression index originally appeared.                    */
03131 
03132                   NTR_IR_LIST_TBL(il_idx_2);
03133                   IL_NEXT_LIST_IDX(loop_labels_il_idx) = il_idx_2;
03134                   IL_PREV_LIST_IDX(il_idx_2)           = loop_labels_il_idx;
03135                   ++IR_LIST_CNT_R(loop_info_idx);
03136                   COPY_OPND(IL_OPND(il_idx_2), IL_OPND(il_idx));
03137                   IL_FLD(il_idx) = AT_Tbl_Idx;
03138                   IL_IDX(il_idx) = tmp_idx;
03139        
03140 # else
03141 
03142                   defer_stmt_expansion = FALSE;
03143 
03144                   if (tree_produces_dealloc(&temp_opnd)) {
03145                      /* make logical tmp asg */
03146                      save_curr_stmt_sh_idx = curr_stmt_sh_idx;
03147                      find_opnd_line_and_column(&temp_opnd,
03148                                        &opnd_line, &opnd_column);
03149 
03150                      GEN_COMPILER_TMP_ASG(asg_idx,
03151                                           tmp_idx,
03152                                           TRUE,       /* Semantics done */
03153                                           opnd_line,
03154                                           opnd_column,
03155                                           exp_desc.type_idx,
03156                                           Priv);
03157 
03158                      gen_sh(Before, Assignment_Stmt, opnd_line,
03159                             opnd_column, FALSE, FALSE, TRUE);
03160 
03161                      curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03162 
03163                      SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
03164                      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
03165 
03166                      process_deferred_functions(&temp_opnd);
03167                      COPY_OPND(IR_OPND_R(asg_idx), temp_opnd);
03168 
03169                      OPND_FLD(temp_opnd)        = AT_Tbl_Idx;
03170                      OPND_IDX(temp_opnd)        = tmp_idx;
03171                      OPND_LINE_NUM(temp_opnd)   = opnd_line;
03172                      OPND_COL_NUM(temp_opnd)    = opnd_column;
03173                      curr_stmt_sh_idx           = save_curr_stmt_sh_idx;
03174                   }
03175                   else {
03176                      process_deferred_functions(&temp_opnd);
03177                   }
03178 
03179                   /* Generate   IF (.NOT. scalar-logical-expr) GO TO skip-lbl */
03180 
03181                   NTR_IR_TBL(expr_ir_idx);
03182                   IR_OPR(expr_ir_idx)      = Not_Opr;
03183                   IR_TYPE_IDX(expr_ir_idx) = LOGICAL_DEFAULT_TYPE;
03184                   IR_LINE_NUM(expr_ir_idx) = stmt_start_line;
03185                   IR_COL_NUM(expr_ir_idx)  = stmt_start_col;
03186                   COPY_OPND(IR_OPND_L(expr_ir_idx), temp_opnd);
03187 
03188                   NTR_IR_TBL(ir_idx);
03189                   IR_OPR(ir_idx)        = Br_True_Opr;
03190                   IR_TYPE_IDX(ir_idx)   = LOGICAL_DEFAULT_TYPE;
03191                   IR_LINE_NUM(ir_idx)   = stmt_start_line;
03192                   IR_COL_NUM(ir_idx)    = stmt_start_col;
03193                   IR_LINE_NUM_L(ir_idx) = stmt_start_line;
03194                   IR_COL_NUM_L(ir_idx)  = stmt_start_col;
03195                   IR_FLD_L(ir_idx)      = IR_Tbl_Idx;
03196                   IR_IDX_L(ir_idx)      = expr_ir_idx;
03197                   IR_LINE_NUM_R(ir_idx) = stmt_start_line;
03198                   IR_COL_NUM_R(ir_idx)  = stmt_start_col;
03199                   IR_FLD_R(ir_idx)      = AT_Tbl_Idx;
03200                   lbl_il_idx            = 
03201                      IL_NEXT_LIST_IDX(IL_IDX(loop_labels_il_idx));
03202                   IR_IDX_R(ir_idx)      = IL_IDX(lbl_il_idx);
03203 
03204                   IR_TYPE_IDX(ir_idx) = exp_desc.type_idx;
03205 
03206                   SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
03207 
03208 # endif
03209 
03210                }
03211             }
03212             else {
03213                PRINTMSG(IL_LINE_NUM(il_idx), 234, Error, IL_COL_NUM(il_idx));
03214                semantics_ok = FALSE;
03215             }
03216          }
03217          else {
03218             semantics_ok = FALSE;
03219          }
03220 
03221 # ifdef _HIGH_LEVEL_DO_LOOP_FORM
03222 
03223          if (! semantics_ok) {
03224             SH_ERR_FLG(do_sh_idx) = TRUE;
03225             curr_stmt_sh_idx      = do_sh_idx;
03226          }
03227 
03228 # else
03229 
03230          defer_stmt_expansion = FALSE;
03231 
03232          label_attr = IL_IDX(IL_IDX(loop_labels_il_idx));
03233 
03234          if (semantics_ok) {
03235 
03236             /* Generate a CONTINUE statement to define the top-of-loop label. */
03237 
03238             gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col,
03239                    FALSE, FALSE, TRUE);
03240 
03241             NTR_IR_TBL(ir_idx);
03242             SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
03243             IR_OPR(ir_idx)              = Label_Opr;
03244             IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
03245             IR_LINE_NUM(ir_idx)         = stmt_start_line;
03246             IR_COL_NUM(ir_idx)          = stmt_start_col;
03247             IR_LINE_NUM_L(ir_idx)       = stmt_start_line;
03248             IR_COL_NUM_L(ir_idx)        = stmt_start_col;
03249             IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
03250             IR_IDX_L(ir_idx)            = label_attr;
03251 
03252             AT_DEF_LINE(label_attr) =
03253                SH_GLB_LINE(SH_NEXT_IDX(curr_stmt_sh_idx));
03254             ATL_DEF_STMT_IDX(label_attr) = curr_stmt_sh_idx;
03255          }
03256          else {
03257             SH_PARENT_BLK_IDX(IR_IDX_L(loop_info_idx)) = NULL_IDX;
03258          }
03259 
03260 
03261          /* Set the loop info flags on the label.                             */
03262 
03263          set_directives_on_label(label_attr);
03264 
03265 # endif
03266 
03267          break;
03268 
03269 
03270       /* -------------------------------------------------------------------- */
03271       /*                                                                      */
03272       /*                      "Infinite" DO statement                         */
03273       /*                                                                      */
03274       /* -------------------------------------------------------------------- */
03275 
03276       case Do_Infinite_Stmt:
03277 
03278          if (cdir_switches.do_omp_sh_idx) {
03279 
03280             PRINTMSG(IR_LINE_NUM(SH_IR_IDX(cdir_switches.do_omp_sh_idx)),
03281                      1544, Error,
03282                      IR_COL_NUM(SH_IR_IDX(cdir_switches.do_omp_sh_idx)),
03283                      "!$OMP DO");
03284 
03285             cdir_switches.do_omp_sh_idx = NULL_IDX;
03286          }
03287          else if (cdir_switches.paralleldo_omp_sh_idx) {
03288 
03289            PRINTMSG(IR_LINE_NUM(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)),
03290                      1544, Error,
03291                      IR_COL_NUM(SH_IR_IDX(cdir_switches.paralleldo_omp_sh_idx)),
03292                      "!$OMP PARALLEL DO");
03293 
03294             cdir_switches.paralleldo_omp_sh_idx = NULL_IDX;
03295          }
03296 
03297          /* Generate a CONTINUE statement to define the top-of-loop label.    */
03298 
03299          gen_sh(After,
03300                 Continue_Stmt,
03301                 SH_GLB_LINE(SH_NEXT_IDX(curr_stmt_sh_idx)),
03302                 SH_COL_NUM(SH_NEXT_IDX(curr_stmt_sh_idx)),
03303                 FALSE,
03304                 TRUE,
03305                 TRUE);
03306 
03307          NTR_IR_TBL(ir_idx);
03308          SH_IR_IDX(curr_stmt_sh_idx)  = ir_idx;
03309          IR_OPR(ir_idx)               = Label_Opr;
03310          IR_TYPE_IDX(ir_idx)          = TYPELESS_DEFAULT_TYPE;
03311          IR_LINE_NUM(ir_idx)          = SH_GLB_LINE(curr_stmt_sh_idx);
03312          IR_COL_NUM(ir_idx)           = SH_COL_NUM(curr_stmt_sh_idx);
03313          IR_LINE_NUM_L(ir_idx)        = IR_LINE_NUM(ir_idx);
03314          IR_COL_NUM_L(ir_idx)         = IR_COL_NUM(ir_idx);
03315          IR_FLD_L(ir_idx)             = AT_Tbl_Idx;
03316          label_attr                   = IL_IDX(IL_IDX(loop_labels_il_idx));
03317          IR_IDX_L(ir_idx)             = label_attr;
03318          AT_DEFINED(label_attr)       = TRUE;
03319          AT_DEF_LINE(label_attr)      =
03320             SH_GLB_LINE(SH_NEXT_IDX(curr_stmt_sh_idx));
03321          ATL_DEF_STMT_IDX(label_attr) = curr_stmt_sh_idx;
03322 
03323          break;
03324 
03325 
03326       /* -------------------------------------------------------------------- */
03327       /*                                                                      */
03328       /*                      P R O B L E M S ! ! !                           */
03329       /*                                                                      */
03330       /* -------------------------------------------------------------------- */
03331 
03332       default:
03333          PRINTMSG(stmt_start_line, 179, Internal, stmt_start_col,
03334                   "do_stmt_semantics");
03335    }
03336 
03337 EXIT:
03338 
03339    TRACE (Func_Exit, "do_stmt_semantics", NULL);
03340 
03341    return;
03342 
03343 }  /* do_stmt_semantics */
03344 
03345 
03346 /******************************************************************************\
03347 |*                                                                            *|
03348 |* Description:                                                               *|
03349 |*      This function handles the following syntax:                           *|
03350 |*         else-stmt       => ELSE [if-construct-name]                        *|
03351 |*         else-if-stmt    => ELSE IF ( sclr-lgcl-expr ) THEN [if-cnstrct-nme]*|
03352 |*         elsewhere-stmt  => ELSE WHERE                                      *|
03353 |*                                                                            *|
03354 |* Input parameters:                                                          *|
03355 |*      NONE                                                                  *|
03356 |*                                                                            *|
03357 |* Output parameters:                                                         *|
03358 |*      NONE                                                                  *|
03359 |*                                                                            *|
03360 |* Returns:                                                                   *|
03361 |*      NONE                                                                  *|
03362 |*                                                                            *|
03363 \******************************************************************************/
03364 
03365 void else_stmt_semantics (void)
03366 
03367 {
03368    int                  and_idx;
03369    int                  col;
03370    opnd_type            cond_expr;
03371    int                  cond_expr_ir_idx;
03372    expr_arg_type        exp_desc;
03373    int                  ir_idx;
03374    int                  line;
03375    int                  list_idx;
03376    opnd_type            mask_expr_opnd;
03377    int                  mask_expr_tmp;
03378    boolean              ok = TRUE;
03379    opnd_type            opnd;
03380    opnd_type            pending_mask_opnd;
03381    int                  sh_idx;
03382   
03383 # if defined(_HIGH_LEVEL_IF_FORM)
03384    int                  else_sh_idx;
03385    int                  endif_sh_idx;
03386    int                  save_curr_stmt_sh_idx;
03387 # else
03388    int                  cont_lbl_idx;
03389    int                  if_ir_idx;
03390    int                  prev_part_idx;
03391 # endif
03392 
03393 
03394    TRACE (Func_Entry, "else_stmt_semantics", NULL);
03395 
03396    switch (stmt_type) {
03397       case Else_Stmt:
03398 
03399 # if defined(_HIGH_LEVEL_IF_FORM)
03400          /* find Endif_Opr stmt. */
03401 
03402 # if defined(_DEBUG)
03403          if (IR_OPR(SH_IR_IDX(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))) != If_Opr) {
03404             PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
03405                      "If_Opr", "else_stmt_semantics");
03406          }
03407 # endif
03408 
03409          endif_sh_idx = IR_IDX_R(SH_IR_IDX(
03410                                 SH_PARENT_BLK_IDX(curr_stmt_sh_idx)));
03411 
03412          SH_PARENT_BLK_IDX(endif_sh_idx) = curr_stmt_sh_idx;
03413          SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = 
03414                                        IR_IDX_L(SH_IR_IDX(endif_sh_idx));
03415 
03416 # else
03417          /* Generate a GO TO stmt ahead of the ELSE SH to branch to the end   */
03418          /* of the IF construct.  Get the END IF label from the second IL     */
03419          /* attached to the right operand of the If_Opr IR attached to the    */
03420          /* If_Cstrct SH.  (Walk back through the SH_PARENT_BLK_IDX chain to  */
03421          /* find the If_Cstrct SH.)                                           */
03422 
03423          gen_sh(Before, Goto_Stmt,
03424                 SH_GLB_LINE(SH_PREV_IDX(curr_stmt_sh_idx)),
03425                 SH_COL_NUM(SH_PREV_IDX(curr_stmt_sh_idx)),
03426                 FALSE, FALSE, TRUE);             /* compiler-generated = TRUE */
03427 
03428          sh_idx                 = SH_PREV_IDX(curr_stmt_sh_idx);
03429          NTR_IR_TBL(ir_idx);
03430          SH_IR_IDX(sh_idx)      = ir_idx;
03431          IR_OPR(ir_idx)         = Br_Uncond_Opr;
03432          IR_TYPE_IDX(ir_idx)    = TYPELESS_DEFAULT_TYPE;
03433          IR_LINE_NUM(ir_idx)    = SH_GLB_LINE(SH_PREV_IDX(sh_idx));
03434          IR_COL_NUM(ir_idx)     = SH_COL_NUM(SH_PREV_IDX(sh_idx));
03435 
03436          IR_LINE_NUM_R(ir_idx)  = SH_GLB_LINE(SH_PREV_IDX(sh_idx));
03437          IR_COL_NUM_R(ir_idx)   = SH_COL_NUM(SH_PREV_IDX(sh_idx));
03438          IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
03439 
03440          sh_idx = IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx));
03441 
03442          while (SH_STMT_TYPE(sh_idx) != If_Cstrct_Stmt) {
03443             sh_idx = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(SH_IR_IDX(sh_idx))));
03444          }
03445 
03446          if_ir_idx = SH_IR_IDX(sh_idx);
03447 
03448          IR_IDX_R(ir_idx) = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(if_ir_idx)));
03449 
03450 
03451          /* Generate a CONTINUE stmt to define the start of the ELSE.  If     */
03452          /* there are no ELSE IF stmts preceding this ELSE then get the       */
03453          /* branch-around label from the first IL attached to the If_Opr IR   */
03454          /* attached to the If_Cstrct SH.  If there was at least one ELSE IF  */
03455          /* stmt, then get the label from the right operand of the preceding  */
03456          /* ELSE IF (via SH_PARENT_BLK_IDX).                                  */
03457 
03458          gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col,
03459                 FALSE,
03460                 TRUE,                                   /* Labeled.           */
03461                 TRUE);                                  /* Compiler-generated */
03462 
03463          sh_idx                = SH_PREV_IDX(curr_stmt_sh_idx);
03464          NTR_IR_TBL(ir_idx);
03465          SH_IR_IDX(sh_idx)     = ir_idx;
03466          IR_OPR(ir_idx)        = Label_Opr;
03467          IR_TYPE_IDX(ir_idx)   = TYPELESS_DEFAULT_TYPE;
03468          IR_LINE_NUM(ir_idx)   = stmt_start_line;
03469          IR_COL_NUM(ir_idx)    = stmt_start_col;
03470          IR_LINE_NUM_L(ir_idx) = stmt_start_line;
03471          IR_COL_NUM_L(ir_idx)  = stmt_start_col;
03472          IR_FLD_L(ir_idx)      = AT_Tbl_Idx;
03473 
03474          prev_part_idx = IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx));
03475 
03476          if (SH_STMT_TYPE(prev_part_idx) == If_Cstrct_Stmt) {
03477             cont_lbl_idx = IL_IDX(IR_IDX_R(if_ir_idx));
03478          }
03479          else {
03480             cont_lbl_idx = IL_IDX(IR_IDX_R(SH_IR_IDX(prev_part_idx)));
03481          }
03482 
03483          IR_IDX_L(ir_idx)               = cont_lbl_idx;
03484          AT_DEFINED(cont_lbl_idx)       = TRUE;
03485          AT_DEF_LINE(cont_lbl_idx)      = stmt_start_line;
03486          AT_DEF_COLUMN(cont_lbl_idx)    = stmt_start_col;
03487          AT_REFERENCED(cont_lbl_idx)    = Referenced;
03488          ATL_DEF_STMT_IDX(cont_lbl_idx) = sh_idx;
03489 #endif
03490 
03491          break;
03492 
03493 
03494       case Else_If_Stmt:
03495 
03496          cond_expr_ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
03497 
03498 # if defined(_HIGH_LEVEL_IF_FORM)
03499          /* generate an Else_Opr stmt and change curr stmt to If_Opr */
03500 
03501          NTR_IR_TBL(ir_idx);
03502          IR_OPR(ir_idx) = Else_Opr;
03503          IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
03504          IR_LINE_NUM(ir_idx) = IR_LINE_NUM(cond_expr_ir_idx);
03505          IR_COL_NUM(ir_idx)  = IR_COL_NUM(cond_expr_ir_idx);
03506          COPY_OPND(IR_OPND_L(ir_idx), 
03507                    IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(cond_expr_ir_idx))));
03508 
03509          gen_sh(Before, Else_Stmt, stmt_start_line, stmt_start_col,
03510                 FALSE,
03511                 FALSE,                                /* Not Labeled.       */
03512                 TRUE);                                /* Compiler-generated */
03513          else_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03514          SH_IR_IDX(else_sh_idx) = ir_idx;
03515 
03516          /* change Else_If_Opr to If_Opr */
03517 
03518          IR_OPR(cond_expr_ir_idx) = If_Opr;
03519          SH_STMT_TYPE(curr_stmt_sh_idx) = If_Stmt;
03520 
03521          /* find Endif_Opr stmt. */
03522 
03523 # if defined(_DEBUG)
03524          if (IR_OPR(SH_IR_IDX(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))) != If_Opr) {
03525             PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
03526                      "If_Opr", "else_stmt_semantics");
03527          }
03528 # endif
03529 
03530          endif_sh_idx = IR_IDX_R(SH_IR_IDX(
03531                                 SH_PARENT_BLK_IDX(curr_stmt_sh_idx)));
03532 
03533          SH_PARENT_BLK_IDX(endif_sh_idx) = else_sh_idx;
03534 
03535          save_curr_stmt_sh_idx = curr_stmt_sh_idx;
03536          curr_stmt_sh_idx = endif_sh_idx;
03537 
03538          SH_PARENT_BLK_IDX(else_sh_idx) = IR_IDX_L(SH_IR_IDX(endif_sh_idx));
03539 
03540          /* generate a new Endif_Opr stmt before endif_sh_idx */
03541 
03542          NTR_IR_TBL(ir_idx);
03543          IR_OPR(ir_idx) = Endif_Opr;
03544          IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
03545          IR_LINE_NUM(ir_idx) = IR_LINE_NUM(cond_expr_ir_idx);
03546          IR_COL_NUM(ir_idx)  = IR_COL_NUM(cond_expr_ir_idx);
03547 
03548          IR_FLD_L(ir_idx) = SH_Tbl_Idx;
03549          IR_IDX_L(ir_idx) = save_curr_stmt_sh_idx;
03550 
03551          gen_sh(Before, End_If_Stmt, stmt_start_line, stmt_start_col,
03552                 FALSE,
03553                 FALSE,                                /* Not Labeled.       */
03554                 TRUE);                                /* Compiler-generated */
03555          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
03556          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03557 
03558          endif_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03559 
03560          /* set SH_PAREN_BLK_IDX to If_Opr stmt for now. */
03561          /* It may be overwritten if an Else or Else if clause follows */
03562          SH_PARENT_BLK_IDX(endif_sh_idx) = save_curr_stmt_sh_idx;
03563 
03564          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
03565 
03566          IR_IDX_R(SH_IR_IDX(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))) = 
03567                                                                endif_sh_idx;
03568 
03569          SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = 0;
03570 # endif
03571          /* The conditional expression must be scalar and type logical.       */
03572    
03573 
03574          in_branch_true       = TRUE;
03575          defer_stmt_expansion = TRUE;
03576          io_item_must_flatten = FALSE;
03577          number_of_functions  = 0;
03578 
03579          COPY_OPND(cond_expr, IR_OPND_L(cond_expr_ir_idx));
03580          exp_desc.rank = 0;
03581          xref_state    = CIF_Symbol_Reference;
03582 
03583          has_present_opr = FALSE;
03584          ok = expr_semantics(&cond_expr, &exp_desc);
03585          has_present_opr = FALSE;
03586 
03587          COPY_OPND(IR_OPND_L(cond_expr_ir_idx), cond_expr);
03588 
03589          defer_stmt_expansion = FALSE;
03590          in_branch_true       = FALSE;
03591 
03592          if (ok && exp_desc.rank != 0) {
03593             PRINTMSG(IR_LINE_NUM(cond_expr_ir_idx), 410, Error,
03594                      IR_COL_NUM(cond_expr_ir_idx));
03595          }
03596 
03597          if (ok && exp_desc.type != Logical) {
03598             PRINTMSG(IR_LINE_NUM(cond_expr_ir_idx), 416, Error,
03599                      IR_COL_NUM(cond_expr_ir_idx));
03600          } 
03601 
03602 #ifndef _HIGH_LEVEL_IF_FORM
03603 
03604          /* Generate a GO TO stmt ahead of the ELSE IF SH to branch to  */
03605          /* the end of the IF construct.  Get the END IF label from the */
03606          /* second IL attached to the right operand of the If_Opr IR    */
03607          /* attached to the If_Cstrct SH.  (Walk back through the       */
03608          /* SH_PARENT_BLK_IDX chain to find the If_Cstrct SH.)          */
03609 
03610          gen_sh(Before, Goto_Stmt,
03611                 SH_GLB_LINE(SH_PREV_IDX(curr_stmt_sh_idx)),
03612                 SH_COL_NUM(SH_PREV_IDX(curr_stmt_sh_idx)),
03613                 FALSE, FALSE, TRUE);       /* compiler-generated = TRUE */
03614 
03615          sh_idx                 = SH_PREV_IDX(curr_stmt_sh_idx);
03616          NTR_IR_TBL(ir_idx);
03617          SH_IR_IDX(sh_idx)      = ir_idx;
03618          IR_OPR(ir_idx)         = Br_Uncond_Opr;
03619          IR_TYPE_IDX(ir_idx)    = TYPELESS_DEFAULT_TYPE;
03620          IR_LINE_NUM(ir_idx)    = SH_GLB_LINE(SH_PREV_IDX(sh_idx));
03621          IR_COL_NUM(ir_idx)     = SH_COL_NUM(SH_PREV_IDX(sh_idx));
03622 
03623          IR_LINE_NUM_R(ir_idx)  = SH_GLB_LINE(SH_PREV_IDX(sh_idx));
03624          IR_COL_NUM_R(ir_idx)   = SH_COL_NUM(SH_PREV_IDX(sh_idx));
03625          IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
03626 
03627          sh_idx =
03628             IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx))));
03629 
03630          while (SH_STMT_TYPE(sh_idx) != If_Cstrct_Stmt) {
03631             sh_idx = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(SH_IR_IDX(sh_idx))));
03632          }
03633 
03634          if_ir_idx = SH_IR_IDX(sh_idx);
03635 
03636          IR_IDX_R(ir_idx) = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(if_ir_idx)));
03637 
03638 
03639          /* Generate a CONTINUE stmt to define the start of the ELSE    */
03640          /* IF.  If this is the first ELSE IF stmt, get the             */
03641          /* branch-around label from the first IL attached to the       */
03642          /* If_Opr IR attached to the If_Cstrct SH.  Otherwise, get it  */
03643          /* from the first IL attached to the right operand of the      */
03644          /* preceding ELSE IF.                                        */
03645 
03646          gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col,
03647                 FALSE, TRUE, TRUE);
03648 
03649          sh_idx                         = SH_PREV_IDX(curr_stmt_sh_idx);
03650          NTR_IR_TBL(ir_idx);
03651          SH_IR_IDX(sh_idx)              = ir_idx;
03652          IR_OPR(ir_idx)                 = Label_Opr;
03653          IR_TYPE_IDX(ir_idx)            = TYPELESS_DEFAULT_TYPE;
03654          IR_LINE_NUM(ir_idx)            = stmt_start_line;
03655          IR_COL_NUM(ir_idx)             = stmt_start_col;
03656          IR_LINE_NUM_L(ir_idx)          = stmt_start_line;
03657          IR_COL_NUM_L(ir_idx)           = stmt_start_col;
03658          IR_FLD_L(ir_idx)               = AT_Tbl_Idx;
03659 
03660          prev_part_idx =
03661             IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx))));
03662          cont_lbl_idx = IL_IDX(IR_IDX_R(SH_IR_IDX(prev_part_idx)));
03663 
03664          IR_IDX_L(ir_idx)               = cont_lbl_idx;
03665          AT_DEFINED(cont_lbl_idx)       = TRUE;
03666          AT_DEF_LINE(cont_lbl_idx)      = stmt_start_line;
03667          AT_DEF_COLUMN(cont_lbl_idx)    = stmt_start_col;
03668          AT_REFERENCED(cont_lbl_idx)    = Referenced;
03669          ATL_DEF_STMT_IDX(cont_lbl_idx) = sh_idx;
03670 
03671 
03672          /* Generate the ".NOT. cond" IR under the Br_True IR.        */
03673 
03674          IR_FLD_L(cond_expr_ir_idx) = IR_Tbl_Idx;
03675          NTR_IR_TBL(ir_idx);
03676          IR_IDX_L(cond_expr_ir_idx) = ir_idx;
03677 
03678          IR_OPR(ir_idx)        = Not_Opr;
03679          IR_TYPE_IDX(ir_idx)   = LOGICAL_DEFAULT_TYPE;
03680          IR_LINE_NUM(ir_idx)   = stmt_start_line;
03681          IR_COL_NUM(ir_idx)    = stmt_start_col;
03682          COPY_OPND(IR_OPND_L(ir_idx), cond_expr);
03683 
03684          
03685          /* Generate the branch-around label and save it in the first   */
03686          /* IL attached to the right operand of the Br_True IR.         */
03687          /* END IF processing will pull the label into the right operand*/
03688          /* of the Br_True IR.                                        */
03689 
03690          IL_LINE_NUM(IR_IDX_R(cond_expr_ir_idx)) = stmt_start_line;
03691          IL_COL_NUM(IR_IDX_R(cond_expr_ir_idx))  = stmt_start_col;
03692          IL_FLD(IR_IDX_R(cond_expr_ir_idx))      = AT_Tbl_Idx;
03693          IL_IDX(IR_IDX_R(cond_expr_ir_idx)) = gen_internal_lbl(stmt_start_line);
03694 
03695 #endif
03696  
03697                
03698          /* short_circuit_branch calls process_deferred_functions.      */
03699 
03700 
03701 #ifdef _HIGH_LEVEL_IF_FORM
03702 
03703          if (ok) {
03704             short_circuit_high_level_if();
03705          }
03706 #else
03707 
03708          if (ok) {
03709             short_circuit_branch();
03710          }
03711 
03712 #endif
03713 
03714 
03715          in_branch_true       = FALSE;
03716          defer_stmt_expansion = FALSE;
03717          io_item_must_flatten = FALSE;
03718          arg_info_list_base   = NULL_IDX;
03719          arg_info_list_top    = NULL_IDX;
03720       
03721          break;
03722 
03723       case Else_Where_Stmt:
03724 
03725          ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
03726          line = IR_LINE_NUM(ir_idx);
03727          col = IR_COL_NUM(ir_idx);
03728 
03729          sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
03730 # ifdef _DEBUG
03731          if (sh_idx == NULL_IDX) {
03732             PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
03733                      "SH_PARENT_BLK_IDX(curr_stmt_sh_idx)",
03734                      "else_stmt_semantics");
03735          }
03736 # endif
03737 
03738          if (IR_FLD_L(SH_IR_IDX(sh_idx)) == IL_Tbl_Idx &&
03739              IR_LIST_CNT_L(SH_IR_IDX(sh_idx)) == 2) {
03740 
03741             NTR_IR_LIST_TBL(list_idx);
03742             IR_FLD_L(ir_idx) = IL_Tbl_Idx;
03743             IR_LIST_CNT_L(ir_idx) = 1;
03744             IR_IDX_L(ir_idx) = list_idx;
03745 
03746             /* put the pending mask on as the control mask */
03747             COPY_OPND(IL_OPND(list_idx),
03748                       IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L(SH_IR_IDX(sh_idx)))));
03749 
03750             where_ir_idx = IL_IDX(list_idx);
03751          }
03752          break;
03753 
03754       case Else_Where_Mask_Stmt:
03755          ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
03756 
03757          exp_desc.rank        = 0;
03758          xref_state           = CIF_Symbol_Reference;
03759 
03760          COPY_OPND(opnd, IR_OPND_L(ir_idx));
03761 
03762          ok = expr_semantics(&opnd, &exp_desc);
03763 
03764          find_opnd_line_and_column(&opnd, &line, &col);
03765 
03766          if (exp_desc.type != Logical) {
03767             PRINTMSG(line, 120, Error, col);
03768             ok = FALSE;
03769          }
03770          else if (exp_desc.rank == 0) {
03771             PRINTMSG(line, 181, Error, col);
03772             ok = FALSE;
03773          }
03774 
03775          if (where_ir_idx > 0) {
03776             /* check conformance */
03777       
03778             if (! check_where_conformance(&exp_desc)) {
03779                PRINTMSG(line, 1610, Error, col);
03780                ok = FALSE;
03781             }
03782          }
03783 
03784          sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
03785 # ifdef _DEBUG
03786          if (sh_idx == NULL_IDX) {
03787             PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
03788                      "SH_PARENT_BLK_IDX(curr_stmt_sh_idx)",
03789                      "else_stmt_semantics");
03790          }
03791 # endif
03792 
03793          if (IR_FLD_L(SH_IR_IDX(sh_idx)) == IL_Tbl_Idx &&
03794              IR_LIST_CNT_L(SH_IR_IDX(sh_idx)) == 2) {
03795 
03796             COPY_OPND(pending_mask_opnd,
03797                       IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L(SH_IR_IDX(sh_idx)))));
03798          }
03799          else {
03800             /* in error situation. */
03801             goto EXIT;
03802          }
03803 
03804          /* set up control mask */
03805          mask_expr_tmp = create_tmp_asg(&opnd, &exp_desc, &mask_expr_opnd,
03806                                         Intent_In, FALSE, TRUE);
03807          and_idx = gen_ir(OPND_FLD(pending_mask_opnd), 
03808                                        OPND_IDX(pending_mask_opnd),
03809                       And_Opr, exp_desc.type_idx, line, col,
03810                           OPND_FLD(mask_expr_opnd), OPND_IDX(mask_expr_opnd));
03811  
03812          gen_opnd(&opnd, and_idx, IR_Tbl_Idx, line, col);
03813 
03814          NTR_IR_LIST_TBL(list_idx);
03815          IR_FLD_L(ir_idx) = IL_Tbl_Idx;
03816          IR_IDX_L(ir_idx) = list_idx;
03817          IR_LIST_CNT_L(ir_idx) = 2;
03818    
03819          where_ir_idx  = OPND_IDX(opnd);
03820          COPY_OPND(IL_OPND(list_idx), opnd);
03821 
03822          /* set up new pending mask */
03823 
03824          and_idx = gen_ir(OPND_FLD(pending_mask_opnd), 
03825                                        OPND_IDX(pending_mask_opnd),
03826                       And_Opr, exp_desc.type_idx, line, col,
03827                           IR_Tbl_Idx, gen_ir(OPND_FLD(mask_expr_opnd), 
03828                                                        OPND_IDX(mask_expr_opnd),
03829                                          Not_Opr, exp_desc.type_idx, line, col,
03830                                              NO_Tbl_Idx, NULL_IDX));
03831 
03832          gen_opnd(&opnd, and_idx, IR_Tbl_Idx, line, col);
03833 
03834          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03835          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03836          list_idx = IL_NEXT_LIST_IDX(list_idx);
03837 
03838          COPY_OPND(IL_OPND(list_idx), opnd);
03839          break;
03840 
03841    }
03842 
03843 EXIT:
03844 
03845    TRACE (Func_Exit, "else_stmt_semantics", NULL);
03846 
03847    return;
03848 
03849 }  /* else_stmt_semantics */
03850 
03851 /******************************************************************************\
03852 |*                                                                            *|
03853 |* Description:                                                               *|
03854 |*      This procedure completes the processing of the FORALL statement and   *|
03855 |*      of the FORALL header portion of an FORALL construct.                  *|
03856 |*                                                                            *|
03857 |* Input parameters:                                                          *|
03858 |*      NONE                                                                  *|
03859 |*                                                                            *|
03860 |* Output parameters:                                                         *|
03861 |*      NONE                                                                  *|
03862 |*                                                                            *|
03863 |* Returns:                                                                   *|
03864 |*      NONE                                                                  *|
03865 |*                                                                            *|
03866 \******************************************************************************/
03867 
03868 void forall_semantics (void)
03869 
03870 {
03871    int                  asg_idx;
03872    int                  body_end_sh_idx;
03873    int                  body_start_sh_idx;
03874    opnd_type            br_around_opnd;
03875    int                  col;
03876    expr_arg_type        exp_desc;
03877    int                  index_idx;
03878    int                  ir_idx;
03879    int                  line;
03880    int                  list_idx;
03881    int                  list_idx2;
03882    opnd_type            l_opnd;
03883    boolean              ok = TRUE;
03884    opnd_type            opnd;
03885    int                  or_idx;
03886    int                  save_next_sh_idx;
03887    int                  tmp_idx;
03888    int                  type_idx;
03889 
03890 
03891    TRACE (Func_Entry, "forall_semantics", NULL);
03892 
03893    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
03894    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
03895 
03896    br_around_opnd = null_opnd;
03897 
03898    if (active_forall_sh_idx) {
03899       gen_forall_loops(curr_stmt_sh_idx,
03900                        IR_IDX_L(ir_idx));
03901       gen_forall_if_mask(curr_stmt_sh_idx,
03902                          IR_IDX_L(ir_idx));
03903    }
03904 
03905    active_forall_sh_idx = curr_stmt_sh_idx;
03906 
03907    /* first, go through list of indexes to catch nested reuse */
03908 
03909    list_idx = IR_IDX_R(ir_idx);
03910 
03911    while (list_idx &&
03912           IL_FLD(list_idx) == IL_Tbl_Idx) {
03913 
03914 # ifdef _DEBUG
03915       if (IL_FLD(IL_IDX(list_idx)) != AT_Tbl_Idx) {
03916          PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal, IR_COL_NUM(ir_idx),
03917                   "AT_Tbl_Idx", "forall_semantics");
03918       }
03919 # endif
03920 
03921       find_opnd_line_and_column(&(IL_OPND(IL_IDX(list_idx))), &line, &col);
03922 
03923       COPY_OPND(opnd, IL_OPND(IL_IDX(list_idx)));
03924       exp_desc.rank = 0;
03925       xref_state    = CIF_Symbol_Modification;
03926 
03927       ok &= expr_semantics(&opnd, &exp_desc);
03928 
03929       if (OPND_FLD(opnd) == IR_Tbl_Idx &&
03930           IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) {
03931          COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
03932       }
03933       COPY_OPND(IL_OPND(IL_IDX(list_idx)), opnd);
03934 
03935       if (OPND_FLD(opnd) != AT_Tbl_Idx ||
03936           exp_desc.rank != 0 ||
03937           exp_desc.type != Integer ||
03938           ATD_CLASS(OPND_IDX(opnd)) == Constant) {
03939 
03940          PRINTMSG(line, 1598, Error, col);
03941          ok = FALSE;
03942       }
03943       else {
03944          index_idx = OPND_IDX(opnd);
03945 
03946          if (ATD_FORALL_INDEX(index_idx)) {
03947 
03948          /* BHJ - need to distinguish nested reuse from same forall reuse */
03949 
03950             PRINTMSG(line, 1599, Error, col, 
03951                      AT_OBJ_NAME_PTR(index_idx));
03952             ok = FALSE;
03953          }
03954          else {
03955 
03956             tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
03957 
03958             AT_SEMANTICS_DONE(tmp_idx)= TRUE;
03959             ATD_TYPE_IDX(tmp_idx)     = ATD_TYPE_IDX(index_idx);
03960             ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03961             ATD_FORALL_INDEX(tmp_idx) = TRUE;
03962 
03963             /* change name to original name */
03964             AT_NAME_IDX(tmp_idx) = AT_NAME_IDX(index_idx);
03965             AT_NAME_LEN(tmp_idx) = AT_NAME_LEN(index_idx);
03966 
03967             AT_ATTR_LINK(index_idx)         = tmp_idx;
03968             AT_IGNORE_ATTR_LINK(index_idx)  = TRUE;
03969 
03970             ATD_TMP_NEEDS_CIF(tmp_idx) = TRUE;
03971 
03972             /* issue a usage rec if needed */
03973             if ((cif_flags & XREF_RECS) != 0) {
03974                cif_usage_rec(tmp_idx, AT_Tbl_Idx, line, col,
03975                              CIF_Symbol_Modification);
03976             }
03977          }
03978       }
03979 
03980       list_idx = IL_NEXT_LIST_IDX(list_idx);
03981    }
03982 
03983    if (! ok ) {
03984       goto EXIT;
03985    }
03986 
03987    /* process subscripts and strides */
03988 
03989    list_idx = IR_IDX_R(ir_idx);
03990 
03991    while (list_idx &&
03992           IL_FLD(list_idx) == IL_Tbl_Idx) {
03993 
03994       type_idx = ATD_TYPE_IDX(IL_IDX(IL_IDX(list_idx)));
03995 
03996       list_idx2 = IL_NEXT_LIST_IDX(IL_IDX(list_idx));
03997 
03998       while (list_idx2) {
03999          find_opnd_line_and_column(&(IL_OPND(list_idx2)), &line, &col);
04000 
04001          COPY_OPND(opnd, IL_OPND(list_idx2));
04002          exp_desc.rank = 0;
04003          xref_state    = CIF_Symbol_Reference;
04004          ok &= expr_semantics(&opnd, &exp_desc);
04005          COPY_OPND(IL_OPND(list_idx2), opnd);
04006 
04007          /* check type and rank */
04008 
04009          if (exp_desc.type != Integer ||
04010              exp_desc.rank != 0) {
04011 
04012             PRINTMSG(line, 1604, Error, col);
04013             ok = FALSE;
04014          }
04015 
04016          ok &= check_forall_triplet_for_index(&opnd);
04017 
04018          /* cast to type_idx if appropriate */
04019 
04020          if (ok) {
04021             cast_to_type_idx(&opnd, 
04022                              &exp_desc,
04023                               type_idx);
04024             COPY_OPND(IL_OPND(list_idx2), opnd);
04025          }
04026 
04027          if (ok &&
04028              OPND_FLD(opnd) != CN_Tbl_Idx) {
04029 
04030             /* capture into tmp */
04031 
04032             tmp_idx = create_tmp_asg(&opnd,
04033                                      &exp_desc,
04034                                      &l_opnd,
04035                                      Intent_In,
04036                                      FALSE,
04037                                      FALSE);
04038 
04039             COPY_OPND(IL_OPND(list_idx2), l_opnd);
04040          }
04041 
04042 
04043          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
04044       }
04045 
04046       ok &= gen_forall_max_expr(IL_NEXT_LIST_IDX(IL_IDX(list_idx)),
04047                                 &opnd);
04048 
04049       if (OPND_FLD(br_around_opnd) == NO_Tbl_Idx) {
04050          COPY_OPND(br_around_opnd, opnd);
04051       }
04052       else {
04053          or_idx = gen_ir(OPND_FLD(br_around_opnd), OPND_IDX(br_around_opnd),
04054                     Or_Opr, LOGICAL_DEFAULT_TYPE, line, col,
04055                          OPND_FLD(opnd), OPND_IDX(opnd));
04056 
04057          gen_opnd(&br_around_opnd, or_idx, IR_Tbl_Idx, line, col);
04058       }
04059   
04060 
04061       list_idx = IL_NEXT_LIST_IDX(list_idx);
04062    }
04063 
04064    if (ok) {
04065       gen_forall_branch_around(&br_around_opnd);
04066    }
04067 
04068    if (ok &&
04069        list_idx != NULL_IDX) {
04070 
04071       /* have mask */
04072 
04073       /* these capture the stmts around the loop body */
04074       /* they must be moved in after all body stmts are generated */
04075 
04076       body_start_sh_idx = curr_stmt_sh_idx;
04077       body_end_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
04078 
04079       find_opnd_line_and_column(&(IL_OPND(list_idx)), &line, &col);
04080 
04081       gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
04082 
04083       /* curr_stmt_sh_idx is an empty assignment stmt right now. */
04084 
04085       within_forall_mask_expr = TRUE;
04086       COPY_OPND(opnd, IL_OPND(list_idx));
04087       exp_desc.rank = 0;
04088       xref_state    = CIF_Symbol_Reference;
04089       io_item_must_flatten = FALSE;
04090 
04091       if (expr_semantics(&opnd, &exp_desc)) {
04092 
04093          /* do not put the transformed opnd back on the forall stmt */
04094 
04095          if (exp_desc.type != Logical ||
04096              exp_desc.rank != 0) {
04097 
04098             PRINTMSG(line, 1607, Error, col);
04099             ok = FALSE;
04100          }
04101       }
04102       else {
04103          ok = FALSE;
04104       }
04105 
04106       within_forall_mask_expr = FALSE;
04107 
04108       if (SH_PREV_IDX(curr_stmt_sh_idx) != body_start_sh_idx ||
04109           SH_NEXT_IDX(curr_stmt_sh_idx) != body_end_sh_idx ||
04110           io_item_must_flatten ||
04111           forall_mask_needs_tmp(&opnd)) {
04112 
04113          NTR_IR_TBL(asg_idx);
04114          IR_OPR(asg_idx) = Asg_Opr;
04115          IR_TYPE_IDX(asg_idx) = exp_desc.type_idx;
04116          IR_LINE_NUM(asg_idx) = line;
04117          IR_COL_NUM(asg_idx) = col;
04118 
04119          COPY_OPND(IR_OPND_R(asg_idx), opnd);
04120 
04121          SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
04122          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
04123 
04124          gen_forall_tmp(&exp_desc, &opnd, line, col, FALSE);
04125 
04126          COPY_OPND(IR_OPND_L(asg_idx), opnd);
04127 
04128          /* save the mask temp as an additional list item */
04129 
04130          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04131          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04132          list_idx = IL_NEXT_LIST_IDX(list_idx);
04133          IR_LIST_CNT_R(ir_idx) += 1;
04134 
04135          COPY_OPND(IL_OPND(list_idx), opnd);
04136    
04137          body_start_sh_idx = SH_NEXT_IDX(body_start_sh_idx);
04138          body_end_sh_idx = SH_PREV_IDX(body_end_sh_idx);
04139    
04140          gen_forall_loops(body_start_sh_idx, body_end_sh_idx);
04141       }
04142       else {
04143          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
04144          remove_sh(SH_NEXT_IDX(curr_stmt_sh_idx));
04145 
04146          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04147          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04148          list_idx = IL_NEXT_LIST_IDX(list_idx);
04149          IR_LIST_CNT_R(ir_idx) += 1;
04150 
04151          COPY_OPND(IL_OPND(list_idx), opnd);
04152       }
04153    }
04154 
04155    within_forall_construct = TRUE;
04156 
04157 EXIT:
04158 
04159    curr_stmt_sh_idx = SH_PREV_IDX(save_next_sh_idx);
04160 
04161    TRACE (Func_Exit, "forall_semantics", NULL);
04162 
04163    return;
04164 
04165 }  /* forall_semantics */
04166 
04167 /******************************************************************************\
04168 |*                                                                            *|
04169 |* Description:                                                               *|
04170 |*      Complete the processing for all user forms of the GO TO statement.    *|
04171 |*      This procedure is also called to handle the compiler-generated GO TO  *|
04172 |*      (no processing).                                                      *|
04173 |*                                                                            *|
04174 |* Input parameters:                                                          *|
04175 |*      NONE                                                                  *|
04176 |*                                                                            *|
04177 |* Output parameters:                                                         *|
04178 |*      NONE                                                                  *|
04179 |*                                                                            *|
04180 |* Returns:                                                                   *|
04181 |*      NONE                                                                  *|
04182 |*                                                                            *|
04183 |* Algorithm notes:                                                           *|
04184 |*      The semantic checks made in this routine are very similar to those    *|
04185 |*      made in assign_stmt_semantics for the ASSIGN stmt.  If you make a     *|
04186 |*      change here, chances are the same (or similar) change will need to be *|
04187 |*      made to the ASSIGN statement code.                                    *|
04188 |*                                                                            *|
04189 \******************************************************************************/
04190 
04191 void goto_stmt_semantics (void)
04192 
04193 {
04194    int                  attr_idx;
04195    int                  column;
04196    expr_arg_type        expr_desc;
04197    boolean              in_assign_stmt;
04198    int                  ir_idx;
04199    int                  lbl_idx;
04200    int                  tmp_idx;
04201    int                  line;
04202    opnd_type            opnd;
04203    opnd_type            l_opnd;
04204  
04205 
04206    TRACE (Func_Entry, "goto_stmt_semantics", NULL);
04207 
04208    if (SH_COMPILER_GEN(curr_stmt_sh_idx)) {
04209       goto EXIT;
04210    }
04211 
04212    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
04213 
04214    switch (IR_OPR(ir_idx)) {
04215    
04216       case Br_Uncond_Opr:
04217 
04218          /* If the GO TO is followed by a stmt that is not labeled, issue a   */
04219          /* warning message (at the following stmt) that the stmt can not be  */
04220          /* reached.                                                          */
04221 
04222          chk_for_unlabeled_stmt();
04223          break;
04224 
04225       case Br_Index_Opr:     /* Computed GO TO:  GO TO (lbl-list), expr       */
04226          COPY_OPND(opnd, IR_OPND_L(ir_idx));
04227          expr_desc.rank = 0;
04228          xref_state = CIF_Symbol_Reference;
04229 
04230          if (expr_semantics(&opnd, &expr_desc)) {
04231             find_opnd_line_and_column(&opnd, &line, &column);
04232             tmp_idx = create_tmp_asg(&opnd,
04233                                      &expr_desc,
04234                                      &l_opnd,
04235                                      Intent_In,
04236                                      TRUE,
04237                                      FALSE);
04238 
04239             if (expr_desc.type == Integer && expr_desc.rank == 0) {
04240                COPY_OPND(IR_OPND_L(ir_idx), l_opnd);
04241             }
04242             else {
04243                PRINTMSG(line, 369, Error, column);
04244             }
04245          } 
04246 
04247          break;
04248 
04249       case Br_Asg_Opr:       /* Assigned GO TO:  GO TO var [ [,] (lbl-list)]  */
04250 
04251          /* If the GO TO is followed by a stmt that is not labeled, issue a   */
04252          /* warning message (at the following stmt) that the stmt can not be  */
04253          /* reached.                                                          */
04254 
04255          chk_for_unlabeled_stmt();
04256 
04257          COPY_OPND(opnd, IR_OPND_L(ir_idx));
04258 
04259          /* The variable must have been assigned a label value SOMEWHERE in   */
04260          /* the CURRENT scoping unit (and that's why we have to grab the flag */
04261          /* before expr_semantics (possibly) resolves the reference to an     */
04262          /* Attr in the host).                                                */
04263 
04264          if (OPND_FLD(opnd) == AT_Tbl_Idx  &&
04265              AT_OBJ_CLASS(OPND_IDX(opnd)) == Data_Obj) {
04266             in_assign_stmt = ATD_IN_ASSIGN(OPND_IDX(opnd));
04267          }
04268 
04269          expr_desc.rank = 0;
04270          xref_state     = CIF_Symbol_Reference;
04271 
04272          if (expr_semantics(&opnd, &expr_desc)) {
04273 
04274             switch (OPND_FLD(opnd)) {
04275 
04276                case AT_Tbl_Idx:
04277                   COPY_OPND(IR_OPND_L(ir_idx), opnd);
04278                   attr_idx = IR_IDX_L(ir_idx);
04279 
04280                   /* If it's not a Data_Obj, don't do any more checking       */
04281                   /* because the variants are not valid (not allowed to       */
04282                   /* access ATD_IN_ASSIGN, for example, if AT_OBJ_CLASS is    */
04283                   /* not Data_Obj).                                           */
04284 
04285                   if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
04286 
04287                      if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) == 
04288                             INTEGER_DEFAULT_TYPE  &&
04289                          expr_desc.rank == 0) {
04290 
04291                         /* Verify that the variable was assigned a label      */
04292                         /* value SOMEWHERE in the current scoping unit.       */
04293                         /* Note that, like CFT77, CF90 does not verify that   */
04294                         /* the current value of the variable is a label nor   */
04295                         /* does it verify that the value is one of the labels */
04296                         /* in the list, if indeed the list exists.            */
04297 
04298                         if (! in_assign_stmt) {
04299                            PRINTMSG(IR_LINE_NUM_L(ir_idx), 340, Error,
04300                                     IR_COL_NUM_L(ir_idx),
04301                                     AT_OBJ_NAME_PTR(attr_idx));
04302                         }
04303 
04304                         break;
04305                      }
04306   
04307                   }
04308 
04309                   PRINTMSG(IR_LINE_NUM_L(ir_idx), 142, Error,
04310                            IR_COL_NUM_L(ir_idx), AT_OBJ_NAME_PTR(attr_idx));
04311                   break;
04312 
04313                case CN_Tbl_Idx:
04314                   find_opnd_line_and_column(&opnd, &line, &column);
04315                   PRINTMSG(line, 569, Error, column,
04316                            AT_OBJ_NAME_PTR(IR_IDX_L(ir_idx)));
04317                   break;
04318                
04319                case IR_Tbl_Idx:
04320                   /* Only case should be a Whole_Subscript IR.                */
04321                   
04322                   PRINTMSG(IR_LINE_NUM_L(ir_idx), 142, Error,
04323                            IR_COL_NUM_L(ir_idx),
04324                            AT_OBJ_NAME_PTR(IR_IDX_L(ir_idx)));
04325                   break;
04326             
04327                default:
04328                   find_opnd_line_and_column(&opnd, &line, &column);
04329                   PRINTMSG(line, 179, Internal, column,
04330                            "goto_stmt_semantics");
04331             }
04332          }
04333 
04334          /* If the label list exists, check each label to verify that it      */
04335          /* appeared in an ASSIGN statement SOMEWHERE in the current scoping  */
04336          /* unit.  CFT77 doesn't make this check so to avoid possibly irate   */
04337          /* customers, CF90 issues a warning message rather than an error     */
04338          /* message like is issued above for the variable.                    */
04339        
04340          lbl_idx = IR_IDX_R(ir_idx);
04341 
04342          while (lbl_idx != NULL_IDX) {
04343 
04344             if ( ! ATL_IN_ASSIGN(IL_IDX(lbl_idx)) ) {
04345                PRINTMSG(IL_LINE_NUM(lbl_idx), 349, Warning, IL_COL_NUM(lbl_idx),
04346                         AT_OBJ_NAME_PTR(IL_IDX(lbl_idx)));
04347             }
04348 
04349             lbl_idx = IL_NEXT_LIST_IDX(lbl_idx);
04350          }
04351 
04352          if (ATP_HAS_TASK_DIRS(SCP_ATTR_IDX(curr_scp_idx))) {
04353             /* can't have assigned goto when subprogram has cmics */
04354             PRINTMSG(stmt_start_line, 1210, Error, stmt_start_col);
04355          }
04356    }         
04357       
04358 EXIT:
04359 
04360    TRACE (Func_Exit, "goto_stmt_semantics", NULL);
04361 
04362    return;
04363 
04364 }  /* goto_stmt_semantics */
04365 
04366 
04367 /******************************************************************************\
04368 |*                                                                            *|
04369 |* Description:                                                               *|
04370 |*      This procedure completes the processing of the logical IF statement   *|
04371 |*      and of the IF-THEN portion of an IF construct.                        *|
04372 |*                                                                            *|
04373 |* Input parameters:                                                          *|
04374 |*      NONE                                                                  *|
04375 |*                                                                            *|
04376 |* Output parameters:                                                         *|
04377 |*      NONE                                                                  *|
04378 |*                                                                            *|
04379 |* Returns:                                                                   *|
04380 |*      NONE                                                                  *|
04381 |*                                                                            *|
04382 \******************************************************************************/
04383 
04384 void if_stmt_semantics (void)
04385 
04386 {
04387    opnd_type            cond_expr;
04388    int                  cond_expr_ir_idx;
04389    expr_arg_type        exp_desc;
04390    boolean              ok = TRUE;
04391    int                  sh_idx;
04392 
04393 # ifndef _HIGH_LEVEL_IF_FORM
04394    int                  il_idx_1;
04395    int                  il_idx_2;
04396    int                  ir_idx;
04397 # endif
04398 
04399 
04400    TRACE (Func_Entry, "if_stmt_semantics", NULL);
04401 
04402    /* The conditional expression must be scalar and type logical.             */
04403    
04404    cond_expr_ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
04405    COPY_OPND(cond_expr, IR_OPND_L(cond_expr_ir_idx));
04406 
04407    exp_desc.rank = 0;
04408    xref_state    = CIF_Symbol_Reference;
04409 
04410    if (! SH_COMPILER_GEN(curr_stmt_sh_idx)) {
04411       in_branch_true       = TRUE;
04412       defer_stmt_expansion = TRUE;
04413       io_item_must_flatten = FALSE;
04414       number_of_functions  = 0;
04415    }
04416 
04417    has_present_opr = FALSE;
04418    ok = expr_semantics(&cond_expr, &exp_desc);
04419    has_present_opr = FALSE;
04420 
04421    COPY_OPND(IR_OPND_L(cond_expr_ir_idx), cond_expr);
04422 
04423    defer_stmt_expansion = FALSE;
04424    in_branch_true       = FALSE;
04425 
04426    if (ok && exp_desc.rank != 0) {
04427       PRINTMSG(IR_LINE_NUM(cond_expr_ir_idx), 410, Error,
04428                IR_COL_NUM(cond_expr_ir_idx));
04429    }
04430 
04431    if (ok && exp_desc.type != Logical) {
04432       PRINTMSG(IR_LINE_NUM(cond_expr_ir_idx), 416, Error,
04433                IR_COL_NUM(cond_expr_ir_idx));
04434    } 
04435 
04436 # ifdef _HIGH_LEVEL_IF_FORM
04437 
04438    /* Reset the operator and clear the right operand (where the index   */
04439    /* to the branch-around label had been stored by the Syntax Pass).   */
04440    /* It's not needed (but is used as a flag in that pass) so it's just */
04441    /* easier to generate then and delete now.                         */
04442 
04443    IR_OPR(cond_expr_ir_idx) = If_Opr;
04444 
04445    if (SH_STMT_TYPE(curr_stmt_sh_idx) == If_Stmt) {
04446       IR_OPND_R(cond_expr_ir_idx) = null_opnd;
04447    }
04448 
04449 #endif
04450 
04451    IR_TYPE_IDX(cond_expr_ir_idx) = exp_desc.type_idx;
04452 
04453    if (SH_COMPILER_GEN(curr_stmt_sh_idx)) {
04454       COPY_OPND(IR_OPND_L(cond_expr_ir_idx), cond_expr);
04455    }
04456    else {
04457 
04458       /* If the IF is a logical IF of the form:                       */
04459       /*    IF (cond) GO TO <lbl>                                     */
04460       /* PDGCS would like the usual form:                             */
04461       /*    If_Stmt          ->  Br_True                              */
04462       /*                           Not                                */
04463       /*                             cond                             */
04464       /*                           <cg-lbl>                           */
04465       /*    Goto_Stmt        ->  Br_Uncond  Null, <user-lbl>          */
04466       /*    CG Continue_Stmt ->  Label      <cg-lbl>                  */
04467       /* simplified to:                                               */
04468       /*    If_Stmt          ->  Br_True  cond, <user-lbl>            */
04469 
04470       if ((SH_STMT_TYPE(SH_NEXT_IDX(curr_stmt_sh_idx)) == Goto_Stmt  &&
04471            IR_OPR(SH_IR_IDX(SH_NEXT_IDX(curr_stmt_sh_idx))) ==
04472              Br_Uncond_Opr)  ||
04473           SH_STMT_TYPE(SH_NEXT_IDX(curr_stmt_sh_idx)) == Cycle_Stmt  ||
04474           SH_STMT_TYPE(SH_NEXT_IDX(curr_stmt_sh_idx)) == Exit_Stmt) {
04475          COPY_OPND(IR_OPND_L(cond_expr_ir_idx), cond_expr);
04476          COPY_OPND(IR_OPND_R(cond_expr_ir_idx), 
04477                    IR_OPND_R(SH_IR_IDX(SH_NEXT_IDX(curr_stmt_sh_idx))));
04478 
04479 #ifdef _HIGH_LEVEL_IF_FORM
04480 
04481          /* Restore the operator (changed to If_Opr not far above).     */
04482 
04483          IR_OPR(cond_expr_ir_idx) = Br_True_Opr;
04484 
04485 #endif
04486 
04487          /* Link ahead to the CG End_If_Stmt SH (for high-level IF) or  */
04488          /* to the Continue_Stmt SH (for low-level IF).  Delete the     */
04489          /* SH's for the GO TO stmt and the CG End_If/Continue_Stmt.    */
04490 
04491          sh_idx = SH_NEXT_IDX(SH_NEXT_IDX(curr_stmt_sh_idx));
04492          SH_NEXT_IDX(curr_stmt_sh_idx) = SH_NEXT_IDX(sh_idx);
04493          if (SH_NEXT_IDX(curr_stmt_sh_idx)) {
04494             SH_PREV_IDX(SH_NEXT_IDX(curr_stmt_sh_idx)) = curr_stmt_sh_idx;
04495          }
04496       }
04497 
04498 # ifndef _HIGH_LEVEL_IF_FORM
04499 
04500       else {
04501         
04502          if (SH_STMT_TYPE(curr_stmt_sh_idx) == If_Cstrct_Stmt) {
04503 
04504             /* Genererate the branch-around label and save it in the    */
04505             /* first IL attached to the right operand of the If_Opr IR. */
04506             /* Generate the END IF label and save it in the second IL   */
04507             /* attached to right operand of the If_Opr IR.  The latter  */
04508             /* label's Attr entry fields are completed as a part of     */
04509             /* END IF processing.                                     */
04510 
04511             NTR_IR_LIST_TBL(il_idx_1);
04512             IR_LIST_CNT_R(cond_expr_ir_idx) = 1;
04513             IR_FLD_R(cond_expr_ir_idx)      = IL_Tbl_Idx;
04514             IR_IDX_R(cond_expr_ir_idx)      = il_idx_1;
04515 
04516             IL_LINE_NUM(il_idx_1) = stmt_start_line;
04517             IL_COL_NUM(il_idx_1)  = stmt_start_col;
04518             IL_FLD(il_idx_1)      = AT_Tbl_Idx;
04519             IL_IDX(il_idx_1)      = gen_internal_lbl(stmt_start_line);
04520 
04521             NTR_IR_LIST_TBL(il_idx_2);
04522             IR_LIST_CNT_R(cond_expr_ir_idx) = 2;
04523             IL_NEXT_LIST_IDX(il_idx_1)      = il_idx_2;
04524             IL_PREV_LIST_IDX(il_idx_2)      = il_idx_1;
04525 
04526             IL_LINE_NUM(il_idx_2) = stmt_start_line;
04527             IL_COL_NUM(il_idx_2)  = stmt_start_col;
04528             IL_FLD(il_idx_2)      = AT_Tbl_Idx;
04529             IL_IDX(il_idx_2)      = gen_internal_lbl(stmt_start_line);
04530          }
04531 
04532 
04533          /* Generate the ".NOT. cond" IR under the Br_True IR.        */
04534 
04535          NTR_IR_TBL(ir_idx);
04536          IR_FLD_L(cond_expr_ir_idx) = IR_Tbl_Idx;
04537          IR_IDX_L(cond_expr_ir_idx) = ir_idx;
04538          IR_OPR(ir_idx)             = Not_Opr;
04539          IR_TYPE_IDX(ir_idx)        = exp_desc.type_idx;
04540          IR_LINE_NUM(ir_idx)        = stmt_start_line;
04541          IR_COL_NUM(ir_idx)         = stmt_start_col;
04542          COPY_OPND(IR_OPND_L(ir_idx), cond_expr);
04543       }
04544 
04545 #endif
04546 
04547       /* short_circuit_branch calls process_deferred_functions.         */
04548 
04549 
04550 #ifdef _HIGH_LEVEL_IF_FORM
04551 
04552       if (ok) {
04553          short_circuit_high_level_if();
04554       }
04555 #else
04556 
04557       if (ok) {
04558          short_circuit_branch();
04559       }
04560 
04561 #endif
04562 
04563    }
04564 
04565    if (! ok) {
04566       SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;    /* Make sure this gets set.     */
04567    }
04568 
04569    in_branch_true       = FALSE;
04570    defer_stmt_expansion = FALSE;
04571    io_item_must_flatten = FALSE;
04572    arg_info_list_base   = NULL_IDX;
04573    arg_info_list_top    = NULL_IDX;
04574    
04575    TRACE (Func_Exit, "if_stmt_semantics", NULL);
04576 
04577    return;
04578 
04579 }  /* if_stmt_semantics */
04580 
04581 
04582 /******************************************************************************\
04583 |*                                                                            *|
04584 |* Description:                                                               *|
04585 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
04586 |*                                                                            *|
04587 |* Input parameters:                                                          *|
04588 |*      NONE                                                                  *|
04589 |*                                                                            *|
04590 |* Output parameters:                                                         *|
04591 |*      NONE                                                                  *|
04592 |*                                                                            *|
04593 |* Returns:                                                                   *|
04594 |*      NONE                                                                  *|
04595 |*                                                                            *|
04596 \******************************************************************************/
04597 
04598 void nullify_stmt_semantics (void)
04599 
04600 {
04601    int           attr_idx;
04602    int           column;
04603    int           dv_idx;
04604    expr_arg_type exp_desc;
04605    int           ir_idx;
04606    int           line;
04607    int           list_idx;
04608    opnd_type     opnd;
04609    boolean       semantically_correct = TRUE;
04610 
04611 
04612    TRACE (Func_Entry, "nullify_stmt_semantics", NULL);
04613 
04614    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
04615 
04616    list_idx = IR_IDX_L(ir_idx);
04617 
04618    while (list_idx != NULL_IDX) {
04619    
04620       if (IL_FLD(list_idx) == IR_Tbl_Idx        &&
04621           IR_OPR(IL_IDX(list_idx)) == Call_Opr) {
04622 
04623          /* catch before expr_semantics to stop bad msgs */
04624          /* error .. must be pointer */
04625 
04626          PRINTMSG(IR_LINE_NUM(IL_IDX(list_idx)), 426, Error,
04627                   IR_COL_NUM(IL_IDX(list_idx)));
04628          semantically_correct = FALSE;
04629       }
04630       else {
04631          exp_desc.rank = 0;
04632          COPY_OPND(opnd, IL_OPND(list_idx));
04633          xref_state = CIF_Symbol_Modification;
04634          semantically_correct = expr_semantics(&opnd, &exp_desc);
04635         COPY_OPND(IL_OPND(list_idx), opnd);
04636 
04637          if (!exp_desc.pointer) {
04638             find_opnd_line_and_column(&opnd, &line, &column);
04639             PRINTMSG(line, 426, Error, column);
04640             semantically_correct = FALSE;
04641          }
04642          else {
04643 
04644             if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
04645                 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
04646                find_opnd_line_and_column(&opnd, &line, &column);
04647                attr_idx = find_left_attr(&opnd);
04648 
04649                if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)) {
04650                   semantically_correct = FALSE;
04651                   PRINTMSG(line, 1270, Error, column,
04652                            AT_OBJ_NAME_PTR(attr_idx),
04653                            ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? 
04654                                     "pure":"elemental");
04655                }
04656             }
04657 
04658             while (OPND_FLD(opnd) == IR_Tbl_Idx &&
04659                    (IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr ||
04660                     IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr)) {
04661                COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
04662             }
04663 
04664             find_opnd_line_and_column(&opnd, &line, &column);
04665 
04666 # if 0 /* we don't have Dv_Deref_Opr in this version */
04667 
04668             if (OPND_FLD(opnd)         == IR_Tbl_Idx &&
04669                 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) {
04670  
04671                NTR_IR_TBL(dv_idx);
04672                IR_OPR(dv_idx)           = Dv_Set_Assoc;
04673                IR_TYPE_IDX(dv_idx)      = CG_INTEGER_DEFAULT_TYPE;
04674                IR_LINE_NUM(dv_idx)      = line;
04675                IR_COL_NUM(dv_idx)       = column;
04676 
04677                COPY_OPND(IR_OPND_L(dv_idx), IR_OPND_L(OPND_IDX(opnd)));
04678 
04679                IR_FLD_R(dv_idx)         = CN_Tbl_Idx;
04680                IR_IDX_R(dv_idx)         = CN_INTEGER_ZERO_IDX;
04681                IR_LINE_NUM_R(dv_idx)    = line;
04682                IR_COL_NUM_R(dv_idx)     = column;
04683  
04684                gen_sh(Before, Assignment_Stmt, line,
04685                       column, FALSE, FALSE, TRUE);
04686 
04687                SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))         = dv_idx;
04688                SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx))     = TRUE;
04689             }
04690             else {
04691                PRINTMSG(line, 626, Internal, column,
04692                         "Dv_Deref_Opr", "nullify_stmt_semantics");
04693             }
04694 
04695 # endif
04696 
04697          }
04698       }
04699 
04700       list_idx = IL_NEXT_LIST_IDX(list_idx);
04701    }
04702 
04703    if (semantically_correct) {
04704       /* remove nullify stmt */
04705 # if 0 /* in our version,don't remove nullify stmt-fzhao */
04706 
04707       remove_sh(curr_stmt_sh_idx);
04708       curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
04709 # endif
04710    }
04711 
04712    TRACE (Func_Exit, "nullify_stmt_semantics", NULL);
04713 
04714    return;
04715 
04716 }  /* nullify_stmt_semantics */
04717 
04718 
04719 /******************************************************************************\
04720 |*                                                                            *|
04721 |* Description:                                                               *|
04722 |*      This procedure handles the semantic processing for the outmoded       *|
04723 |*      indirect logical IF and the outmoded two-branch arithmetic IF stmts.  *|
04724 |*                                                                            *|
04725 |* Input parameters:                                                          *|
04726 |*      NONE                                                                  *|
04727 |*                                                                            *|
04728 |* Output parameters:                                                         *|
04729 |*      NONE                                                                  *|
04730 |*                                                                            *|
04731 |* Returns:                                                                   *|
04732 |*      NONE                                                                  *|
04733 |*                                                                            *|
04734 \******************************************************************************/
04735 
04736 void outmoded_if_stmt_semantics (void)
04737 
04738 {
04739 
04740    int                  br_ir_idx;
04741    int                  col;
04742    opnd_type            cond_expr;
04743    expr_arg_type        exp_desc;
04744    int                  il_idx;
04745    int                  ir_idx;
04746    int                  lbl_list_idx;
04747    int                  line;
04748 
04749 
04750    TRACE (Func_Entry, "outmoded_if_stmt_semantics", NULL);
04751 
04752    /* If the outmoded IF is followed by a stmt that is not labeled, issue     */
04753    /* a warning message (at the following stmt) that the stmt can not be      */
04754    /* reached.                                                                */
04755 
04756    chk_for_unlabeled_stmt();
04757 
04758    /* The conditional expression must be scalar.                              */
04759    /* If the expression is a numeric type, the stmt is a two-branch           */
04760    /* arithmetic IF; the numeric type must not be complex.                    */
04761    /* If the expression is type logical, the stmt is an indirect logical IF.  */
04762    /* Any other data type is an error.                                        */
04763    
04764    br_ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
04765 
04766    COPY_OPND(cond_expr, IR_OPND_L(br_ir_idx));
04767    exp_desc.rank = 0;
04768    xref_state    = CIF_Symbol_Reference;
04769 
04770    if (! expr_semantics(&cond_expr, &exp_desc)) {
04771       goto EXIT;
04772    }
04773 
04774    COPY_OPND(IR_OPND_L(br_ir_idx), cond_expr);
04775 
04776    if (exp_desc.type != Integer  &&  
04777        exp_desc.type != Real     &&  
04778        exp_desc.type != Logical  &&
04779        exp_desc.type != Typeless) {
04780       PRINTMSG(IR_LINE_NUM(br_ir_idx), 414, Error, IR_COL_NUM(br_ir_idx));
04781    } 
04782 
04783    if (exp_desc.rank != 0) {
04784       PRINTMSG(IR_LINE_NUM(br_ir_idx), 410, Error, IR_COL_NUM(br_ir_idx));
04785    }
04786 
04787    if (SH_ERR_FLG(curr_stmt_sh_idx)) {
04788       goto EXIT;
04789    }
04790 
04791    lbl_list_idx = IR_IDX_R(br_ir_idx);
04792 
04793    if (exp_desc.type == Logical) {
04794 
04795       if (cif_flags & MISC_RECS) {
04796          cif_stmt_type_rec(TRUE, 
04797                            CIF_If_Indirect_Logical_Stmt, 
04798                            statement_number);
04799       }
04800 
04801       /* Fill in the Br_True IR header fields and set the right operand to be */
04802       /* the first label.                                                     */
04803 
04804       IR_OPR(br_ir_idx)         = Br_True_Opr;
04805       IR_TYPE_IDX(br_ir_idx)    = LOGICAL_DEFAULT_TYPE;
04806       IR_LINE_NUM(br_ir_idx)    = stmt_start_line;
04807       IR_COL_NUM(br_ir_idx)     = stmt_start_col;
04808 
04809       COPY_OPND(IR_OPND_R(br_ir_idx), IL_OPND(IL_NEXT_LIST_IDX(lbl_list_idx)));
04810       FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(lbl_list_idx));
04811 
04812       /* Generate    Goto_Stmt ---> Br_Uncond                                 */
04813       /*                              Left:  null                             */
04814       /*                              Right: label 2                          */
04815 
04816       gen_sh(After, Goto_Stmt, stmt_start_line, stmt_start_col,
04817              FALSE, FALSE, TRUE);
04818 
04819       NTR_IR_TBL(ir_idx);
04820       SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
04821       IR_OPR(ir_idx)              = Br_Uncond_Opr;
04822       IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
04823       IR_LINE_NUM(ir_idx)         = stmt_start_line;
04824       IR_COL_NUM(ir_idx)          = stmt_start_col;
04825 
04826       COPY_OPND(IR_OPND_R(ir_idx), IL_OPND(lbl_list_idx));
04827       FREE_IR_LIST_NODE(lbl_list_idx);
04828    }
04829    else {
04830 
04831       if (cif_flags & MISC_RECS) {
04832          cif_stmt_type_rec(TRUE, 
04833                            CIF_If_Two_Branch_Arithmetic_Stmt,
04834                            statement_number);
04835       }
04836  
04837       /* CRI extension:  The "type" of the expression may be typeless.     */
04838       /* PDGCS treats the expression (result) as an integer.               */
04839       /* If the expression is a typeless constant that is longer than a    */
04840       /* word, truncate it and reenter it as an integer.                   */
04841 
04842       if (exp_desc.linear_type == Long_Typeless) {
04843          IR_IDX_L(br_ir_idx) = ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE,
04844                                              FALSE,
04845                                              &CN_CONST(IR_IDX_L(br_ir_idx)));
04846       }
04847       else if (exp_desc.linear_type == Short_Typeless_Const) {
04848          find_opnd_line_and_column(&(IR_OPND_L(br_ir_idx)), &line, &col);
04849          IR_IDX_L(br_ir_idx) = cast_typeless_constant(IR_IDX_L(br_ir_idx),
04850                                                       INTEGER_DEFAULT_TYPE,
04851                                                       line,
04852                                                       col);
04853          exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
04854          exp_desc.type_idx    = INTEGER_DEFAULT_TYPE;
04855          exp_desc.type        = Integer;
04856       }
04857 
04858       /* Change the IR to look like a normal arithmetic IF.  Insert an IL     */
04859       /* between the two exiting ILs and copy the label operand from the     */
04860       /* second IL to the new IL.  This will make a nonzero condition jump to */
04861       /* label-1 and a zero condition jump to label-2.                        */
04862 
04863       NTR_IR_LIST_TBL(il_idx);
04864 
04865       IL_NEXT_LIST_IDX(il_idx)          = IL_NEXT_LIST_IDX(lbl_list_idx);
04866       IL_NEXT_LIST_IDX(lbl_list_idx)    = il_idx;
04867 
04868       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(il_idx)) = il_idx;
04869       IL_PREV_LIST_IDX(il_idx)                   = lbl_list_idx;
04870 
04871       COPY_OPND(IL_OPND(il_idx), IL_OPND(IL_NEXT_LIST_IDX(il_idx)));
04872 
04873       ++IR_LIST_CNT_R(br_ir_idx);
04874    }
04875 
04876 EXIT:
04877 
04878    TRACE (Func_Exit, "outmoded_if_stmt_semantics", NULL);
04879 
04880    return;
04881 
04882 }  /* outmoded_if_stmt_semantics */
04883 
04884 
04885 /******************************************************************************\
04886 |*                                                                            *|
04887 |* Description:                                                               *|
04888 |*      Do the semantic processing for a RETURN statement.                    *|
04889 |*      Verify that the expression which follows a RETURN statement is        *|
04890 |*      a scalar integer expression.                                          *|
04891 |*                                                                            *|
04892 |* Input parameters:                                                          *|
04893 |*      NONE                                                                  *|
04894 |*                                                                            *|
04895 |* Output parameters:                                                         *|
04896 |*      NONE                                                                  *|
04897 |*                                                                            *|
04898 |* Returns:                                                                   *|
04899 |*      NONE                                                                  *|
04900 |*                                                                            *|
04901 \******************************************************************************/
04902 
04903 void return_stmt_semantics (void)
04904 
04905 {
04906    int                  idx;
04907    int                  ir_idx;
04908    expr_arg_type        exp_desc;
04909    int                  new_end_idx;
04910    size_offset_type     new_size;
04911    int                  new_start_idx;
04912    opnd_type            opnd;
04913    int                  ptr;
04914    size_offset_type     result;
04915    int                  rslt_idx;
04916    boolean              semantically_correct;
04917    size_offset_type     size;
04918 
04919 
04920    TRACE (Func_Entry, "return_stmt_semantics", NULL);
04921 
04922    if (cdir_switches.parallel_region) {
04923 
04924       /* a return stmt is illegal within a parallel region */
04925 
04926       PRINTMSG(stmt_start_line, 549, Error, stmt_start_col, "RETURN");
04927    }
04928 
04929    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
04930 
04931    /* If an alternate return specifier exits. */
04932 
04933    if (IR_FLD_L(ir_idx) != NO_Tbl_Idx) {
04934       COPY_OPND(opnd, IR_OPND_L(ir_idx));
04935       exp_desc.rank             = 0;
04936       xref_state                = CIF_Symbol_Reference;
04937       semantically_correct      = expr_semantics(&opnd,
04938                                                  &exp_desc);
04939       COPY_OPND(IR_OPND_L(ir_idx), opnd);
04940 
04941       if (semantically_correct &&
04942           (exp_desc.rank != 0 || exp_desc.type != Integer)) {
04943          PRINTMSG(IR_LINE_NUM(ir_idx), 369, Error, IR_COL_NUM(ir_idx));
04944          semantically_correct = FALSE;
04945       }
04946 
04947       /* check to see if the return specifier needs to be cast to cg default */
04948       if (semantically_correct) {
04949          COPY_OPND(opnd, IR_OPND_L(ir_idx));
04950          cast_to_cg_default(&opnd, &exp_desc);
04951          COPY_OPND(IR_OPND_L(ir_idx), opnd);
04952       }
04953    }
04954 
04955    if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function) {
04956       rslt_idx = ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx));
04957 
04958       if (!ATD_IM_A_DOPE(rslt_idx) &&
04959           ATD_ARRAY_IDX(rslt_idx) == NULL_IDX &&
04960           TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) != Structure &&
04961           TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) != Character) {
04962 
04963 # ifdef _SEPARATE_FUNCTION_RETURNS
04964          if (SCP_ALT_ENTRY_CNT(curr_scp_idx) != 0 &&
04965              SCP_RETURN_LABEL(curr_scp_idx) != NULL_IDX) {
04966             /* change return to goto to multiple return code block */
04967             IR_OPR(ir_idx)   = Br_Uncond_Opr;
04968             IR_FLD_R(ir_idx) = AT_Tbl_Idx;
04969             IR_IDX_R(ir_idx) = SCP_RETURN_LABEL(curr_scp_idx);
04970             IR_LINE_NUM_R(ir_idx)  = IR_LINE_NUM(ir_idx);
04971             IR_COL_NUM_R(ir_idx)   = IR_COL_NUM(ir_idx);
04972          }
04973          else {
04974             IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
04975             IR_IDX_R(ir_idx)       = rslt_idx;
04976             IR_LINE_NUM_R(ir_idx)  = IR_LINE_NUM(ir_idx);
04977             IR_COL_NUM_R(ir_idx)   = IR_COL_NUM(ir_idx);
04978          }
04979 # else
04980 
04981          IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
04982          IR_LINE_NUM_R(ir_idx)  = IR_LINE_NUM(ir_idx);
04983          IR_COL_NUM_R(ir_idx)   = IR_COL_NUM(ir_idx);
04984 
04985          if (SCP_ENTRY_IDX(curr_scp_idx)) {
04986             idx  = SCP_ENTRY_IDX(curr_scp_idx);
04987             size = stor_bit_size_of(rslt_idx, TRUE, FALSE);
04988 
04989             /* KAY - Disallowing n$pes in alternate entry function results */
04990 
04991             while (idx != NULL_IDX) {
04992                new_size = stor_bit_size_of(ATP_RSLT_IDX(AL_ATTR_IDX(idx)),
04993                                            TRUE, 
04994                                            FALSE);
04995                
04996                size_offset_logical_calc(&new_size, &size, Gt_Opr, &result);
04997 
04998                if (THIS_IS_TRUE(result.constant, result.type_idx)) {
04999                   size          = new_size;
05000                   rslt_idx      = ATP_RSLT_IDX(AL_ATTR_IDX(idx));
05001                }
05002                idx              = AL_NEXT_IDX(idx);
05003             }
05004          }
05005          IR_IDX_R(ir_idx)       = rslt_idx;
05006 # endif
05007       }
05008       else {
05009 
05010          /* Fill in the Return_Opr so that PDGCS can check  */
05011          /* to make sure the function result is defined.    */
05012 
05013          IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
05014          IR_IDX_R(ir_idx)       = rslt_idx;
05015          IR_LINE_NUM_R(ir_idx)  = IR_LINE_NUM(ir_idx);
05016          IR_COL_NUM_R(ir_idx)   = IR_COL_NUM(ir_idx);
05017       }
05018    }
05019    else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Subroutine &&
05020             ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))         &&
05021             IR_FLD_L(ir_idx) == NO_Tbl_Idx) {
05022       /* if no alt return spec was specified, supply zero */
05023       IR_FLD_L(ir_idx) = CN_Tbl_Idx;
05024       IR_IDX_L(ir_idx) = CN_INTEGER_ZERO_IDX;
05025       IR_LINE_NUM_L(ir_idx)  = IR_LINE_NUM(ir_idx);
05026       IR_COL_NUM_L(ir_idx)   = IR_COL_NUM(ir_idx);
05027    }
05028 
05029    ptr = SCP_EXIT_IR_SH_IDX(curr_scp_idx);
05030 
05031    if (ptr) {
05032       while (SH_NEXT_IDX(ptr) != NULL_IDX) {
05033          ptr = SH_NEXT_IDX(ptr);
05034       }
05035 
05036       copy_entry_exit_sh_list(SCP_EXIT_IR_SH_IDX(curr_scp_idx), ptr,
05037                               &new_start_idx, &new_end_idx);
05038 
05039       insert_sh_chain_before(new_start_idx);
05040    }
05041 
05042    TRACE (Func_Exit, "return_stmt_semantics", NULL);
05043 
05044    return;
05045 
05046 }  /* return_stmt_semantics */
05047 
05048 
05049 /******************************************************************************\
05050 |*                                                                            *|
05051 |* Description:                                                               *|
05052 |*      Do the semantic processing for the SELECT CASE statement.             *|
05053 |*                                                                            *|
05054 |* Input parameters:                                                          *|
05055 |*      NONE                                                                  *|
05056 |*                                                                            *|
05057 |* Output parameters:                                                         *|
05058 |*      NONE                                                                  *|
05059 |*                                                                            *|
05060 |* Returns:                                                                   *|
05061 |*      NONE                                                                  *|
05062 |*                                                                            *|
05063 \******************************************************************************/
05064 
05065 void select_stmt_semantics (void)
05066 
05067 {
05068    int                  column;
05069    expr_arg_type        expr_desc;
05070    int                  ir_idx;
05071    int                  line;
05072    opnd_type            l_opnd;
05073    opnd_type            opnd;
05074    int                  save_curr_stmt_sh_idx;
05075    int                  tmp_idx;
05076    int                  unused_curr_stmt_sh_idx;
05077 
05078 
05079    TRACE (Func_Entry, "select_stmt_semantics", NULL);
05080 
05081    ir_idx = IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx));
05082    COPY_OPND(opnd, IR_OPND_L(ir_idx));
05083    expr_desc.rank = 0;
05084    xref_state     = CIF_Symbol_Reference;
05085 
05086    defer_stmt_expansion = TRUE;
05087    number_of_functions = 0;
05088 
05089    if (expr_semantics(&opnd, &expr_desc)) {
05090 
05091       /* The case-expr must be type integer, character, or logical.           */
05092 
05093       if (expr_desc.type != Integer  &&  expr_desc.type != Character  &&
05094           expr_desc.type != Logical) {
05095          find_opnd_line_and_column(&opnd, &line, &column);
05096          PRINTMSG(line, 767, Error, column);
05097       }
05098     
05099       /* The case-expr expression must be scalar.                             */
05100 
05101       if (expr_desc.rank != 0) {
05102          find_opnd_line_and_column(&opnd, &line, &column);
05103          PRINTMSG(line, 765, Error, column);
05104       }
05105 
05106       defer_stmt_expansion = FALSE;
05107 
05108       if (tree_produces_dealloc(&opnd)) {
05109          /* put expression into temp */
05110 
05111          find_opnd_line_and_column(&opnd, &line, &column);
05112          save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05113 
05114          /* first, generate an unused sh to expand the function around */
05115          gen_sh(Before, Assignment_Stmt, line,
05116                 column, FALSE, FALSE, TRUE);
05117 
05118          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05119          unused_curr_stmt_sh_idx = curr_stmt_sh_idx;
05120 
05121          process_deferred_functions(&opnd);
05122 
05123          tmp_idx = create_tmp_asg(&opnd,
05124                                   &expr_desc,
05125                                   &l_opnd,
05126                                   Intent_In,
05127                                   FALSE,
05128                                   TRUE);
05129 
05130          COPY_OPND(opnd, l_opnd);
05131 
05132          /* remove the unused sh */
05133          remove_sh(unused_curr_stmt_sh_idx);
05134          FREE_SH_NODE(unused_curr_stmt_sh_idx);
05135 
05136          if (where_dealloc_stmt_idx != NULL_IDX) {
05137 # ifdef _DEBUG
05138             if (IL_FLD(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))) != AT_Tbl_Idx  ||
05139                 AT_OBJ_CLASS(IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)))) !=
05140                                                         Label) {
05141 
05142                PRINTMSG(line, 626, Internal, column,
05143                         "label", "select_stmt_semantics");
05144             }
05145 # endif
05146              
05147             curr_stmt_sh_idx = ATL_DEF_STMT_IDX(IL_IDX(
05148                                     IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))));
05149 
05150             while (SH_STMT_TYPE(curr_stmt_sh_idx) != End_Select_Stmt) {
05151 # ifdef _DEBUG
05152                if (curr_stmt_sh_idx == NULL_IDX) {
05153                   PRINTMSG(line, 626, Internal, column,
05154                            "End_Select_Stmt", "select_stmt_semantics");
05155                }
05156 # endif
05157                curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
05158             }
05159 
05160             /* insert the where_dealloc_stmt_idx after End_Select_Stmt */
05161             insert_sh_chain(where_dealloc_stmt_idx,
05162                             where_dealloc_stmt_idx,
05163                             After);
05164 
05165             where_dealloc_stmt_idx = NULL_IDX;
05166          }
05167 
05168          curr_stmt_sh_idx           = save_curr_stmt_sh_idx;
05169       }
05170       else {
05171 
05172          process_deferred_functions(&opnd);
05173 
05174          if (expr_desc.type == Character) {
05175             validate_char_len(&opnd, &expr_desc);
05176          }
05177       }
05178    }
05179  
05180    if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
05181       COPY_OPND(IR_OPND_L(ir_idx), opnd);
05182       IR_TYPE_IDX(ir_idx) = expr_desc.type_idx;
05183    }
05184          
05185    defer_stmt_expansion = FALSE;
05186    arg_info_list_base   = NULL_IDX;
05187    arg_info_list_top    = NULL_IDX;
05188 
05189    TRACE (Func_Exit, "select_stmt_semantics", NULL);
05190 
05191    return;
05192 
05193 }  /* select_stmt_semantics */
05194 
05195 
05196 /******************************************************************************\
05197 |*                                                                            *|
05198 |* Description:                                                               *|
05199 |*      Do all semantic processing for STOP/PAUSE.  A Return_Opr will be      *|
05200 |*      generated following the call to $STOP.  Calls will be generated in    *|
05201 |*      the IR to $STOP/$PAUSE.                                               *|
05202 |*                                                                            *|
05203 |* Input parameters:                                                          *|
05204 |*      NONE                                                                  *|
05205 |*                                                                            *|
05206 |* Output parameters:                                                         *|
05207 |*      NONE                                                                  *|
05208 |*                                                                            *|
05209 |* Returns:                                                                   *|
05210 |*      NONE                                                                  *|
05211 |*                                                                            *|
05212 \******************************************************************************/
05213 
05214 void stop_pause_stmt_semantics (void)
05215 
05216 {
05217    int                  attr_idx;
05218    expr_arg_type        exp_desc;
05219    int                  ir_idx;
05220    boolean              is_call;
05221    int                  list_idx;
05222    opnd_type            opnd;
05223    int                  save_arg_info_list_base;
05224    boolean              semantically_correct            = TRUE; 
05225    char                 str[16];
05226    int                  type_idx;
05227 
05228 
05229    TRACE (Func_Entry, "stop_pause_stmt_semantics", NULL);
05230 
05231    /* do memory management stuff to make sure the call tables are big enough */
05232 
05233    if (max_call_list_size >= arg_list_size) {
05234       enlarge_call_list_tables();
05235    }
05236 
05237    save_arg_info_list_base = arg_info_list_base;
05238    arg_info_list_base      = arg_info_list_top;
05239    arg_info_list_top       = arg_info_list_base + 1;
05240 
05241    if (arg_info_list_top >= arg_info_list_size) {
05242       enlarge_info_list_table();
05243    }
05244 
05245    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
05246 
05247    if (IR_OPR(ir_idx) == Pause_Opr) {
05248 
05249       if (glb_tbl_idx[Pause_Attr_Idx] == NULL_IDX) {
05250          glb_tbl_idx[Pause_Attr_Idx] = create_lib_entry_attr(PAUSE_LIB_ENTRY,
05251                                                             PAUSE_NAME_LEN,
05252                                                             IR_LINE_NUM(ir_idx),
05253                                                             IR_COL_NUM(ir_idx));
05254       }
05255 
05256       attr_idx  = glb_tbl_idx[Pause_Attr_Idx];
05257 
05258       ADD_ATTR_TO_LOCAL_LIST(attr_idx);
05259       
05260       NTR_IR_LIST_TBL(list_idx);
05261       IL_ARG_DESC_VARIANT(list_idx)= TRUE;
05262       IL_FLD(list_idx)          = IR_FLD_L(ir_idx);
05263       IL_IDX(list_idx)          = IR_IDX_L(ir_idx);
05264       IL_COL_NUM(list_idx)      = IR_COL_NUM(ir_idx);
05265       IL_LINE_NUM(list_idx)     = IR_LINE_NUM(ir_idx);  
05266 
05267       IR_FLD_R(ir_idx)          = IL_Tbl_Idx;
05268       IR_IDX_R(ir_idx)          = list_idx;
05269       IR_LIST_CNT_R(ir_idx)     = 1;
05270 
05271       is_call = TRUE;
05272    }
05273    else {
05274 
05275       if (glb_tbl_idx[Stop_Attr_Idx] == NULL_IDX) {
05276 # ifdef _TARGET_OS_MAX
05277          if (cmd_line_flags.co_array_fortran) {
05278             glb_tbl_idx[Stop_Attr_Idx] = create_lib_entry_attr(
05279                                                            STOP_ALL_LIB_ENTRY,
05280                                                            STOP_ALL_NAME_LEN,
05281                                                            IR_LINE_NUM(ir_idx),
05282                                                            IR_COL_NUM(ir_idx));
05283          }
05284          else {
05285             glb_tbl_idx[Stop_Attr_Idx] = create_lib_entry_attr(STOP_LIB_ENTRY,
05286                                                                STOP_NAME_LEN,
05287                                                            IR_LINE_NUM(ir_idx),
05288                                                            IR_COL_NUM(ir_idx));
05289          }
05290 # else
05291          glb_tbl_idx[Stop_Attr_Idx] = create_lib_entry_attr(STOP_LIB_ENTRY,
05292                                                             STOP_NAME_LEN,
05293                                                         IR_LINE_NUM(ir_idx),
05294                                                         IR_COL_NUM(ir_idx));
05295 # endif
05296          ATP_NOSIDE_EFFECTS(glb_tbl_idx[Stop_Attr_Idx])     = TRUE;
05297          ATP_DOES_NOT_RETURN(glb_tbl_idx[Stop_Attr_Idx])     = TRUE;
05298       }
05299 
05300       attr_idx  = glb_tbl_idx[Stop_Attr_Idx];
05301 
05302 # ifdef _STOP_IS_OPR
05303       is_call = FALSE;
05304 # else
05305       ADD_ATTR_TO_LOCAL_LIST(attr_idx);
05306       is_call = TRUE;
05307 # endif
05308       
05309       NTR_IR_LIST_TBL(list_idx);
05310       IL_ARG_DESC_VARIANT(list_idx)= TRUE;
05311       IL_FLD(list_idx)          = IR_FLD_L(ir_idx);
05312       IL_IDX(list_idx)          = IR_IDX_L(ir_idx);
05313       IL_COL_NUM(list_idx)      = IR_COL_NUM(ir_idx);
05314       IL_LINE_NUM(list_idx)     = IR_LINE_NUM(ir_idx);  
05315 
05316       IR_FLD_R(ir_idx)          = IL_Tbl_Idx;
05317       IR_IDX_R(ir_idx)          = list_idx;
05318       IR_LIST_CNT_R(ir_idx)     = 1;
05319 
05320    }
05321 
05322    /* If stop_code exits. */
05323 
05324    if (IL_FLD(list_idx) != NO_Tbl_Idx) {
05325 
05326       switch (IL_FLD(list_idx)) {
05327 
05328       case AT_Tbl_Idx :                 /* we have a stand alone identifier */
05329          COPY_OPND(opnd, IL_OPND(list_idx));
05330          exp_desc.rank          = 0;
05331          xref_state             = CIF_Symbol_Reference;
05332          semantically_correct   = expr_semantics(&opnd,
05333                                                  &exp_desc);
05334          COPY_OPND(IL_OPND(list_idx), opnd);
05335 
05336          arg_info_list[arg_info_list_base + 1]                  = init_arg_info;
05337          arg_info_list[arg_info_list_base + 1].ed               = exp_desc;
05338          arg_info_list[arg_info_list_base + 1].maybe_modified   = FALSE;
05339 
05340          if (!AT_DCL_ERR(IR_IDX_L(ir_idx))) {
05341 
05342             if (exp_desc.type != Character || exp_desc.rank != 0) {
05343                PRINTMSG(IR_LINE_NUM(ir_idx), 386, Error, IR_COL_NUM(ir_idx));
05344                semantically_correct = FALSE;
05345             }
05346             else if (! exp_desc.constant) {
05347                PRINTMSG(IR_LINE_NUM(ir_idx), 385, Ansi, IR_COL_NUM(ir_idx));
05348             }
05349          }
05350          break;
05351 
05352 
05353       case CN_Tbl_Idx :  /* we have a scalar constant */
05354 
05355          if (TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) != Integer &&
05356              TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) != Character) {
05357            PRINTMSG(IR_LINE_NUM(ir_idx), 386, Error, IR_COL_NUM(ir_idx));
05358            semantically_correct = FALSE;
05359          }
05360 
05361          if (TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Integer) {
05362 
05363             if (compare_cn_and_value(IL_IDX(list_idx), 0, Lt_Opr) ||
05364                 compare_cn_and_value(IL_IDX(list_idx), 99999, Gt_Opr)) {
05365 
05366                PRINTMSG(IR_LINE_NUM(ir_idx), 385, Ansi, IR_COL_NUM(ir_idx));
05367             }
05368        
05369             /* Convert the integer value to a character constant. */ 
05370 
05371             convert_to_string(&CN_CONST(IL_IDX(list_idx)),
05372                                CN_TYPE_IDX(IL_IDX(list_idx)),
05373                                str);
05374 
05375             CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
05376 
05377             TYP_TYPE(TYP_WORK_IDX)      = Character;
05378             TYP_LINEAR(TYP_WORK_IDX)    = CHARACTER_DEFAULT_TYPE;
05379             TYP_CHAR_CLASS(TYP_WORK_IDX)= Const_Len_Char;
05380             TYP_FLD(TYP_WORK_IDX)       = CN_Tbl_Idx;
05381             TYP_IDX(TYP_WORK_IDX)       = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
05382                                                       strlen(str));
05383             type_idx                    = ntr_type_tbl();
05384             IL_IDX(list_idx)            = ntr_const_tbl(type_idx, 
05385                                                         TRUE,
05386                                                         (long_type *) str);
05387          }
05388 
05389          arg_info_list[arg_info_list_base + 1]                  = init_arg_info;
05390          arg_info_list[arg_info_list_base + 1].ed.type_idx      = 
05391                                                CN_TYPE_IDX(IL_IDX(list_idx)); 
05392          arg_info_list[arg_info_list_base + 1].ed.type          = Character;
05393          arg_info_list[arg_info_list_base + 1].ed.linear_type   = Character_1;
05394          arg_info_list[arg_info_list_base + 1].ed.char_len.fld  = 
05395                     TYP_FLD(CN_TYPE_IDX(IL_IDX(list_idx)));
05396          arg_info_list[arg_info_list_base + 1].ed.char_len.idx  = 
05397                     TYP_IDX(CN_TYPE_IDX(IL_IDX(list_idx)));
05398          arg_info_list[arg_info_list_base + 1].ed.constant      = TRUE;
05399          arg_info_list[arg_info_list_base + 1].maybe_modified   = FALSE;
05400          break;
05401 
05402 
05403       case IR_Tbl_Idx :  /* we have an expression tree */
05404          COPY_OPND(opnd, IL_OPND(list_idx));
05405          exp_desc.rank          = 0;
05406          xref_state             = CIF_Symbol_Reference;
05407          semantically_correct   = expr_semantics(&opnd,
05408                                                  &exp_desc);
05409          COPY_OPND(IL_OPND(list_idx), opnd);
05410 
05411          if (semantically_correct) {
05412 
05413             if (exp_desc.rank != 0 || exp_desc.type != Character) {
05414                PRINTMSG(IR_LINE_NUM(ir_idx), 386, Error, IR_COL_NUM(ir_idx));
05415                semantically_correct = FALSE;
05416             }
05417             else if (exp_desc.type == Character) {
05418                PRINTMSG(IR_LINE_NUM(ir_idx), 385, Ansi, IR_COL_NUM(ir_idx));
05419             }
05420          }
05421 
05422          arg_info_list[arg_info_list_base + 1]                  = init_arg_info;
05423          arg_info_list[arg_info_list_base + 1].ed               = exp_desc;
05424          arg_info_list[arg_info_list_base + 1].maybe_modified   = FALSE;
05425          break;
05426 
05427 
05428       default :
05429          PRINTMSG(IR_LINE_NUM(ir_idx), 386, Error, IR_COL_NUM(ir_idx));
05430          semantically_correct = FALSE;
05431          break;
05432       }
05433    }
05434    else {  /* no stop code exits - pass a blank */
05435       
05436 # if defined(GENERATE_WHIRL)
05437       /* send a zero length string on irix */
05438 
05439       CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
05440       TYP_TYPE(TYP_WORK_IDX)    = Character;
05441       TYP_LINEAR(TYP_WORK_IDX)  = CHARACTER_DEFAULT_TYPE;
05442       TYP_DESC(TYP_WORK_IDX)    = Default_Typed;
05443       TYP_CHAR_CLASS(TYP_WORK_IDX)= Const_Len_Char;
05444       TYP_FLD(TYP_WORK_IDX)     = CN_Tbl_Idx;
05445       TYP_IDX(TYP_WORK_IDX)     = CN_INTEGER_ZERO_IDX;
05446       type_idx                  = ntr_type_tbl();
05447 
05448       IL_FLD(list_idx)                  = CN_Tbl_Idx;
05449       IL_IDX(list_idx)                  = ntr_const_tbl(type_idx,
05450                                                         FALSE,
05451                                                         NULL);
05452       IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx);
05453       IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx);
05454 
05455       arg_info_list[arg_info_list_base + 1]                 = init_arg_info;
05456       arg_info_list[arg_info_list_base + 1].ed.type_idx     = type_idx;
05457       arg_info_list[arg_info_list_base + 1].ed.type         = Character;
05458       arg_info_list[arg_info_list_base + 1].ed.char_len.fld =
05459                     TYP_FLD(CN_TYPE_IDX(IL_IDX(list_idx)));
05460       arg_info_list[arg_info_list_base + 1].ed.char_len.idx =
05461                     TYP_IDX(CN_TYPE_IDX(IL_IDX(list_idx)));
05462       arg_info_list[arg_info_list_base + 1].ed.linear_type  = Character_1;
05463       arg_info_list[arg_info_list_base + 1].ed.constant     = TRUE;
05464       arg_info_list[arg_info_list_base + 1].maybe_modified  = FALSE;
05465 
05466 # else
05467       str[0] = ' ';
05468       str[1] = '\0';
05469 
05470       IL_FLD(list_idx)                  = CN_Tbl_Idx;
05471       IL_IDX(list_idx)                  = ntr_const_tbl(CHARACTER_DEFAULT_TYPE,
05472                                                         FALSE,
05473                                                         (long_type *) str);
05474       IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx);
05475       IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx);
05476 
05477       arg_info_list[arg_info_list_base + 1]                     = init_arg_info;
05478       arg_info_list[arg_info_list_base + 1].ed.type_idx= CHARACTER_DEFAULT_TYPE;
05479       arg_info_list[arg_info_list_base + 1].ed.type             = Character;
05480       arg_info_list[arg_info_list_base + 1].ed.char_len.fld  = 
05481                     TYP_FLD(CN_TYPE_IDX(IL_IDX(list_idx)));
05482       arg_info_list[arg_info_list_base + 1].ed.char_len.idx  = 
05483                     TYP_IDX(CN_TYPE_IDX(IL_IDX(list_idx)));
05484       arg_info_list[arg_info_list_base + 1].ed.linear_type      = Character_1;
05485       arg_info_list[arg_info_list_base + 1].ed.constant         = TRUE;
05486       arg_info_list[arg_info_list_base + 1].maybe_modified      = FALSE;
05487 # endif
05488    }
05489 
05490    IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
05491 
05492    if (is_call) {
05493       IR_FLD_L(ir_idx) = AT_Tbl_Idx;
05494       IR_IDX_L(ir_idx) = attr_idx;
05495       IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx);
05496       IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx);
05497       IR_OPR(ir_idx)   = Call_Opr;
05498    }
05499 
05500    if (semantically_correct) {
05501       arg_list[1]               = list_idx;
05502       IL_ARG_DESC_IDX(list_idx) = arg_info_list_base + 1;
05503 
05504       COPY_OPND(opnd, IR_OPND_R(ir_idx));
05505       semantically_correct = final_arg_work(&opnd, attr_idx, 1, NULL) &&
05506                              semantically_correct;
05507       COPY_OPND(IR_OPND_R(ir_idx), opnd);
05508    }
05509 
05510    /* restore arg_info_list to previous "stack frame" */
05511 
05512    arg_info_list_top  = arg_info_list_base;
05513    arg_info_list_base = save_arg_info_list_base;
05514 
05515    TRACE (Func_Exit, "stop_pause_stmt_semantics", NULL);
05516 
05517    return;
05518 
05519 }  /* stop_pause_stmt_semantics */
05520 
05521 
05522 /******************************************************************************\
05523 |*                                                                            *|
05524 |* Description:                                                               *|
05525 |*      This function removes the Then_Stmt SH because it was only needed by  *|
05526 |*      the Syntax Pass and the PDGCS interface doesn't want to see it.       *|
05527 |*                                                                            *|
05528 |* Input parameters:                                                          *|
05529 |*      NONE                                                                  *|
05530 |*                                                                            *|
05531 |* Output parameters:                                                         *|
05532 |*      NONE                                                                  *|
05533 |*                                                                            *|
05534 |* Returns:                                                                   *|
05535 |*      NONE                                                                  *|
05536 |*                                                                            *|
05537 \******************************************************************************/
05538 
05539 void then_stmt_semantics (void)
05540 
05541 {
05542    int  then_idx;
05543 
05544 
05545    TRACE (Func_Entry, "then_stmt_semantics", NULL);
05546 
05547    then_idx                           = curr_stmt_sh_idx;
05548    curr_stmt_sh_idx                   = SH_PREV_IDX(then_idx);
05549    remove_sh(then_idx);
05550    FREE_SH_NODE(then_idx);
05551 
05552    TRACE (Func_Exit, "then_stmt_semantics", NULL);
05553 
05554    return;
05555 
05556 }  /* then_stmt_semantics */
05557 
05558 
05559 /******************************************************************************\
05560 |*                                                                            *|
05561 |* Description:                                                               *|
05562 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
05563 |*                                                                            *|
05564 |* Input parameters:                                                          *|
05565 |*      NONE                                                                  *|
05566 |*                                                                            *|
05567 |* Output parameters:                                                         *|
05568 |*      NONE                                                                  *|
05569 |*                                                                            *|
05570 |* Returns:                                                                   *|
05571 |*      NONE                                                                  *|
05572 |*                                                                            *|
05573 \******************************************************************************/
05574 
05575 void where_stmt_semantics (void)
05576 
05577 {
05578    int                  and_idx;
05579    int                  col;
05580    boolean              clear_alloc_block = FALSE;
05581    expr_arg_type        exp_desc;
05582    int                  ir_idx;
05583    int                  line;
05584    int                  list_idx;
05585    opnd_type            mask_expr_opnd;
05586    int                  mask_expr_tmp;
05587    boolean              ok              = TRUE;
05588    opnd_type            opnd;
05589    int                  save_active_forall_sh_idx;
05590    int                  save_where_ir_idx;
05591    int                  sh_idx;
05592 
05593 
05594    TRACE (Func_Entry, "where_stmt_semantics", NULL);
05595 
05596    ir_idx               = SH_IR_IDX(curr_stmt_sh_idx);
05597 
05598    if (active_forall_sh_idx) {
05599 
05600       if (IR_OPR(ir_idx) == Where_Cnstrct_Opr) {
05601          gen_forall_loops(curr_stmt_sh_idx,
05602                           IR_IDX_R(ir_idx));
05603          gen_forall_if_mask(curr_stmt_sh_idx,
05604                             IR_IDX_R(ir_idx));
05605 
05606          SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = active_forall_sh_idx;
05607          active_forall_sh_idx = NULL_IDX;
05608       }
05609       else {
05610          /* WHERE stmt. */
05611          gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx);
05612          gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx);
05613       }
05614    }
05615 
05616    exp_desc.rank        = 0;
05617    xref_state           = CIF_Symbol_Reference;
05618 
05619    COPY_OPND(opnd, IR_OPND_L(ir_idx));
05620 
05621    ok = expr_semantics(&opnd, &exp_desc);
05622 
05623    find_opnd_line_and_column(&opnd, &line, &col);
05624 
05625    if (exp_desc.type != Logical) {
05626       PRINTMSG(line, 120, Error, col);
05627       ok = FALSE;
05628    }
05629    else if (exp_desc.rank == 0) {
05630       PRINTMSG(line, 181, Error, col);
05631       ok = FALSE;
05632    }
05633 
05634    if (where_ir_idx > 0) {
05635       /* check conformance */
05636 
05637       if (! check_where_conformance(&exp_desc)) {
05638          PRINTMSG(line, 1610, Error, col);
05639          ok = FALSE;
05640       }
05641    }
05642 
05643    if (!ok) {
05644       if (stmt_type != Where_Stmt) {
05645          where_ir_idx = -1;
05646       }
05647       goto EXIT;
05648    }
05649 
05650    if (SH_PARENT_BLK_IDX(curr_stmt_sh_idx) == NULL_IDX ||
05651        (SH_STMT_TYPE(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))!=Where_Cstrct_Stmt &&
05652         SH_STMT_TYPE(SH_PARENT_BLK_IDX(curr_stmt_sh_idx)) != Else_Where_Stmt &&
05653         SH_STMT_TYPE(SH_PARENT_BLK_IDX(curr_stmt_sh_idx)) != 
05654                                                   Else_Where_Mask_Stmt)) {
05655 
05656       /* this is the outer WHERE construct */
05657 # ifdef _DEBUG
05658       if (alloc_block_start_idx != NULL_IDX ||
05659           alloc_block_end_idx != NULL_IDX) {
05660          PRINTMSG(line, 626, Internal, col,
05661                   "alloc_block_start_idx == NULL_IDX",
05662                   "where_stmt_semantics");
05663       }
05664 # endif
05665 
05666       if (stmt_type != Where_Stmt)  {
05667 
05668          if (IR_FLD_R(ir_idx) == SH_Tbl_Idx &&
05669              ! SH_ERR_FLG(IR_IDX_R(ir_idx))) {
05670 
05671             alloc_block_start_idx = curr_stmt_sh_idx;
05672             alloc_block_end_idx = IR_IDX_R(ir_idx);
05673          }
05674       }
05675       else {
05676          alloc_block_start_idx = curr_stmt_sh_idx;
05677          alloc_block_end_idx = curr_stmt_sh_idx;
05678          clear_alloc_block = TRUE;
05679       }
05680    }
05681 
05682    if (stmt_type == Where_Stmt) {
05683 
05684       save_active_forall_sh_idx = active_forall_sh_idx;
05685       active_forall_sh_idx = NULL_IDX;
05686 
05687       save_where_ir_idx = where_ir_idx;
05688 
05689 # if 0 /*fzhao */
05690       mask_expr_tmp = create_tmp_asg(&opnd, &exp_desc, &mask_expr_opnd,
05691                                  Intent_In, FALSE, TRUE);
05692       if (where_ir_idx > 0) {
05693          and_idx = gen_ir(IR_Tbl_Idx, where_ir_idx,
05694                      And_Opr, exp_desc.type_idx, line, col,
05695                           OPND_FLD(mask_expr_opnd), OPND_IDX(mask_expr_opnd));
05696 #endif
05697       if (where_ir_idx > 0) {
05698          and_idx = gen_ir(IR_Tbl_Idx, where_ir_idx,
05699                      And_Opr, exp_desc.type_idx, line, col,
05700                           OPND_FLD(opnd), OPND_IDX(opnd));
05701 
05702 
05703          gen_opnd(&opnd, and_idx, IR_Tbl_Idx, line, col);
05704       }
05705       else {
05706 
05707 # if 0 /*fzhao  */
05708          COPY_OPND(opnd, mask_expr_opnd);
05709 # endif 
05710            ;
05711       }
05712 
05713       /* Check the next statement.  If it is a statement number statement */
05714       /* use it to set statement_number so that assignment statement gens */
05715       /* the correct statement number for CIF.  Remove the statement.     */
05716 
05717       if (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX &&
05718           SH_STMT_TYPE(SH_NEXT_IDX(curr_stmt_sh_idx)) == Statement_Num_Stmt &&
05719           SH_IR_IDX(SH_NEXT_IDX(curr_stmt_sh_idx)) == NULL_IDX) {
05720          sh_idx                                 = SH_NEXT_IDX(curr_stmt_sh_idx);
05721          stmt_end_line                          = SH_GLB_LINE(sh_idx);
05722          stmt_end_col                           = SH_COL_NUM(sh_idx);
05723          statement_number                       = SH_PARENT_BLK_IDX(sh_idx);
05724          SH_NEXT_IDX(curr_stmt_sh_idx)          = SH_NEXT_IDX(sh_idx);
05725          SH_PREV_IDX(SH_NEXT_IDX(sh_idx))       = curr_stmt_sh_idx;
05726          FREE_SH_NODE(sh_idx);
05727       }
05728 
05729       where_ir_idx  = OPND_IDX(opnd);
05730 
05731       /* need to remove the where operator and make this look */
05732       /* like assignment.                                     */
05733 
05734       SH_STMT_TYPE(curr_stmt_sh_idx) = Assignment_Stmt;
05735       stmt_type                      = Assignment_Stmt;
05736 
05737       find_opnd_line_and_column((opnd_type *) &IR_OPND_R(ir_idx), 
05738                                 &stmt_start_line, 
05739                                 &stmt_start_col);
05740 
05741       SH_IR_IDX(curr_stmt_sh_idx)    = IR_IDX_R(ir_idx);
05742 
05743       (*stmt_semantics[stmt_type])();
05744 
05745       if (clear_alloc_block) {
05746          alloc_block_start_idx = NULL_IDX;
05747          alloc_block_end_idx = NULL_IDX;
05748       }
05749 
05750       where_ir_idx = save_where_ir_idx;
05751 
05752       active_forall_sh_idx = save_active_forall_sh_idx;
05753    }
05754    else {
05755 
05756       /* set up control mask */
05757 
05758 # if 0 /*fzhao */
05759       mask_expr_tmp = create_tmp_asg(&opnd, &exp_desc, &mask_expr_opnd, 
05760                                      Intent_In, FALSE, TRUE);
05761 
05762       if (where_ir_idx > 0) {
05763          and_idx = gen_ir(IR_Tbl_Idx, where_ir_idx,
05764                       And_Opr, exp_desc.type_idx, line, col,
05765                           OPND_FLD(mask_expr_opnd), OPND_IDX(mask_expr_opnd));
05766 
05767          gen_opnd(&opnd, and_idx, IR_Tbl_Idx, line, col);
05768       }
05769       else {
05770          COPY_OPND(opnd, mask_expr_opnd);
05771       }
05772 # endif
05773       if (where_ir_idx > 0) {
05774          and_idx = gen_ir(IR_Tbl_Idx, where_ir_idx,
05775                       And_Opr, exp_desc.type_idx, line, col,
05776                           OPND_FLD(opnd), OPND_IDX(opnd));
05777 
05778          gen_opnd(&opnd, and_idx, IR_Tbl_Idx, line, col);
05779       }
05780 
05781 
05782       NTR_IR_LIST_TBL(list_idx);
05783       IR_FLD_L(ir_idx) = IL_Tbl_Idx;
05784       IR_IDX_L(ir_idx) = list_idx;
05785       IR_LIST_CNT_L(ir_idx) = 2;
05786 
05787       COPY_OPND(IL_OPND(list_idx), opnd);
05788 
05789       /* set up pending mask */
05790 # if 0 /*fzhao */
05791       gen_opnd(&opnd, 
05792                gen_ir(OPND_FLD(mask_expr_opnd), OPND_IDX(mask_expr_opnd),
05793                   Not_Opr, exp_desc.type_idx, line, col,
05794                       NO_Tbl_Idx, NULL_IDX),
05795                IR_Tbl_Idx,
05796                line,
05797                col);
05798 # endif
05799       gen_opnd(&opnd,
05800                gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
05801                   Not_Opr, exp_desc.type_idx, line, col,
05802                       NO_Tbl_Idx, NULL_IDX),
05803                IR_Tbl_Idx,
05804                line,
05805                col);
05806 
05807 
05808 
05809       if (where_ir_idx > 0) {
05810          and_idx = gen_ir(IR_Tbl_Idx, where_ir_idx,
05811                       And_Opr, exp_desc.type_idx, line, col,
05812                           OPND_FLD(opnd), OPND_IDX(opnd));
05813 
05814          gen_opnd(&opnd, and_idx, IR_Tbl_Idx, line, col);
05815       }
05816 
05817       /* do not change where_ir_idx until the pending mask tree is created */
05818 
05819       where_ir_idx  = IL_IDX(list_idx);
05820 
05821       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
05822       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
05823       list_idx = IL_NEXT_LIST_IDX(list_idx);
05824 
05825       COPY_OPND(IL_OPND(list_idx), opnd);
05826    }
05827 
05828 EXIT:
05829    
05830    TRACE (Func_Exit, "where_stmt_semantics", NULL);
05831    
05832    return;
05833 
05834 }  /* where_stmt_semantics */
05835 
05836 
05837 /******************************************************************************\
05838 |*                                                                            *|
05839 |* Description:                                                               *|
05840 |*      This procedure should be called by the semantics routine for any      *|
05841 |*      statement that makes an unconditional branch (such as an              *|
05842 |*      unconditional GO TO, an arithmetic IF, etc.) or that stops program    *|
05843 |*      execution (such as the STOP statement).  It issues a warning message  *|
05844 |*      (on the following statement) if the following statement is not        *|
05845 |*      labeled (control can not reach it).                                   *|
05846 |*                                                                            *|
05847 |* Input parameters:                                                          *|
05848 |*      NONE                                                                  *|
05849 |*                                                                            *|
05850 |* Output parameters:                                                         *|
05851 |*      NONE                                                                  *|
05852 |*                                                                            *|
05853 |* Returns:                                                                   *|
05854 |*      NONE                                                                  *|
05855 |*                                                                            *|
05856 \******************************************************************************/
05857 
05858 static void chk_for_unlabeled_stmt (void)
05859 
05860 {
05861    int          sh_idx;
05862  
05863 
05864    TRACE (Func_Entry, "chk_for_unlabeled_stmt", NULL);
05865 
05866    /* Do not issue the message if the unconditional branching stmt is the     */
05867    /* action-stmt of a logical IF.                                            */
05868 
05869 
05870    if (! SH_ACTION_STMT(curr_stmt_sh_idx)) {
05871       sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
05872 
05873       while (SH_COMPILER_GEN(sh_idx)) {
05874          sh_idx = SH_NEXT_IDX(sh_idx);
05875       }
05876              
05877       if (SH_STMT_TYPE(sh_idx) != Label_Def) {
05878 
05879          switch (SH_STMT_TYPE(sh_idx))
05880          {
05881             case Null_Stmt:
05882             case Contains_Stmt:
05883             case Data_Stmt:
05884             case Directive_Stmt:
05885             case End_Do_Stmt:
05886             case End_Function_Stmt:
05887             case End_If_Stmt:
05888             case End_Program_Stmt:
05889             case End_Select_Stmt:
05890             case End_Stmt:
05891             case End_Subroutine_Stmt:
05892             case Case_Stmt:
05893             case Else_Stmt:
05894             case Else_If_Stmt:
05895             case Entry_Stmt:
05896             case End_Parallel_Stmt:
05897             case End_Do_Parallel_Stmt:
05898             case End_Parallel_Case_Stmt:
05899             case Parallel_Case_Stmt:
05900             case End_Guard_Stmt:
05901             case SGI_Section_Stmt:
05902             case SGI_End_Psection_Stmt:
05903             case SGI_End_Pdo_Stmt:
05904             case SGI_End_Parallel_Stmt:
05905             case SGI_End_Critical_Section_Stmt:
05906             case SGI_End_Single_Process_Stmt:
05907             case SGI_Region_End_Stmt:
05908             case Open_MP_Section_Stmt:
05909             case Open_MP_End_Parallel_Stmt:
05910             case Open_MP_End_Do_Stmt:
05911             case Open_MP_End_Parallel_Sections_Stmt:
05912             case Open_MP_End_Sections_Stmt:
05913             case Open_MP_End_Section_Stmt:
05914             case Open_MP_End_Single_Stmt:
05915             case Open_MP_End_Parallel_Do_Stmt:
05916             case Open_MP_End_Master_Stmt:
05917             case Open_MP_End_Critical_Stmt:
05918             case Open_MP_End_Ordered_Stmt:
05919             case Open_MP_End_Parallel_Workshare_Stmt:
05920             case Open_MP_End_Workshare_Stmt:
05921 
05922                break;
05923 
05924             default:
05925                PRINTMSG(SH_GLB_LINE(sh_idx), 362, Warning, SH_COL_NUM(sh_idx));
05926          }
05927       }
05928    }
05929 
05930    TRACE (Func_Exit, "chk_for_unlabeled_stmt", NULL);
05931 
05932    return;
05933 
05934 }  /* chk_for_unlabeled_stmt */
05935 
05936 
05937 /******************************************************************************\
05938 |*                                                                            *|
05939 |* Description:                                                               *|
05940 |*      This procedure is called by case_stmt_semantics to perform semantic   *|
05941 |*      analysis on a case-value-range.                                       *|
05942 |*                                                                            *|
05943 |* Input parameters:                                                          *|
05944 |*      ir_idx        : the index of the Case_Range IR                        *|
05945 |*      new_il_idx    : the index of the new IL to be added to the list;      *|
05946 |*                      points at the Case_Range IR                           *|
05947 |*      select_ir_idx : the index of the dummy Select IR                      *|
05948 |*                                                                            *|
05949 |* Output parameters:                                                         *|
05950 |*      NONE                                                                  *|
05951 |*                                                                            *|
05952 |* Returns:                                                                   *|
05953 |*      NONE                                                                  *|
05954 |*                                                                            *|
05955 \******************************************************************************/
05956 
05957 static void case_value_range_semantics(int      ir_idx,
05958                                        int      new_il_idx,
05959                                        int      select_ir_idx)
05960 
05961 {
05962    int                  column;
05963    int                  curr_il_idx;
05964    int                  curr_range_ir_idx;
05965    expr_arg_type        expr_desc;
05966    opnd_type            opnd; 
05967    int                  line;
05968  
05969 
05970    TRACE (Func_Entry, "case_value_range_semantics", NULL);
05971 
05972    COPY_OPND(opnd, IR_OPND_L(ir_idx));
05973    expr_desc.rank = 0;
05974 
05975    switch (IR_FLD_L(ir_idx)) {
05976 
05977       case NO_Tbl_Idx:
05978          break;
05979 
05980       case CN_Tbl_Idx:
05981          expr_desc.type_idx     = CN_TYPE_IDX(IR_IDX_L(ir_idx));
05982          expr_desc.type         = TYP_TYPE(expr_desc.type_idx);
05983          expr_desc.linear_type  = TYP_LINEAR(expr_desc.type_idx);
05984          break;
05985 
05986       case AT_Tbl_Idx:
05987 
05988       case IR_Tbl_Idx:
05989          xref_state = CIF_Symbol_Reference;
05990 
05991          if (expr_semantics(&opnd, &expr_desc)) {
05992                  
05993             if (expr_desc.constant) {
05994                COPY_OPND(IR_OPND_L(ir_idx), opnd);
05995             }
05996             else {
05997 
05998                /* Did not resolve to a named constant.                        */
05999 
06000                PRINTMSG(IR_LINE_NUM_L(ir_idx), 811, Error,
06001                         IR_COL_NUM_L(ir_idx));
06002                IR_OPND_L(ir_idx) = null_opnd;
06003             }
06004          }
06005          else {
06006             IR_OPND_L(ir_idx) = null_opnd;
06007          }
06008 
06009          break;
06010 
06011 # ifdef _DEBUG
06012       default:
06013          PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 179, Internal, 
06014                   SH_COL_NUM(curr_stmt_sh_idx), "case_value_range_semantics");
06015 # endif
06016 
06017    }  
06018                     
06019    if (IR_FLD_L(ir_idx) != NO_Tbl_Idx) {
06020       find_opnd_line_and_column(&opnd, &line, &column);
06021       
06022       /* The case-value expression must be scalar.                            */
06023 
06024       if (expr_desc.rank != 0) {
06025          PRINTMSG(line, 766, Error, column);
06026       }
06027          
06028       /* The case-value must be type integer or character.                    */
06029 
06030       if (expr_desc.type == Integer  ||  expr_desc.type == Character) {
06031 
06032          /* If the SELECT CASE stmt is OK, verify that the type of the        */
06033          /* case-value is the same as the SELECT CASE expression.             */
06034 
06035          if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  &&
06036              expr_desc.type != TYP_TYPE(IR_TYPE_IDX(IR_IDX_L(select_ir_idx)))) {
06037             PRINTMSG(line, 745, Error, column);
06038          }
06039 
06040       }
06041       else if (expr_desc.type == Typeless  &&
06042                CN_BOZ_CONSTANT(OPND_IDX(opnd))) {
06043 
06044          /* Extension:  We'll also allow a BOZ constant (but NOT the X,       */
06045          /* trailing B, Hollerith, or character used as Hollerith forms) to   */
06046          /* match an integer SELECT CASE expression.                          */
06047    
06048          if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  &&
06049              TYP_TYPE(IR_TYPE_IDX(IR_IDX_L(select_ir_idx))) != Integer) {
06050             PRINTMSG(line, 745, Error, column);
06051          }
06052          else if (expr_desc.linear_type == Short_Typeless_Const) {
06053             IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx),
06054                                                       INTEGER_DEFAULT_TYPE,
06055                                                       line,
06056                                                       column);
06057             expr_desc.linear_type = INTEGER_DEFAULT_TYPE;
06058             expr_desc.type_idx    = INTEGER_DEFAULT_TYPE;
06059             expr_desc.type        = Integer;
06060          }
06061       }
06062       else {
06063          PRINTMSG(line, 768, Error, column);
06064       }
06065    }
06066 
06067    COPY_OPND(opnd, IR_OPND_R(ir_idx));
06068    expr_desc.rank = 0;
06069 
06070    switch (IR_FLD_R(ir_idx)) {
06071 
06072       case NO_Tbl_Idx:
06073          break;
06074 
06075       case CN_Tbl_Idx:
06076          expr_desc.type_idx     = CN_TYPE_IDX(IR_IDX_R(ir_idx));
06077          expr_desc.type         = TYP_TYPE(expr_desc.type_idx);
06078          expr_desc.linear_type  = TYP_LINEAR(expr_desc.type_idx);
06079          break;
06080 
06081       case AT_Tbl_Idx:
06082 
06083       case IR_Tbl_Idx:
06084          xref_state = CIF_Symbol_Reference;
06085 
06086          if (expr_semantics(&opnd, &expr_desc)) {
06087                
06088             if (expr_desc.constant) {
06089                COPY_OPND(IR_OPND_R(ir_idx), opnd);
06090             }
06091             else {
06092 
06093                /* Did not resolve to a named constant.                        */
06094 
06095                PRINTMSG(IR_LINE_NUM_R(ir_idx), 811, Error,
06096                         IR_COL_NUM_R(ir_idx));
06097                IR_OPND_R(ir_idx) = null_opnd;
06098             }
06099          }
06100          else {
06101             IR_OPND_R(ir_idx) = null_opnd;
06102          }
06103 
06104          break;
06105 
06106 # ifdef _DEBUG
06107       default:
06108          PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 179, Internal, 
06109                   SH_COL_NUM(curr_stmt_sh_idx), "case_value_range_semantics");
06110 # endif
06111 
06112    }  
06113 
06114    if (IR_FLD_R(ir_idx) != NO_Tbl_Idx) {
06115       find_opnd_line_and_column(&opnd, &line, &column);
06116 
06117       /* The case-value expression must be scalar.                            */
06118 
06119       if (expr_desc.rank != 0) {
06120          PRINTMSG(line, 766, Error, column);
06121       }
06122          
06123       /* The case-value must be type integer or character.                    */
06124 
06125       if (expr_desc.type == Integer  ||  expr_desc.type == Character) {
06126 
06127          /* If the SELECT CASE stmt is OK, verify that the type of the        */
06128          /* case-value is the same as the SELECT CASE expression.             */
06129 
06130          if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  &&
06131              expr_desc.type != TYP_TYPE(IR_TYPE_IDX(IR_IDX_L(select_ir_idx)))) {
06132             PRINTMSG(line, 745, Error, column);
06133          }
06134 
06135       }
06136       else if (expr_desc.type == Typeless  &&
06137                CN_BOZ_CONSTANT(OPND_IDX(opnd))) {
06138 
06139          /* Extension:  We'll also allow a BOZ constant (but NOT the X,       */
06140          /* trailing B, Hollerith, or character used as Hollerith forms) to   */
06141          /* match an integer SELECT CASE expression.                          */
06142    
06143          if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  &&
06144              TYP_TYPE(IR_TYPE_IDX(IR_IDX_L(select_ir_idx))) != Integer) {
06145             PRINTMSG(line, 745, Error, column);
06146          }
06147          else if (expr_desc.linear_type == Short_Typeless_Const) {
06148             IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx),
06149                                                       INTEGER_DEFAULT_TYPE,
06150                                                       line,
06151                                                       column);
06152             expr_desc.linear_type = INTEGER_DEFAULT_TYPE;
06153             expr_desc.type_idx    = INTEGER_DEFAULT_TYPE;
06154             expr_desc.type        = Integer;
06155          }
06156       }
06157       else {
06158          PRINTMSG(line, 768, Error, column);
06159       }
06160 
06161       /* If the range has both a left and right value and the left value is   */
06162       /* greater than the right value, issue a warning and return.            */
06163 
06164       if (! SH_ERR_FLG(curr_stmt_sh_idx)  &&
06165           IR_FLD_L(ir_idx) != NO_Tbl_Idx    &&
06166           fold_relationals(IR_IDX_L(ir_idx), IR_IDX_R(ir_idx), Gt_Opr)) {
06167          PRINTMSG(IR_LINE_NUM(ir_idx), 758, Warning, IR_COL_NUM(ir_idx));
06168          goto EXIT;
06169       }
06170 
06171    }
06172 
06173    if (SH_ERR_FLG(curr_stmt_sh_idx)) {
06174       goto EXIT;
06175    }
06176 
06177    /* If this is the first CASE, just attach the new IL to the dummy Select   */
06178    /* IR's right operand.                                                     */
06179 
06180    if (IR_FLD_R(select_ir_idx) == NO_Tbl_Idx) {
06181       ++IR_LIST_CNT_R(select_ir_idx);
06182       IR_FLD_R(select_ir_idx) = IL_Tbl_Idx;
06183       IR_IDX_R(select_ir_idx) = new_il_idx;
06184       goto EXIT;
06185    }
06186 
06187    /* See where this case-value range fits in with previous CASEs.            */
06188 
06189    curr_il_idx = IR_IDX_R(select_ir_idx);
06190 
06191    while (curr_il_idx != NULL_IDX) {
06192 
06193       /* Is there a left value in this new case range?                        */
06194 
06195       if (IR_FLD_L(ir_idx) != NO_Tbl_Idx) {
06196 
06197          /* Yes.  Is there a right value in this new case range?              */
06198 
06199          if (IR_FLD_R(ir_idx) != NO_Tbl_Idx) {
06200 
06201             /* Yes.  Does the current IL represent a single case-value?       */
06202 
06203             if (IL_FLD(curr_il_idx) == CN_Tbl_Idx) {
06204 
06205                /* Yes.                                                        */
06206                /* Is the current value < new IL left value?                   */
06207                /*   Y: Is the current IL the last one in the chain?           */
06208                /*        Y: Append the new IL to the end of the chain.        */
06209                /*           {Done}                                            */
06210                /*        N: Advance to the next IL in the chain.              */
06211                /*   N: Is the current value > new IL right value?             */
06212                /*        Y: Insert the new IL ahead of the current IL.        */
06213                /*        N: Error; the (new) range contains a value already   */
06214                /*             specified by a previous single case-value.      */
06215 
06216                if (fold_relationals(IL_IDX(curr_il_idx), IR_IDX_L(ir_idx),
06217                                     Lt_Opr)) {
06218 
06219                   if (IL_NEXT_LIST_IDX(curr_il_idx) == NULL_IDX) {
06220                      IL_NEXT_LIST_IDX(curr_il_idx) = new_il_idx;
06221                      IL_PREV_LIST_IDX(new_il_idx)  = curr_il_idx;
06222                      ++IR_LIST_CNT_R(select_ir_idx);
06223                      goto EXIT;
06224                   }
06225 
06226                }
06227                else if (fold_relationals(IL_IDX(curr_il_idx), IR_IDX_R(ir_idx),
06228                                          Gt_Opr)) {
06229                   insert_on_left(new_il_idx, curr_il_idx, select_ir_idx);
06230                   goto EXIT;
06231                }
06232                else {
06233                   PRINTMSG(IR_LINE_NUM(ir_idx), 748, Error,
06234                            IR_COL_NUM(ir_idx), IL_LINE_NUM(curr_il_idx));
06235                   goto EXIT;
06236                }
06237 
06238             }
06239             else {
06240 
06241                /* No, the current IL represents a range.                      */
06242                /* Does the current range have a left value?                   */
06243                /*   Y: Does the current range have a right value?             */
06244                /*        Y: Is the new left value > current left value?       */
06245                /*             Y: Is the new left value > current right value? */
06246                /*                  Y: Is the current IL at the end of the     */
06247                /*                     list?                                   */
06248                /*                       Y: Append the new IL to the list.     */
06249                /*                          {Done}                             */
06250                /*                       N: Advance to the next IL in the list.*/
06251                /*                  N: Error; the ranges overlap.              */
06252                /*                     {Quit}                                  */
06253                /*             N: --|                                          */
06254                /*        N: --|                                               */
06255                /*      Is the new right value < current left value?           */
06256                /*        Y: Insert the new IL to the left of the current IL.  */
06257                /*           {Done}                                            */
06258                /*        N: Error; the ranges overlap.                        */
06259                /*           {Quit}                                            */
06260                /*   N: Is the new left value > current right value?           */
06261                /*        Y: Is the current IL the last one in the list?       */
06262                /*             Y: Append the new IL to the end of the list.    */
06263                /*             N: Advance to the next IL.                      */
06264                /*        N: Error; the ranges overlap.                        */
06265                /*           {Quit}                                            */
06266 
06267                curr_range_ir_idx = IL_IDX(curr_il_idx);
06268 
06269                if (IR_FLD_L(curr_range_ir_idx) != NO_Tbl_Idx) {
06270 
06271                   if (IR_FLD_R(curr_range_ir_idx) != NO_Tbl_Idx) {
06272 
06273                      if (fold_relationals(IR_IDX_L(ir_idx), 
06274                                           IR_IDX_L(curr_range_ir_idx),
06275                                           Gt_Opr)) {
06276 
06277                         if (fold_relationals(IR_IDX_L(ir_idx),
06278                                              IR_IDX_R(curr_range_ir_idx),
06279                                              Gt_Opr)) {
06280 
06281                            if (IL_NEXT_LIST_IDX(curr_il_idx) == NULL_IDX) {
06282                               IL_NEXT_LIST_IDX(curr_il_idx) = new_il_idx;
06283                               IL_PREV_LIST_IDX(new_il_idx)  = curr_il_idx;
06284                               ++IR_LIST_CNT_R(select_ir_idx);
06285                               goto EXIT;
06286                            }
06287                            else {
06288                               goto ADVANCE_TO_NEXT_IL;
06289                            }
06290 
06291                         }
06292                         else {
06293                            PRINTMSG(IR_LINE_NUM(ir_idx), 749, Error,
06294                                     IR_COL_NUM(ir_idx),
06295                                     IR_LINE_NUM(curr_range_ir_idx));
06296                            goto EXIT;
06297                         }
06298 
06299                      }
06300 
06301                   }
06302 
06303                   if (fold_relationals(IR_IDX_R(ir_idx),
06304                                        IR_IDX_L(curr_range_ir_idx),
06305                                        Lt_Opr)) {
06306                      insert_on_left(new_il_idx, curr_il_idx, select_ir_idx);
06307                      goto EXIT;
06308                   }
06309                   else {
06310                      PRINTMSG(IR_LINE_NUM(ir_idx), 749, Error,
06311                               IR_COL_NUM(ir_idx),
06312                               IR_LINE_NUM(curr_range_ir_idx));
06313                      goto EXIT;
06314                   }
06315 
06316                }
06317                else {
06318 
06319                   if (fold_relationals(IR_IDX_L(ir_idx),
06320                                        IR_IDX_R(curr_range_ir_idx),
06321                                        Gt_Opr)) {
06322 
06323                      if (IL_NEXT_LIST_IDX(curr_il_idx) == NULL_IDX) {
06324                         IL_NEXT_LIST_IDX(curr_il_idx) = new_il_idx;
06325                         IL_PREV_LIST_IDX(new_il_idx)  = curr_il_idx;
06326                         ++IR_LIST_CNT_R(select_ir_idx);
06327                         goto EXIT;
06328                      }
06329                      else {
06330                         goto ADVANCE_TO_NEXT_IL;
06331                      }
06332 
06333                   }
06334                   else {
06335                      PRINTMSG(IR_LINE_NUM(ir_idx), 749, Error,
06336                               IR_COL_NUM(ir_idx),
06337                               IR_LINE_NUM(curr_range_ir_idx));
06338                      goto EXIT;
06339                   }
06340 
06341                }
06342 
06343             }
06344 
06345          }
06346          else {
06347 
06348             /* The new case range does NOT have a right value.                */
06349 
06350             /* Does the current IL represent a single case-value?             */
06351             /*   Y: Is the new left value > current value?                    */
06352             /*        Y: Is the current IL at the end of the list?            */
06353             /*             Y: Append the new IL to the end of the list.       */
06354             /*             N: Advance to the next IL.                         */
06355             /*        N: Error; this range contains a value that was already  */
06356             /*             specified by a single case-value.                  */
06357             /*           {Quit}                                               */
06358             /*   N: Does the current range have a right value?                */
06359             /*        Y: Is the new left value > current right value?         */
06360             /*             Y: Is the current IL at the end of the list?       */
06361             /*                  Y: Append the new IL to the end of the list.  */
06362             /*                  N: Advance to the next IL.                    */
06363             /*             N: --|                                             */
06364             /*        N: --|                                                  */
06365             /*      Error; the ranges overlap.                                */
06366             /*      {Quit}                                                    */
06367 
06368             if (IL_FLD(curr_il_idx) == CN_Tbl_Idx) {
06369 
06370                if (fold_relationals(IR_IDX_L(ir_idx),
06371                                     IL_IDX(curr_il_idx), Gt_Opr)) {
06372 
06373                   if (IL_NEXT_LIST_IDX(curr_il_idx) == NULL_IDX) {
06374                      IL_NEXT_LIST_IDX(curr_il_idx) = new_il_idx;
06375                      IL_PREV_LIST_IDX(new_il_idx)  = curr_il_idx;
06376                      ++IR_LIST_CNT_R(select_ir_idx);
06377                      goto EXIT;
06378                   }
06379 
06380                }
06381                else {
06382                   PRINTMSG(IR_LINE_NUM(ir_idx), 748, Error,
06383                            IR_COL_NUM(ir_idx), IL_LINE_NUM(curr_il_idx));
06384                   goto EXIT;
06385                }
06386 
06387             }
06388             else {
06389 
06390                if (IR_FLD_R(IL_IDX(curr_il_idx)) != NO_Tbl_Idx) {
06391 
06392                   if (fold_relationals(IR_IDX_L(ir_idx),
06393                                        IR_IDX_R(IL_IDX(curr_il_idx)), Gt_Opr)) {
06394 
06395                      if (IL_NEXT_LIST_IDX(curr_il_idx) == NULL_IDX) {
06396                         IL_NEXT_LIST_IDX(curr_il_idx) = new_il_idx;
06397                         IL_PREV_LIST_IDX(new_il_idx)  = curr_il_idx;
06398                         ++IR_LIST_CNT_R(select_ir_idx);
06399                         goto EXIT;
06400                      }
06401                      else {
06402                         goto ADVANCE_TO_NEXT_IL;
06403                      }
06404 
06405                   }
06406      
06407                }
06408 
06409                PRINTMSG(IR_LINE_NUM(ir_idx), 749, Error,
06410                         IR_COL_NUM(ir_idx), IR_LINE_NUM(IL_IDX(curr_il_idx)));
06411                goto EXIT;
06412             }
06413 
06414          }
06415 
06416       }
06417       else {
06418 
06419          /* The new case range does NOT have a left value.                    */
06420 
06421          /* Does the current IL represent a single case-value?                */
06422          /*   Y: Is the new right value < current value?                      */
06423          /*        Y: Insert the new IL at the head of the list.              */
06424          /*           (The current IL must be at the head of the list or an   */
06425          /*            error would already have been detected.)               */
06426          /*           {Done}                                                  */
06427          /*        N: Error; this range contains a value that was already     */
06428          /*             specified by a single case-value.                     */
06429          /*           {Quit}                                                  */
06430          /*   N: Does the current range have a left value?                    */
06431          /*        Y: Is the new right value < current left value?            */
06432          /*             Y: Insert the new IL at the head of the list.         */
06433          /*                (The current IL must be at the head of the list or */
06434          /*                 an error would already have been detected.)       */
06435          /*                {Done}                                             */
06436          /*             N: --|                                                */
06437          /*        N: --|                                                     */
06438          /*      Error; the ranges overlap.                                   */
06439          /*      {Quit}                                                       */
06440 
06441          if (IL_FLD(curr_il_idx) == CN_Tbl_Idx) {
06442 
06443             if (fold_relationals(IR_IDX_R(ir_idx), IL_IDX(curr_il_idx),
06444                                  Lt_Opr)) {
06445                insert_on_left(new_il_idx, curr_il_idx, select_ir_idx);
06446                goto EXIT;
06447             }
06448             else {
06449                PRINTMSG(IR_LINE_NUM(ir_idx), 748, Error,
06450                         IR_COL_NUM(ir_idx), IL_LINE_NUM(curr_il_idx));
06451                goto EXIT;
06452             }
06453 
06454          }
06455          else {
06456 
06457             if (IR_FLD_L(IL_IDX(curr_il_idx)) != NO_Tbl_Idx) {
06458 
06459                if (fold_relationals(IR_IDX_R(ir_idx),
06460                                     IR_IDX_L(IL_IDX(curr_il_idx)), Lt_Opr)) {
06461                   insert_on_left(new_il_idx, curr_il_idx, select_ir_idx);
06462                   goto EXIT;
06463                }
06464      
06465             }
06466 
06467             PRINTMSG(IR_LINE_NUM(ir_idx), 749, Error, 
06468                      IR_COL_NUM(ir_idx), IR_LINE_NUM(IL_IDX(curr_il_idx)));
06469             goto EXIT;
06470          }
06471 
06472       }
06473          
06474 ADVANCE_TO_NEXT_IL:
06475 
06476       curr_il_idx = IL_NEXT_LIST_IDX(curr_il_idx);
06477    }  /* while */
06478 
06479 EXIT:
06480 
06481    TRACE (Func_Exit, "case_value_range_semantics", NULL);
06482 
06483    return;
06484 
06485 }  /* case_value_range_semantics */
06486 
06487 
06488 /******************************************************************************\
06489 |*                                                                            *|
06490 |* Description:                                                               *|
06491 |*      This procedure inserts the "new" IL to the left (or ahead of) the     *|
06492 |*      current IL in the case-value IL list attached to the Select IR.       *|
06493 |*                                                                            *|
06494 |* Input parameters:                                                          *|
06495 |*      new_il_idx    : the index of the "new" IL to be inserted in the list  *|
06496 |*      curr_il_idx   : the index of the current IL; the new IL is to be      *|
06497 |*                      inserted ahead of this one                            *|
06498 |*      select_ir_idx : the index of the dummy Select IR; the sorted          *|
06499 |*                      case-value list is attached to the right operand      *|
06500 |*                                                                            *|
06501 |* Output parameters:                                                         *|
06502 |*      NONE                                                                  *|
06503 |*                                                                            *|
06504 |* Returns:                                                                   *|
06505 |*      NONE                                                                  *|
06506 |*                                                                            *|
06507 \******************************************************************************/
06508 
06509 static void insert_on_left(int          new_il_idx,
06510                            int          curr_il_idx,
06511                            int          select_ir_idx)
06512 
06513 {
06514 
06515    TRACE (Func_Entry, "insert_on_left", NULL);
06516 
06517    /* Is the current IL the first one in the list?                            */
06518    /*   Y: Insert the new IL at the head of the list.                         */
06519    /*   N: Insert the new IL between the current IL and the IL preceding the  */
06520    /*      current IL.                                                        */
06521 
06522    if (IR_IDX_R(select_ir_idx) == curr_il_idx) {
06523       IR_IDX_R(select_ir_idx) = new_il_idx;
06524    }
06525    else {
06526       IL_NEXT_LIST_IDX(IL_PREV_LIST_IDX(curr_il_idx)) = new_il_idx;
06527       IL_PREV_LIST_IDX(new_il_idx) = IL_PREV_LIST_IDX(curr_il_idx);
06528    }
06529 
06530    IL_NEXT_LIST_IDX(new_il_idx)  = curr_il_idx;
06531    IL_PREV_LIST_IDX(curr_il_idx) = new_il_idx;
06532 
06533    ++IR_LIST_CNT_R(select_ir_idx);
06534 
06535    TRACE (Func_Exit, "insert_on_left", NULL);
06536 
06537    return;
06538 
06539 }  /* insert_on_left */
06540 
06541 
06542 /******************************************************************************\
06543 |*                                                                            *|
06544 |* Description:                                                               *|
06545 |*      This procedure is called by the DO statement semantics routine to     *|
06546 |*      check the semantics of the start, end, and increment expressions.     *|
06547 |*      If the expression is OK, an assignment statement is generated to      *|
06548 |*      freeze the expression in a temp if the expression is not a constant   *|
06549 |*      value.                                                                *|
06550 |*                                                                            *|
06551 |* Input parameters:                                                          *|
06552 |*      expr_il_idx : The IL index of the expression to be evaluated.         *|
06553 |*      do_var_idx  : Attr index for the DO variable.                         *|
06554 |*                                                                            *|
06555 |* Output parameters:                                                         *|
06556 |*      expr_opnd   : Cray:  Points at the Asg IR generated to freeze the     *|
06557 |*                           expression or it points at the result value.     *|
06558 |*                    ACSET: Points at the expression result.                 *|
06559 |*                                                                            *|
06560 |* Returns:                                                                   *|
06561 |*      True if the expression is acceptable.                                 *|
06562 |*                                                                            *|
06563 \******************************************************************************/
06564 
06565 static boolean   do_loop_expr_semantics (int             expr_il_idx,
06566                                          int             do_var_idx,
06567                                          opnd_type      *expr_opnd)
06568 
06569 {
06570    int                  col;
06571    expr_arg_type        exp_desc;
06572    int                  line;
06573    boolean              result          = TRUE;
06574    int                  save_next_sh_idx;
06575    int                  idx;
06576    int                  ir_idx;
06577    opnd_type            opnd;
06578    int                  tmp_idx;  
06579 
06580    int                  preamble_end_sh_idx; 
06581    int                  preamble_start_sh_idx;
06582  
06583 
06584    TRACE (Func_Entry, "do_loop_expr_semantics", NULL);
06585 
06586    save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
06587 
06588    COPY_OPND(*expr_opnd, IL_OPND(expr_il_idx));
06589    find_opnd_line_and_column(expr_opnd, &line, &col);
06590    exp_desc.rank = 0;
06591    xref_state    = CIF_Symbol_Reference;
06592   
06593    if (expr_semantics(expr_opnd, &exp_desc)) {
06594       
06595       /* It is possible that expr_semantics generated statements that follow  */
06596       /* curr_stmt_sh_idx.  The following line moves curr_stmt_sh_idx to the  */
06597       /* end of the generated statements.                                     */
06598 
06599       curr_stmt_sh_idx = SH_PREV_IDX(save_next_sh_idx);
06600 
06601 
06602       if (exp_desc.rank != 0) {
06603          PRINTMSG(IL_LINE_NUM(expr_il_idx), 222, Error,
06604                   IL_COL_NUM(expr_il_idx));
06605          result = FALSE;
06606       }
06607 
06608       /* The expression can be default or nondefault integer, default real or */
06609       /* double precision (both of these are obsolescent), or typeless.       */
06610       /* (It should be typeless only if the expression consists of a Boolean  */
06611       /* constant - a CRI extension.)                                         */
06612       
06613       if (exp_desc.type == Integer) {
06614 
06615          /* Good.  Nothing to do.                                             */
06616     
06617       } 
06618       else if (exp_desc.type == Real  && 
06619                (exp_desc.linear_type == REAL_DEFAULT_TYPE  ||
06620                 exp_desc.linear_type == DOUBLE_DEFAULT_TYPE)) {
06621               PRINTMSG(IL_LINE_NUM(expr_il_idx), 1569, Ansi,
06622                        IL_COL_NUM(expr_il_idx));
06623       }
06624       else if (exp_desc.type == Typeless) {
06625 
06626          if ((exp_desc.linear_type == Typeless_4 ||
06627               exp_desc.linear_type == Typeless_8)  &&
06628              TYP_LINEAR(ATD_TYPE_IDX(do_var_idx)) == DOUBLE_DEFAULT_TYPE) {
06629             PRINTMSG(IL_LINE_NUM(expr_il_idx), 1047, Error,
06630                      IL_COL_NUM(expr_il_idx));
06631             result = FALSE;
06632          }
06633          else if (exp_desc.linear_type == Short_Typeless_Const) {
06634             OPND_IDX((*expr_opnd)) = 
06635                           cast_typeless_constant(OPND_IDX((*expr_opnd)),
06636                                                  ATD_TYPE_IDX(do_var_idx),
06637                                                  line,
06638                                                  col);
06639             exp_desc.type_idx    = ATD_TYPE_IDX(do_var_idx);
06640             exp_desc.type        = TYP_TYPE(exp_desc.type_idx);
06641             exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
06642          }
06643          else if (exp_desc.linear_type == Long_Typeless) {
06644             PRINTMSG(IL_LINE_NUM(expr_il_idx), 394, Error,
06645                      IL_COL_NUM(expr_il_idx));
06646             result = FALSE;
06647          }
06648       }
06649       else {
06650          PRINTMSG(IL_LINE_NUM(expr_il_idx),
06651                   (exp_desc.type == Typeless) ? 694 : 217,
06652                   Error,
06653                   IL_COL_NUM(expr_il_idx));
06654          result = FALSE;
06655       }
06656 
06657 
06658       /* If the expression is acceptable, then for the high-level iterative   */
06659       /* DO loop form, just replace the index to the IR tree in the loop      */
06660       /* control IL chain attached to the Loop_Info IR with the tree          */
06661       /* produced from expr_semantics.                                        */
06662       /* For the low-level iterative DO loop form, do one of two things:      */
06663       /*   - If the expression resolves to a constant, convert it to the type */
06664       /*     of the DO variable.                                              */
06665       /*   - Otherwise, generate an assignment statement to freeze the value  */
06666       /*     of the expression.                                               */
06667 
06668       if (result) {
06669 /*  # ifdef _HIGH_LEVEL_DO_LOOP_FORM 
06670          --we need to have temporary for high level loop format --FMZ
06671          COPY_OPND(IL_OPND(expr_il_idx), *expr_opnd);
06672 # else 
06673 */
06674 
06675          if (OPND_FLD((*expr_opnd)) == CN_Tbl_Idx) {
06676             IL_FLD(expr_il_idx) = CN_Tbl_Idx;
06677             IL_IDX(expr_il_idx) = OPND_IDX((*expr_opnd));
06678 
06679             if (CN_TYPE_IDX(OPND_IDX((*expr_opnd))) !=
06680                    ATD_TYPE_IDX(do_var_idx)) {
06681                IL_IDX(expr_il_idx) =
06682                   convert_to_do_var_type((TYP_TYPE(ATD_TYPE_IDX(do_var_idx)) ==
06683                                              CRI_Ptr) ?
06684                                              INTEGER_DEFAULT_TYPE :
06685                                              ATD_TYPE_IDX(do_var_idx),
06686                                          IL_IDX(expr_il_idx));
06687                OPND_IDX((*expr_opnd)) = IL_IDX(expr_il_idx);
06688             }
06689          }
06690          else {
06691 
06692             /* Generate an assignment statement to freeze the expression in   */
06693             /* a temp.                                                        */
06694 
06695             gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
06696                    FALSE, FALSE, TRUE);
06697 
06698             GEN_COMPILER_TMP_ASG(ir_idx,
06699                                  tmp_idx,
06700                                  FALSE,         /* Do semantics on tmp */
06701                                  line,
06702                                  col,
06703                                  INTEGER_DEFAULT_TYPE,
06704                                  Priv);
06705 
06706             COPY_OPND(IR_OPND_R(ir_idx), *expr_opnd);
06707 
06708             SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
06709 
06710             /* Make the Asg IR result type is the same as the DO variable.    */
06711             /* Set the result temp to the type of the DO variable unless the  */
06712             /* DO variable is a CRI pointer in which case leave the temp as   */
06713             /* default integer (because the temps are used in the trip count  */
06714             /* calculation and the rules of CRI pointer arithmetic are a bit  */
06715             /* arcane).                                                       */
06716 
06717             IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(do_var_idx);
06718    
06719             if (TYP_TYPE(ATD_TYPE_IDX(do_var_idx)) != CRI_Ptr) {
06720                ATD_TYPE_IDX(IR_IDX_L(ir_idx)) = ATD_TYPE_IDX(do_var_idx);
06721             }
06722 
06723             if (cdir_switches.doall_sh_idx ||
06724                 cdir_switches.paralleldo_omp_sh_idx) {
06725 
06726                if (preamble_end_sh_idx == NULL_IDX) {
06727                   gen_opnd(&opnd, curr_stmt_sh_idx, SH_Tbl_Idx, 
06728                            stmt_start_line, stmt_start_col);
06729                   copy_subtree(&opnd, &opnd);
06730                   preamble_start_sh_idx = OPND_IDX(opnd);
06731                   SH_COMPILER_GEN(preamble_start_sh_idx) = TRUE;
06732                   SH_P2_SKIP_ME(preamble_start_sh_idx) = TRUE;
06733                   preamble_end_sh_idx = preamble_start_sh_idx;
06734                }
06735                else {
06736                   gen_opnd(&opnd, curr_stmt_sh_idx, SH_Tbl_Idx, 
06737                            stmt_start_line, stmt_start_col);
06738                   copy_subtree(&opnd, &opnd);
06739                   idx = OPND_IDX(opnd);
06740                   SH_NEXT_IDX(preamble_end_sh_idx) = idx;
06741 
06742                   if (SH_NEXT_IDX(preamble_end_sh_idx)) {
06743                      SH_PREV_IDX(SH_NEXT_IDX(preamble_end_sh_idx)) =
06744                                                        preamble_end_sh_idx;
06745                   }
06746                   preamble_end_sh_idx = SH_NEXT_IDX(preamble_end_sh_idx);
06747                   SH_COMPILER_GEN(preamble_end_sh_idx) = TRUE;
06748                   SH_P2_SKIP_ME(preamble_end_sh_idx) = TRUE;
06749                }
06750             }
06751 
06752             /* Save the target temp in the IL that originally pointed at the  */
06753             /* expression so that it can be used by end-of-loop processing.   */
06754 
06755             IL_FLD(expr_il_idx) = AT_Tbl_Idx;
06756             IL_IDX(expr_il_idx) = tmp_idx;
06757          } 
06758 
06759 /* # endif  */
06760 
06761       }
06762    }
06763    else {
06764       result = FALSE;
06765    }
06766 
06767    TRACE (Func_Exit, "do_loop_expr_semantics", NULL);
06768 
06769    return(result);
06770 
06771 }  /* do_loop_expr_semantics */
06772 
06773 
06774 
06775 /* # ifndef _HIGH_LEVEL_DO_LOOP_FORM */
06776 
06777 /******************************************************************************\
06778 |*                                                                            *|
06779 |* Description:                                                               *|
06780 |*      This procedure is called by the DO statement semantics routine when   *|
06781 |*      all 3 loop expressions are constant values.  It calculates the        *|
06782 |*      iteration count at compile time and, for Crays, checks to see if the  *|
06783 |*      loop iteration count is too large.                                    *|
06784 |*                                                                            *|
06785 |* Input parameters:                                                          *|
06786 |*      do_sh_idx   : SH index for the DO statement                           *|
06787 |*      start_idx   : CN index for the start value                            *|
06788 |*      end_idx     : CN index for the start value                            *|
06789 |*      inc_idx     : CN index for the start value                            *|
06790 |*      do_vari_idx : AT index for the DO variable                            *|
06791 |*                                                                            *|
06792 |* Output parameters:                                                         *|
06793 |*      NONE                                                                  *|
06794 |*                                                                            *|
06795 |* Returns:                                                                   *|
06796 |*      The CN index for the iteration count value if the calculation         *|
06797 |*      succeeded.  Returns a 0 CN index otherwise.                           *|
06798 |*                                                                            *|
06799 \******************************************************************************/
06800 
06801 static  int calculate_iteration_count(int       do_sh_idx,
06802                                       int       start_idx,
06803                                       int       end_idx,
06804                                       int       inc_idx,
06805                                       int       do_var_idx)
06806 {
06807    long64               cri_loop_limit;
06808    int                  cri_loop_limit_idx;
06809    basic_type_type      do_var_type;
06810    linear_type_type     do_var_lin_type;
06811    int                  do_var_type_idx;
06812    expr_arg_type        expr_desc;
06813    opnd_type            expr_opnd;
06814    int                  ir_idx;
06815    int                  iter_count_idx;
06816    int                  iter_count_ir_idx;
06817    int                  result_type_idx;
06818    long_type            result_value[MAX_WORDS_FOR_NUMERIC];
06819 
06820 
06821 # ifdef _DEBUG
06822    int                  orig_iter_count_idx;
06823    long_type            debug_converted_value[MAX_WORDS_FOR_NUMERIC];
06824 # endif
06825 
06826 
06827 # ifdef _TARGET_OS_UNICOS
06828 
06829    /* Define the smallest numbers greater than 1.0 for CRAY PVP architecture. */
06830    /* (Needed for the multiplication below because on a CRAY, a division like */
06831    /* 42 / 6 can produce a value of 6.999... which when truncated produces    */
06832    /* 6.0 which is the wrong iteration count.)                                */
06833 
06834   long_type     fudge;
06835   int           fudge_idx;
06836 
06837   struct        {long_type      part_1;
06838                  long_type      part_2;
06839                 } double_fudge;
06840 
06841 # endif
06842 
06843                
06844    TRACE (Func_Entry, "calculate_iteration_count", NULL);
06845 
06846    /* Set comp_gen_expr to TRUE to force real constant expressions to be      */
06847    /* folded.  When -Oieeeconform is specified, the folding of real and       */
06848    /* complex expressions is disabled.                                        */
06849 
06850    comp_gen_expr = TRUE;
06851 
06852 
06853    /* Get the type information for the DO variable.  Set up the IR            */
06854    /* representing the iteration count expression  (END - START + INC) / INC  */
06855 
06856    if (TYP_TYPE(ATD_TYPE_IDX(do_var_idx)) == CRI_Ptr) {
06857       do_var_type       = Integer;
06858       do_var_lin_type   = INTEGER_DEFAULT_TYPE;
06859       do_var_type_idx   = INTEGER_DEFAULT_TYPE;
06860    }
06861    else {
06862       do_var_type_idx   = ATD_TYPE_IDX(do_var_idx);
06863       do_var_type       = TYP_TYPE(do_var_type_idx);
06864       do_var_lin_type   = TYP_LINEAR(do_var_type_idx);
06865    }
06866    
06867    NTR_IR_TBL(iter_count_ir_idx);
06868    IR_OPR(iter_count_ir_idx)      = Minus_Opr;
06869    IR_TYPE_IDX(iter_count_ir_idx) = do_var_type_idx;
06870    IR_LINE_NUM(iter_count_ir_idx) = stmt_start_line;
06871    IR_COL_NUM(iter_count_ir_idx)  = stmt_start_line;
06872    IR_FLD_L(iter_count_ir_idx)    = CN_Tbl_Idx;
06873    IR_IDX_L(iter_count_ir_idx)    = end_idx;
06874    IR_LINE_NUM_L(iter_count_ir_idx) = stmt_start_line;
06875    IR_COL_NUM_L(iter_count_ir_idx)  = stmt_start_line;
06876    IR_FLD_R(iter_count_ir_idx)    = CN_Tbl_Idx;
06877    IR_IDX_R(iter_count_ir_idx)    = start_idx;
06878    IR_LINE_NUM_R(iter_count_ir_idx) = stmt_start_line;
06879    IR_COL_NUM_R(iter_count_ir_idx)  = stmt_start_line;
06880 
06881    NTR_IR_TBL(ir_idx);
06882    IR_OPR(ir_idx)      = Plus_Opr;
06883    IR_TYPE_IDX(ir_idx) = do_var_type_idx;
06884    IR_LINE_NUM(ir_idx) = stmt_start_line;
06885    IR_COL_NUM(ir_idx)  = stmt_start_line;
06886    IR_FLD_L(ir_idx)    = IR_Tbl_Idx;
06887    IR_IDX_L(ir_idx)    = iter_count_ir_idx;
06888    IR_FLD_R(ir_idx)    = CN_Tbl_Idx;
06889    IR_IDX_R(ir_idx)    = inc_idx;
06890    IR_LINE_NUM_R(ir_idx) = stmt_start_line;
06891    IR_COL_NUM_R(ir_idx)  = stmt_start_line;
06892 
06893    NTR_IR_TBL(iter_count_ir_idx);
06894    IR_OPR(iter_count_ir_idx)      = Div_Opr;
06895    IR_TYPE_IDX(iter_count_ir_idx) = do_var_type_idx;
06896    IR_LINE_NUM(iter_count_ir_idx) = stmt_start_line;
06897    IR_COL_NUM(iter_count_ir_idx)  = stmt_start_line;
06898    IR_FLD_L(iter_count_ir_idx)    = IR_Tbl_Idx;
06899    IR_IDX_L(iter_count_ir_idx)    = ir_idx;
06900    IR_FLD_R(iter_count_ir_idx)    = CN_Tbl_Idx;
06901    IR_IDX_R(iter_count_ir_idx)    = inc_idx;
06902    IR_LINE_NUM_R(iter_count_ir_idx) = stmt_start_line;
06903    IR_COL_NUM_R(iter_count_ir_idx)  = stmt_start_line;
06904   
06905    OPND_FLD(expr_opnd) = IR_Tbl_Idx;
06906    OPND_IDX(expr_opnd) = iter_count_ir_idx;
06907 
06908 
06909    /* If the host machine is a nonPVP machine or the host is a PVP and the    */
06910    /* loop control expressions are type INTEGER(8), we need to be careful in  */
06911    /* calculating the iteration count because it could overflow.  In order    */
06912    /* to prevent the overflow message from being output by the folder, turn   */
06913    /* it off, then upon return, check to see if overflow (including too small */
06914    /* of a negative integer value) occurred.                                  */
06915 
06916    expr_desc.rank         = 0;
06917    issue_overflow_msg_719 = FALSE;
06918 
06919    if (expr_semantics(&expr_opnd, &expr_desc)) {
06920       iter_count_idx = OPND_IDX(expr_opnd);
06921 
06922       if (do_var_type != Integer) {
06923 
06924          /* Convert the iteration count to integer.                           */
06925 
06926 # if !(defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
06927 # ifdef _TARGET_OS_UNICOS
06928 
06929 # ifdef _DEBUG
06930          orig_iter_count_idx = OPND_IDX(expr_opnd);
06931 # endif
06932 
06933          /* The DO-variable is type real or double precision, so we have to   */
06934          /* be careful to multiply the calculated value by the smallest       */
06935          /* number > 1 to round a division result like 6.99999... to 7.       */
06936          /* Note that union variables can not be initialized so code exists   */
06937          /* below to get the value into the appropriate fudge factor.         */
06938 
06939          /* IEEE machines (such as the IEEE T90) do division exactly so the   */
06940          /* fudging around and the multiply is not needed.                    */
06941 
06942          if (do_var_type == Real  &&  ! (target_triton  &&  target_ieee)) {
06943     
06944             if (do_var_lin_type == REAL_DEFAULT_TYPE) {
06945 
06946 
06947 # if defined(_HOST_OS_UNICOS)
06948 
06949                fudge = 00400014000000000000001;
06950 
06951 # elif defined(_HOST32)
06952 
06953                fudge = 00400014000000000000001ULL;   /* BRIANJ */
06954 
06955 # endif
06956 
06957                fudge_idx = ntr_const_tbl( REAL_DEFAULT_TYPE,
06958                                           FALSE,
06959                                          &fudge);
06960             }
06961             else {
06962 
06963 # if defined(_HOST_OS_UNICOS)
06964 
06965                double_fudge.part_1 = 00400014000000000000000;
06966                double_fudge.part_2 = 1;
06967 
06968 # elif defined(_HOST32)
06969 
06970                double_fudge.part_1 = 00400014000000000000000ULL;
06971                double_fudge.part_2 = 1;
06972 
06973 # endif
06974 
06975                fudge_idx = ntr_const_tbl(DOUBLE_DEFAULT_TYPE,
06976                                          FALSE,
06977                                          (long_type *) &double_fudge);
06978             }
06979 
06980             result_type_idx = do_var_type_idx;
06981 
06982             if (folder_driver( (char *) &CN_CONST(iter_count_idx),
06983                                do_var_type_idx,
06984                                (char *) &CN_CONST(fudge_idx),
06985                                do_var_type_idx,
06986                                result_value,
06987                               &result_type_idx,
06988                                stmt_start_line,
06989                                stmt_start_col,
06990                                2,
06991                                Mult_Opr)) {
06992                iter_count_idx = ntr_const_tbl(do_var_lin_type,
06993                                               FALSE,
06994                                               result_value);
06995             }
06996             else {
06997                PRINTMSG(stmt_start_line, 857, Internal, stmt_start_col);
06998                SH_ERR_FLG(do_sh_idx) = TRUE;
06999             }
07000          }
07001 
07002 # endif                               /* End special Cray PVP considerations. */
07003 # endif                               /* End special Cray PVP considerations. */
07004 
07005 
07006          result_type_idx = INTEGER_DEFAULT_TYPE;
07007 
07008          if (folder_driver((char *)&CN_CONST(iter_count_idx),
07009                            do_var_type_idx,
07010                            NULL,
07011                            NULL_IDX,
07012                            result_value,
07013                           &result_type_idx,
07014                            stmt_start_line,
07015                            stmt_start_col,
07016                            1,
07017                            Cvrt_Opr)) {
07018 
07019             iter_count_idx = ntr_const_tbl(INTEGER_DEFAULT_TYPE,
07020                                            FALSE,
07021                                            result_value);
07022          }
07023 
07024 
07025 # if !(defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
07026 # ifdef _TARGET_OS_UNICOS
07027 # ifdef _DEBUG
07028    
07029          /* Before comparing the calculated iteration count to the CRI limit, */
07030          /* make sure our fudge factor multiplication assumptions have worked */
07031          /* out.  That is, if we convert both the original iteration count    */
07032          /* and the fudged iteration count to integer, they should be equal   */
07033          /* or the fudged one should be 1 greater than the original value.    */
07034          /* If these relationships don't hold, we want to rethink this code.  */
07035 
07036          result_type_idx = INTEGER_DEFAULT_TYPE;
07037 
07038          if (folder_driver((char *)&CN_CONST(orig_iter_count_idx),
07039                            CN_TYPE_IDX(orig_iter_count_idx),
07040                            NULL,
07041                            NULL_IDX,
07042                            debug_converted_value,
07043                           &result_type_idx,
07044                            stmt_start_line,
07045                            stmt_start_col,
07046                            1,
07047                            Cvrt_Opr)) {
07048 
07049             orig_iter_count_idx = ntr_const_tbl(INTEGER_DEFAULT_TYPE,
07050                                                 FALSE,
07051                                                 debug_converted_value);
07052          }
07053 
07054          if (fold_relationals(orig_iter_count_idx, iter_count_idx, Ne_Opr)) {
07055             result_type_idx = INTEGER_DEFAULT_TYPE;
07056 
07057             if (folder_driver((char *) debug_converted_value,
07058                               INTEGER_DEFAULT_TYPE,
07059                               (char *) &CN_CONST(CN_INTEGER_ONE_IDX),
07060                               CN_TYPE_IDX(CN_INTEGER_ONE_IDX),
07061                               debug_converted_value,
07062                              &result_type_idx,
07063                               stmt_start_line,
07064                               stmt_start_col,
07065                               2,
07066                               Plus_Opr)) {
07067    
07068             }
07069 
07070             /* THe above call to folder_driver replaces this line */
07071             /* ++debug_converted_value[0];                        */
07072             /* BRIANJ JEFFL KAY                                   */
07073       
07074             orig_iter_count_idx = ntr_const_tbl(INTEGER_DEFAULT_TYPE,
07075                                                 FALSE,
07076                                                 debug_converted_value);
07077 
07078             if (! fold_relationals(orig_iter_count_idx, iter_count_idx,
07079                                    Eq_Opr)) {
07080                PRINTMSG(stmt_start_line, 857, Internal, stmt_start_col);
07081                SH_ERR_FLG(do_sh_idx) = TRUE;
07082             }
07083          } 
07084 
07085 # endif  
07086 # endif  
07087 # endif                                       /* End Cray PVP considerations. */
07088 
07089       }
07090 
07091 
07092 # if !(defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
07093 # ifdef _TARGET_OS_UNICOS
07094 
07095       /* Now that the iteration count has been converted to integer, if       */
07096       /* necessary, for Cray PVP machines verify that the iteration count     */
07097       /* will fit in a 32-bit A register.                                     */
07098 
07099       if (! (target_triton  &&  target_ieee)) {
07100 
07101          if (target_triton) {
07102 # ifdef _HOST64
07103             cri_loop_limit = 70368744177663L;                  /*  2**46 - 1  */
07104 # else
07105             cri_loop_limit = 70368744177663LL;                 /*  2**46 - 1  */
07106 # endif
07107          }
07108          else {
07109 # ifdef _HOST64
07110             cri_loop_limit = 2147483647L;                      /*  2**31 - 1  */
07111 # else
07112             cri_loop_limit = 2147483647LL;                     /*  2**31 - 1  */
07113 # endif
07114          }
07115 
07116          cri_loop_limit_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE,
07117                                           cri_loop_limit);
07118 
07119          if (fold_relationals(iter_count_idx, cri_loop_limit_idx, Gt_Opr)) {
07120             PRINTMSG(stmt_start_line, 856, Error, stmt_start_col,
07121                      cri_loop_limit);
07122             SH_ERR_FLG(do_sh_idx) = TRUE;
07123          }
07124       }
07125 
07126 # endif                                
07127 # endif                                
07128                                       
07129 
07130    }
07131    else {
07132 
07133       /* Semantic analysis of the iteration count expression failed.          */
07134 
07135       iter_count_idx = 0;
07136 
07137       if (need_to_issue_719) {
07138          PRINTMSG(stmt_start_line, 1082, Error, stmt_start_col);
07139          need_to_issue_719     = FALSE;
07140          SH_ERR_FLG(do_sh_idx) = TRUE;
07141       }
07142       else {
07143          PRINTMSG(stmt_start_line, 857, Internal, stmt_start_col);
07144       }
07145    }
07146 
07147    issue_overflow_msg_719 = TRUE;
07148 
07149 
07150    /* Reset comp_gen_expr to FALSE because we're at the end of the compiler   */
07151    /* generated expression processing.                                        */
07152 
07153    comp_gen_expr = FALSE;
07154 
07155    TRACE (Func_Exit, "calculate_iteration_count", NULL);
07156 
07157    return(iter_count_idx);
07158 
07159 }  /* calculate_iteration_count */
07160 
07161 
07162 
07163 /******************************************************************************\
07164 |*                                                                            *|
07165 |* Description:                                                               *|
07166 |*      Convert the loop control expression value to the DO-variable type.    *|
07167 |*                                                                            *|
07168 |* Input parameters:                                                          *|
07169 |*      do_var_type_idx : DO-variable type_idx                                *|
07170 |*      cn_idx          : CN index of loop control expression                 *|
07171 |*                                                                            *|
07172 |* Output parameters:                                                         *|
07173 |*      NONE                                                                  *|
07174 |*                                                                            *|
07175 |* Returns:                                                                   *|
07176 |*      converted_cn_idx : the index to the CN entry for the loop control     *|
07177 |*                         expression converted to the DO-variable type or    *|
07178 |*                         NULL_IDX if something went wrong                   *|
07179 |*                                                                            *|
07180 \******************************************************************************/
07181 
07182 static int convert_to_do_var_type(int           do_var_type_idx,
07183                                   int           cn_idx)
07184 {
07185    int                  converted_cn_idx;
07186    long_type            converted_value[MAX_WORDS_FOR_NUMERIC];
07187    basic_type_type      do_var_type;
07188    linear_type_type     do_var_lin_type;
07189    int                  type_idx;
07190   
07191 
07192    TRACE (Func_Entry, "convert_to_do_var_type", NULL);
07193 
07194    do_var_type          = TYP_TYPE(do_var_type_idx);
07195    do_var_lin_type      = TYP_LINEAR(do_var_type_idx);
07196 
07197    if (TYP_TYPE(CN_TYPE_IDX(cn_idx)) == do_var_type  &&
07198        TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == do_var_lin_type) {
07199       converted_cn_idx = cn_idx;
07200    }
07201    else {
07202 
07203       if (TYP_TYPE(CN_TYPE_IDX(cn_idx)) == Typeless) {
07204 
07205          /* Hey, LRR, I need a better line and column here. */
07206 
07207          converted_cn_idx = cast_typeless_constant(cn_idx,
07208                                                    do_var_type_idx,
07209                                                    stmt_start_line,
07210                                                    stmt_start_col);
07211       }
07212       else {
07213              
07214          if (do_var_lin_type != TYP_LINEAR(CN_TYPE_IDX(cn_idx))) {
07215 
07216             type_idx = do_var_type_idx;
07217 
07218             if (folder_driver((char *)&CN_CONST(cn_idx),
07219                               CN_TYPE_IDX(cn_idx),
07220                               NULL,
07221                               NULL_IDX,
07222                               converted_value,
07223                              &type_idx,
07224                               stmt_start_line,
07225                               stmt_start_col,
07226                               1,
07227                               Cvrt_Opr)) {
07228             }
07229          }
07230          else {
07231             /* BRIANJ - This is probably wrong here. */
07232             converted_value[0] = CN_INT_TO_C(cn_idx);
07233 
07234             if (TYP_TYPE(CN_TYPE_IDX(cn_idx)) == Real  &&
07235                 TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == DOUBLE_DEFAULT_TYPE) {
07236                converted_value[1] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + 1);
07237             }
07238          }
07239 
07240          converted_cn_idx = ntr_const_tbl(do_var_type_idx,
07241                                           FALSE,
07242                                           converted_value);
07243       }
07244    }
07245 
07246    TRACE (Func_Exit, "convert_to_do_var_type", NULL);
07247 
07248    return(converted_cn_idx);
07249 
07250 }  /* convert_to_do_var_type */
07251 
07252 /*  # endif */
07253 
07254 
07255 
07256 /******************************************************************************\
07257 |*                                                                            *|
07258 |* Description:                                                               *|
07259 |*      Generate the IR at the end of a loop.  This procedure is called by    *|
07260 |*      semantics_pass_driver.                                                *|
07261 |*                                                                            *|
07262 |* Input parameters:                                                          *|
07263 |*      NONE                                                                  *|
07264 |*                                                                            *|
07265 |* Output parameters:                                                         *|
07266 |*      NONE                                                                  *|
07267 |*                                                                            *|
07268 |* Returns:                                                                   *|
07269 |*      NONE                                                                  *|
07270 |*                                                                            *|
07271 \******************************************************************************/
07272 
07273 void gen_loop_end_ir()
07274 
07275 {
07276    int                  asg_ir_idx;
07277    int                  attr_idx;
07278    int                  do_sh_idx;
07279    expr_arg_type        expr_desc;
07280    int                  il_idx;
07281    int                  ir_idx;
07282    int                  loop_control_il_idx;
07283    int                  loop_labels_il_idx;
07284    int                  loop_info_idx;
07285    opnd_type            temp_opnd;
07286 
07287 # ifdef _HIGH_LEVEL_DO_LOOP_FORM
07288    int                  loop_end_sh_idx;
07289 # else
07290    int                  asg_idx;
07291    int                  do_var_il_idx;
07292    int                  do_var_linear_type;
07293    int                  expr_ir_idx;
07294    long_type            folded_const[MAX_WORDS_FOR_NUMERIC];
07295    int                  il_idx_2;
07296    int                  inc_il_idx;
07297    int                  induc_tmp_il_idx;
07298    int                  init_ir_idx;
07299    int                  max_int_idx;
07300    int                  opnd_column;
07301    int                  opnd_line;
07302    int                  save_curr_stmt_sh_idx;
07303    int                  start_il_idx;
07304    int                  trip_cnt_il_idx;
07305    int                  tmp_idx;
07306    int                  tmp_idx2;
07307 # endif
07308 
07309 
07310    TRACE (Func_Entry, "gen_loop_end_ir", NULL);
07311 
07312    /* The current SH is a compiler-generated CONTINUE SH that represents      */
07313    /* either the EXIT label or the loop bottom (skip) label.                  */
07314 
07315    do_sh_idx           = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
07316    loop_info_idx       = SH_IR_IDX(do_sh_idx);
07317    loop_control_il_idx = IR_IDX_R(loop_info_idx);
07318    loop_labels_il_idx  = IL_NEXT_LIST_IDX(loop_control_il_idx);
07319 
07320 
07321    /* If this is an iterative DO, clear its "live DO variable" flag.          */
07322 
07323    if (SH_STMT_TYPE(do_sh_idx) == Do_Iterative_Stmt) {
07324 
07325       if (IL_FLD(loop_control_il_idx) == IL_Tbl_Idx) {
07326          il_idx = IL_IDX(loop_control_il_idx);
07327 
07328          attr_idx = find_left_attr(&IL_OPND(il_idx));
07329 
07330          if (attr_idx &&
07331              AT_OBJ_CLASS(attr_idx) == Data_Obj) {
07332             ATD_LIVE_DO_VAR(attr_idx) = FALSE;
07333          }
07334       }
07335    }
07336 
07337 
07338    /* If the DO statement is in error, don't bother trying to do anything     */
07339    /* more.                                                                   */
07340 
07341    if (SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))) {
07342       goto EXIT;
07343    }
07344 
07345 
07346    if (cif_flags & MISC_RECS) {
07347       cif_loop_def_rec();
07348    }
07349 
07350 
07351    /* Generate IR depending on the type of the loop.                          */
07352 
07353    switch (SH_STMT_TYPE(do_sh_idx)) {
07354 
07355       /* -------------------------------------------------------------------- */
07356       /*                                                                      */
07357       /*               DO [label] [,] do-var = expr, expr [, expr]            */
07358       /*                                                                      */
07359       /* -------------------------------------------------------------------- */
07360 
07361       case Do_Iterative_Stmt:
07362  
07363 # ifndef _HIGH_LEVEL_DO_LOOP_FORM
07364 
07365          start_il_idx = IL_NEXT_LIST_IDX(IL_IDX(loop_control_il_idx));
07366          inc_il_idx   = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(start_il_idx));
07367 
07368          if (cif_flags & MISC_RECS) {
07369             il_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(loop_labels_il_idx));
07370          } 
07371          else {
07372             il_idx = IL_NEXT_LIST_IDX(loop_labels_il_idx);
07373          }
07374 
07375          trip_cnt_il_idx  = IL_IDX(il_idx);
07376          induc_tmp_il_idx = IL_NEXT_LIST_IDX(trip_cnt_il_idx);
07377 
07378          /* Generate the assignment statement:  induc_temp = induc_temp + 1   */
07379 
07380          NTR_IR_TBL(expr_ir_idx);
07381          IR_OPR(expr_ir_idx)           = Plus_Opr;
07382          IR_TYPE_IDX(expr_ir_idx)      = INTEGER_DEFAULT_TYPE;
07383          IR_LINE_NUM(expr_ir_idx)      = stmt_start_line;
07384          IR_COL_NUM(expr_ir_idx)       = stmt_start_col;
07385          COPY_OPND(IR_OPND_L(expr_ir_idx), IL_OPND(induc_tmp_il_idx));
07386          IR_LINE_NUM_R(expr_ir_idx)    = stmt_start_line;
07387          IR_COL_NUM_R(expr_ir_idx)     = stmt_start_col;
07388          IR_FLD_R(expr_ir_idx)         = CN_Tbl_Idx;
07389          IR_IDX_R(expr_ir_idx)         = CN_INTEGER_ONE_IDX;
07390 
07391          NTR_IR_TBL(ir_idx);
07392          IR_OPR(ir_idx)           = Asg_Opr;
07393          IR_TYPE_IDX(ir_idx)      = INTEGER_DEFAULT_TYPE;
07394          IR_LINE_NUM(ir_idx)      = stmt_start_line;
07395          IR_COL_NUM(ir_idx)       = stmt_start_col;
07396          COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(induc_tmp_il_idx));
07397          IR_LINE_NUM_R(ir_idx)    = stmt_start_line;
07398          IR_COL_NUM_R(ir_idx)     = stmt_start_col;
07399          IR_FLD_R(ir_idx)         = IR_Tbl_Idx;
07400          IR_IDX_R(ir_idx)         = expr_ir_idx;
07401 
07402          gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
07403                 FALSE, FALSE, TRUE);
07404          
07405          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
07406 
07407 
07408          /* Generate the test and branch to the top-of-loop label:            */
07409          /*   IF (induc_temp < trip_count_temp) GO TO top_lbl                 */
07410 
07411          NTR_IR_TBL(expr_ir_idx);
07412          IR_OPR(expr_ir_idx)           = Lt_Opr;
07413          IR_TYPE_IDX(expr_ir_idx)      = LOGICAL_DEFAULT_TYPE;
07414          IR_LINE_NUM(expr_ir_idx)      = stmt_start_line;
07415          IR_COL_NUM(expr_ir_idx)       = stmt_start_col;
07416          COPY_OPND(IR_OPND_L(expr_ir_idx), IL_OPND(induc_tmp_il_idx));
07417          COPY_OPND(IR_OPND_R(expr_ir_idx), IL_OPND(trip_cnt_il_idx));
07418 
07419          NTR_IR_TBL(ir_idx);
07420          IR_OPR(ir_idx)           = Br_True_Opr;
07421          IR_TYPE_IDX(ir_idx)      = LOGICAL_DEFAULT_TYPE;
07422          IR_LINE_NUM(ir_idx)      = stmt_start_line;
07423          IR_COL_NUM(ir_idx)       = stmt_start_col;
07424          IR_LINE_NUM_L(ir_idx)    = stmt_start_line;
07425          IR_COL_NUM_L(ir_idx)     = stmt_start_col;
07426          IR_FLD_L(ir_idx)         = IR_Tbl_Idx;
07427          IR_IDX_L(ir_idx)         = expr_ir_idx;
07428          IR_LINE_NUM_R(ir_idx)    = stmt_start_line;
07429          IR_COL_NUM_R(ir_idx)     = stmt_start_col;
07430          IR_FLD_R(ir_idx)         = AT_Tbl_Idx;
07431          IR_IDX_R(ir_idx)         = IL_IDX(IL_IDX(loop_labels_il_idx));
07432 
07433          AT_REFERENCED(IL_IDX(IL_IDX(loop_labels_il_idx))) = Referenced;
07434 
07435          gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 
07436                 FALSE, FALSE, TRUE);
07437 
07438          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
07439 
07440 
07441          /* Generate the assignment statement to set the terminal value of    */
07442          /* the DO-variable:                                                  */
07443          /*     DO-variable = start + trip_count * inc                        */
07444 
07445          NTR_IR_TBL(expr_ir_idx);
07446          IR_OPR(expr_ir_idx)        = Mult_Opr;
07447          IR_LINE_NUM(expr_ir_idx)   = stmt_start_line;
07448          IR_COL_NUM(expr_ir_idx)    = stmt_start_col;
07449          COPY_OPND(IR_OPND_L(expr_ir_idx), IL_OPND(trip_cnt_il_idx));
07450          COPY_OPND(IR_OPND_R(expr_ir_idx), IL_OPND(inc_il_idx));
07451 
07452          NTR_IR_TBL(ir_idx);
07453          IR_OPR(ir_idx)        = Plus_Opr;
07454          IR_LINE_NUM(ir_idx)   = stmt_start_line;
07455          IR_COL_NUM(ir_idx)    = stmt_start_col;
07456          COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(start_il_idx));
07457          IR_LINE_NUM_R(ir_idx) = stmt_start_line;
07458          IR_COL_NUM_R(ir_idx)  = stmt_start_col;
07459          IR_FLD_R(ir_idx)      = IR_Tbl_Idx;
07460          IR_IDX_R(ir_idx)      = expr_ir_idx;
07461 
07462          NTR_IR_TBL(asg_ir_idx);
07463          IR_OPR(asg_ir_idx)           = Asg_Opr;
07464          IR_LINE_NUM(asg_ir_idx)      = stmt_start_line;
07465          IR_COL_NUM(asg_ir_idx)       = stmt_start_col;
07466          COPY_OPND(IR_OPND_L(asg_ir_idx),
07467                    IL_OPND(IL_IDX(IR_IDX_R(loop_info_idx))));
07468          IR_TYPE_IDX(asg_ir_idx)      = (IR_FLD_L(asg_ir_idx) == AT_Tbl_Idx) ?
07469                                            ATD_TYPE_IDX(IR_IDX_L(asg_ir_idx)) :
07470                                            IR_TYPE_IDX(IR_IDX_L(asg_ir_idx));
07471          IR_LINE_NUM_R(asg_ir_idx)    = stmt_start_line;
07472          IR_COL_NUM_R(asg_ir_idx)     = stmt_start_col;
07473          IR_FLD_R(asg_ir_idx)         = IR_Tbl_Idx;
07474          IR_IDX_R(asg_ir_idx)         = ir_idx;
07475     
07476          gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
07477                 FALSE, FALSE, TRUE);
07478 
07479          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_ir_idx;
07480 
07481 
07482          /* Send the expression through expr_semantics to get types, etc.     */
07483          /* propagated.  However, we must be careful because the calculation  */
07484          /* could overflow.  In order to prevent the overflow message from    */
07485          /* being output by the folder, turn it off, then upon return, check  */
07486          /* to see if overflow (including too small of a negative integer     */
07487          /* value) occurred.                                                  */
07488 
07489          COPY_OPND(temp_opnd, IR_OPND_R(asg_ir_idx));
07490          expr_desc.rank         = 0;
07491          xref_state             = CIF_No_Usage_Rec;
07492          issue_overflow_msg_719 = FALSE;
07493 
07494          if (expr_semantics(&temp_opnd, &expr_desc)) {
07495             COPY_OPND(IR_OPND_R(asg_ir_idx), temp_opnd);
07496 
07497             if (OPND_FLD(temp_opnd) == CN_Tbl_Idx  &&
07498                 TYP_TYPE(CN_TYPE_IDX(OPND_IDX(temp_opnd))) == Integer) {
07499             
07500                /* Get the DO variable's linear type.  If the DO variable is   */
07501                /* not represented by an Attr, the IL had better be pointing   */
07502                /* at something like a Dv_Deref IR (pointer).                  */
07503 
07504                do_var_il_idx = IL_IDX(loop_control_il_idx);
07505 
07506                if (IL_FLD(do_var_il_idx) == AT_Tbl_Idx) {
07507                   do_var_linear_type =
07508                   (TYP_TYPE(ATD_TYPE_IDX(IL_IDX(do_var_il_idx))) == CRI_Ptr) ?
07509                      INTEGER_DEFAULT_TYPE :
07510                      TYP_LINEAR(ATD_TYPE_IDX(IL_IDX(do_var_il_idx)));
07511                }
07512                else {
07513                   do_var_linear_type =
07514                      TYP_LINEAR(IR_TYPE_IDX(IL_IDX(do_var_il_idx)));
07515                }
07516 
07517 
07518                /* The final value might be bigger than the largest value that */
07519                /* can be held in an integer with the kind type parameter of   */
07520                /* the DO variable.                                            */
07521  
07522                switch (do_var_linear_type) {
07523 
07524                   case Integer_1:
07525                      max_int_idx = cvrt_str_to_cn(HUGE_INT1_F90,
07526                                                   do_var_linear_type);
07527                      break;
07528   
07529                   case Integer_2:
07530                      max_int_idx = cvrt_str_to_cn(HUGE_INT2_F90,
07531                                                   do_var_linear_type);
07532                      break;
07533      
07534                   case Integer_4:
07535                      max_int_idx = cvrt_str_to_cn(HUGE_INT4_F90,
07536                                                   do_var_linear_type);
07537                      break;
07538      
07539                   case Integer_8:
07540                      max_int_idx = cvrt_str_to_cn(HUGE_INT8_F90,
07541                                                   do_var_linear_type);
07542                }
07543      
07544                if (compare_cn_and_value(IL_IDX(inc_il_idx), 0, Lt_Opr)) {
07545 
07546                   if (folder_driver( (char *) &CN_CONST(max_int_idx),
07547                                      do_var_linear_type,
07548                                      NULL,
07549                                      NULL_IDX,
07550                                      folded_const,
07551                                     &do_var_linear_type,
07552                                      IR_LINE_NUM(ir_idx),
07553                                      IR_COL_NUM(ir_idx),
07554                                      1,
07555                                      Uminus_Opr)) {
07556                      max_int_idx =  ntr_const_tbl(do_var_linear_type,
07557                                                   FALSE,
07558                                                   folded_const);
07559                   }
07560                }
07561 
07562                if ((compare_cn_and_value(IL_IDX(inc_il_idx), 0, Gt_Opr) &&
07563                     fold_relationals(OPND_IDX(temp_opnd),
07564                                      max_int_idx, Gt_Opr))  ||
07565                    (compare_cn_and_value(IL_IDX(inc_il_idx), 0, Lt_Opr) &&
07566                     fold_relationals(OPND_IDX(temp_opnd),
07567                                      max_int_idx, Lt_Opr))) {
07568                   PRINTMSG(SH_GLB_LINE(do_sh_idx), 1083, Warning,
07569                            SH_COL_NUM(do_sh_idx));
07570                }
07571             }
07572          }
07573          else {
07574 
07575             if (need_to_issue_719) {
07576                PRINTMSG(SH_GLB_LINE(do_sh_idx), 1083, Warning,
07577                         SH_COL_NUM(do_sh_idx));
07578                need_to_issue_719 = FALSE;
07579 
07580 
07581                /* The magnitude of the final value of the DO variable is too  */
07582                /* large for the target machine.  Hide the start value in a    */
07583                /* static temp so PDGCS won't attempt to fold the tree (and    */
07584                /* also produce a compile time overflow).                      */
07585 
07586                gen_sh(After, Data_Stmt, stmt_start_line, stmt_start_col,
07587                       FALSE, FALSE, TRUE);
07588 
07589                NTR_IR_TBL(init_ir_idx);
07590                SH_IR_IDX(curr_stmt_sh_idx) = init_ir_idx;
07591                IR_OPR(init_ir_idx)         = Init_Opr;
07592                IR_TYPE_IDX(init_ir_idx)    = TYPELESS_DEFAULT_TYPE;
07593                IR_LINE_NUM(init_ir_idx)    = stmt_start_line;
07594                IR_COL_NUM(init_ir_idx)     = stmt_start_col;
07595 
07596                tmp_idx = gen_compiler_tmp(stmt_start_line, stmt_start_col,
07597                                           Shared, TRUE);
07598                AT_SEMANTICS_DONE(tmp_idx) = TRUE;
07599                ATD_TYPE_IDX(tmp_idx)      = CN_TYPE_IDX(IL_IDX(start_il_idx));
07600                ATD_SAVED(tmp_idx)         = TRUE;
07601                ATD_DATA_INIT(tmp_idx)     = TRUE;
07602                ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
07603                
07604                IR_LINE_NUM_L(init_ir_idx) = stmt_start_line;
07605                IR_COL_NUM_L(init_ir_idx)  = stmt_start_col;
07606                IR_FLD_L(init_ir_idx)      = AT_Tbl_Idx;
07607                IR_IDX_L(init_ir_idx)      = tmp_idx;
07608 
07609                NTR_IR_LIST_TBL(il_idx);
07610                COPY_OPND(IL_OPND(il_idx), IR_OPND_L(OPND_IDX(temp_opnd)));
07611                IR_LIST_CNT_R(init_ir_idx) = 1;
07612                IR_FLD_R(init_ir_idx)      = IL_Tbl_Idx;
07613                IR_IDX_R(init_ir_idx)      = il_idx;
07614 
07615                NTR_IR_LIST_TBL(il_idx_2);
07616                IL_NEXT_LIST_IDX(il_idx)   = il_idx_2;
07617                IL_PREV_LIST_IDX(il_idx_2) = il_idx;
07618                ++IR_LIST_CNT_R(init_ir_idx);
07619                IL_FLD(il_idx_2)           = CN_Tbl_Idx;
07620                IL_IDX(il_idx_2)           = CN_INTEGER_ONE_IDX;
07621                IL_LINE_NUM(il_idx_2)      = stmt_start_line;
07622                IL_COL_NUM(il_idx_2)       = stmt_start_col;
07623                il_idx                     = il_idx_2;
07624 
07625                NTR_IR_LIST_TBL(il_idx_2);
07626                IL_NEXT_LIST_IDX(il_idx)   = il_idx_2;
07627                IL_PREV_LIST_IDX(il_idx_2) = il_idx;
07628                ++IR_LIST_CNT_R(init_ir_idx);
07629                IL_FLD(il_idx_2)           = CN_Tbl_Idx;
07630                IL_IDX(il_idx_2)           = CN_INTEGER_ZERO_IDX;
07631                IL_LINE_NUM(il_idx_2)      = stmt_start_line;
07632                IL_COL_NUM(il_idx_2)       = stmt_start_col;
07633 
07634                IR_FLD_L(OPND_IDX(temp_opnd)) = AT_Tbl_Idx;
07635                IR_IDX_L(OPND_IDX(temp_opnd)) = tmp_idx;
07636                IR_LINE_NUM_L(OPND_IDX(temp_opnd)) = stmt_start_line;
07637                IR_COL_NUM_L(OPND_IDX(temp_opnd))  = stmt_start_col;
07638             }
07639             else {
07640                PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 224, Internal, 0);
07641             }
07642          }
07643 
07644          issue_overflow_msg_719 = TRUE;
07645 
07646 # endif                                 /* End long section that is not done  */
07647                                         /* if the DO loop form is high-level. */
07648 
07649          break;
07650 
07651 
07652       /* -------------------------------------------------------------------- */
07653       /*                                                                      */
07654       /*                    DO [label] [,] WHILE (expr)                       */
07655       /*                                                                      */
07656       /* -------------------------------------------------------------------- */
07657 
07658       case Do_While_Stmt:
07659 
07660 # ifdef _HIGH_LEVEL_DO_LOOP_FORM
07661 
07662          loop_end_sh_idx = curr_stmt_sh_idx;
07663 
07664          il_idx = IL_NEXT_LIST_IDX(loop_labels_il_idx);
07665          COPY_OPND(temp_opnd, IL_OPND(il_idx));
07666 
07667          /* Insert an assignment stmt ahead of the Loop_End (CG CONTINUE) stmt*/
07668          /* that ends the DO loop to capture the loop control expression in a */
07669          /* temp.  We need to do this (just as we did at the head of the loop)*/
07670          /* for the case where the expression contains a function reference.  */
07671 
07672          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07673 
07674          gen_sh(After,
07675                 Assignment_Stmt,
07676                 SH_GLB_LINE(do_sh_idx),
07677                 SH_COL_NUM(do_sh_idx),
07678                 FALSE,                          /* Error flag.                */
07679                 FALSE,                          /* Labeled.                   */
07680                 TRUE);                          /* Compiler-generated.        */
07681 
07682          NTR_IR_TBL(asg_ir_idx);
07683          IR_OPR(asg_ir_idx)      = Asg_Opr;
07684          IR_TYPE_IDX(asg_ir_idx) = LOGICAL_DEFAULT_TYPE;
07685          COPY_OPND(IR_OPND_L(asg_ir_idx), IL_OPND(IL_IDX(loop_control_il_idx)));
07686          IR_LINE_NUM(asg_ir_idx) = IR_LINE_NUM_L(asg_ir_idx);
07687          IR_COL_NUM(asg_ir_idx)  = IR_COL_NUM_L(asg_ir_idx);
07688 
07689          SH_IR_IDX(curr_stmt_sh_idx) = asg_ir_idx;
07690 
07691          expr_desc.rank  = 0;
07692          xref_state     = CIF_No_Usage_Rec;
07693 
07694          if (! expr_semantics(&temp_opnd, &expr_desc)) {
07695             PRINTMSG(SH_GLB_LINE(loop_end_sh_idx), 224, Internal, 0);
07696          } 
07697 
07698          COPY_OPND(IR_OPND_R(asg_ir_idx), temp_opnd);
07699          curr_stmt_sh_idx = loop_end_sh_idx;
07700 
07701 # else
07702 
07703          /* Generate    IF (scalar-logical-expr) GO TO top-lbl                */
07704 
07705          gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07706                 FALSE, FALSE, TRUE);
07707 
07708          /* Send the expression through expr_semantics to get types, etc.     */
07709          /* propagated.  Temporarily reset curr_stmt_sh_idx to point at the   */
07710          /* IF SH so that any IR generated to represent the expression is     */
07711          /* inserted ahead of the IF SH.                                      */
07712 
07713          tmp_idx          = curr_stmt_sh_idx;
07714          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07715 
07716          COPY_OPND(temp_opnd, IL_OPND(IL_IDX(loop_control_il_idx)));
07717          expr_desc.rank  = 0;
07718          xref_state      = CIF_No_Usage_Rec;
07719          defer_stmt_expansion = TRUE;
07720 
07721          if (! expr_semantics(&temp_opnd, &expr_desc)) {
07722             PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 224, Internal, 0);
07723          }
07724 
07725          defer_stmt_expansion = FALSE;
07726 
07727          if (tree_produces_dealloc(&temp_opnd)) {
07728             /* make logical tmp asg */
07729             save_curr_stmt_sh_idx = curr_stmt_sh_idx;
07730             find_opnd_line_and_column(&temp_opnd,
07731                               &opnd_line, &opnd_column);
07732 
07733             GEN_COMPILER_TMP_ASG(asg_idx,
07734                                  tmp_idx2,
07735                                  TRUE,       /* Semantics done */
07736                                  opnd_line,
07737                                  opnd_column,
07738                                  expr_desc.type_idx,
07739                                  Priv);
07740 
07741             gen_sh(Before, Assignment_Stmt, opnd_line,
07742                    opnd_column, FALSE, FALSE, TRUE);
07743 
07744             curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07745 
07746             SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
07747             SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07748 
07749             process_deferred_functions(&temp_opnd);
07750             COPY_OPND(IR_OPND_R(asg_idx), temp_opnd);
07751 
07752             OPND_FLD(temp_opnd)        = AT_Tbl_Idx;
07753             OPND_IDX(temp_opnd)        = tmp_idx2;
07754             OPND_LINE_NUM(temp_opnd)   = opnd_line;
07755             OPND_COL_NUM(temp_opnd)    = opnd_column;
07756             curr_stmt_sh_idx           = save_curr_stmt_sh_idx;
07757          }
07758          else {
07759             process_deferred_functions(&temp_opnd);
07760          }
07761 
07762          NTR_IR_TBL(ir_idx);
07763          IR_OPR(ir_idx)              = Br_True_Opr;
07764          IR_TYPE_IDX(ir_idx)         = LOGICAL_DEFAULT_TYPE;
07765          IR_LINE_NUM(ir_idx)         = stmt_start_line;
07766          IR_COL_NUM(ir_idx)          = stmt_start_col;
07767          COPY_OPND(IR_OPND_L(ir_idx), temp_opnd);
07768          IR_LINE_NUM_R(ir_idx)       = stmt_start_line;
07769          IR_COL_NUM_R(ir_idx)        = stmt_start_col;
07770          IR_FLD_R(ir_idx)            = AT_Tbl_Idx;
07771          IR_IDX_R(ir_idx)            = IL_IDX(IL_IDX(loop_labels_il_idx));    
07772 
07773          SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
07774 
07775          AT_REFERENCED(IL_IDX(IL_IDX(loop_labels_il_idx))) = Referenced;
07776 
07777          curr_stmt_sh_idx = tmp_idx;
07778 
07779 # endif
07780 
07781          break;
07782 
07783 
07784       /* -------------------------------------------------------------------- */
07785       /*                                                                      */
07786       /*                             DO [label]                               */
07787       /*                                                                      */
07788       /* -------------------------------------------------------------------- */
07789 
07790       case Do_Infinite_Stmt:
07791 
07792          /* Generate a GO TO to branch back to the top-of-loop label.         */
07793 
07794          NTR_IR_TBL(ir_idx);
07795          IR_OPR(ir_idx)        = Br_Uncond_Opr;
07796          IR_TYPE_IDX(ir_idx)   = TYPELESS_DEFAULT_TYPE;
07797          IR_LINE_NUM(ir_idx)   = stmt_start_line;
07798          IR_COL_NUM(ir_idx)    = stmt_start_col;
07799          IR_LINE_NUM_R(ir_idx) = stmt_start_line;
07800          IR_COL_NUM_R(ir_idx)  = stmt_start_col;
07801          IR_FLD_R(ir_idx)      = AT_Tbl_Idx;
07802          IR_IDX_R(ir_idx)      = IL_IDX(IL_IDX(loop_labels_il_idx));
07803 
07804          AT_REFERENCED(IL_IDX(IL_IDX(loop_labels_il_idx))) = Referenced;
07805 
07806          gen_sh(Before, Goto_Stmt, stmt_start_line, stmt_start_col,
07807                 FALSE, FALSE, TRUE);
07808 
07809          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
07810 
07811    }  /* End switch on DO stmt type */
07812 
07813      
07814 EXIT:
07815 
07816    TRACE (Func_Exit, "gen_loop_end_ir", NULL);
07817 
07818    return;
07819 
07820 }  /* gen_loop_end_ir */
07821 
07822 
07823 /******************************************************************************\
07824 |*                                                                            *|
07825 |* Description:                                                               *|
07826 |*      Create the tmp array for allocate/deallocate calls.                   *|
07827 |*                                                                            *|
07828 |* Input parameters:                                                          *|
07829 |*      NONE                                                                  *|
07830 |*                                                                            *|
07831 |* Output parameters:                                                         *|
07832 |*      NONE                                                                  *|
07833 |*                                                                            *|
07834 |* Returns:                                                                   *|
07835 |*      NOTHING                                                               *|
07836 |*                                                                            *|
07837 \******************************************************************************/
07838 
07839 int     create_alloc_descriptor(int     count,
07840                                 int     line,
07841                                 int     col,
07842                                 boolean shared_heap)
07843 
07844 {
07845    int          asg_idx;
07846    int          bd_idx;
07847    int          second_cn_idx;
07848    int          list_idx;
07849    int          subscript_idx;
07850    long_type    the_constant;
07851    long_type    version[2];
07852    int          tmp_idx;
07853    int          type_idx;
07854 
07855 
07856    TRACE (Func_Entry, "create_alloc_descriptor", NULL);
07857 
07858 # if defined(GENERATE_WHIRL)
07859    type_idx = SA_INTEGER_DEFAULT_TYPE;
07860 # else
07861    type_idx = CG_INTEGER_DEFAULT_TYPE;
07862 # endif
07863 
07864    tmp_idx                      = gen_compiler_tmp(line, col, Priv, TRUE);
07865    AT_SEMANTICS_DONE(tmp_idx)   = TRUE;
07866    ATD_TYPE_IDX(tmp_idx)        = type_idx;
07867    ATD_STOR_BLK_IDX(tmp_idx)    = SCP_SB_STACK_IDX(curr_scp_idx);
07868 
07869    bd_idx                       = reserve_array_ntry(1);
07870    BD_RANK(bd_idx)              = 1;
07871    BD_ARRAY_CLASS(bd_idx)       = Explicit_Shape;
07872    BD_ARRAY_SIZE(bd_idx)        = Constant_Size;
07873    BD_LINE_NUM(bd_idx)          = line;
07874    BD_COLUMN_NUM(bd_idx)        = col;
07875    BD_RESOLVED(bd_idx)          = TRUE;
07876 
07877    the_constant                 = 1 + count;
07878 
07879 # if defined(GENERATE_WHIRL)
07880    /* the version/count item is always 64 bits */
07881    if (TYP_LINEAR(type_idx) == Integer_4) {
07882       the_constant++;
07883    }
07884 # endif
07885 
07886    BD_LEN_FLD(bd_idx)           = CN_Tbl_Idx;
07887    BD_LEN_IDX(bd_idx)           = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
07888                                               the_constant);
07889 
07890    BD_LB_FLD(bd_idx, 1)         = CN_Tbl_Idx;
07891    BD_LB_IDX(bd_idx, 1)         = CN_INTEGER_ONE_IDX;
07892 
07893    BD_UB_FLD(bd_idx, 1)         = CN_Tbl_Idx;
07894    BD_UB_IDX(bd_idx, 1)         = BD_LEN_IDX(bd_idx);
07895 
07896    BD_XT_FLD(bd_idx, 1)         = CN_Tbl_Idx;
07897    BD_XT_IDX(bd_idx, 1)         = BD_LEN_IDX(bd_idx);
07898 
07899    BD_SM_FLD(bd_idx, 1)         = CN_Tbl_Idx;
07900    BD_SM_IDX(bd_idx, 1)         = CN_INTEGER_ONE_IDX;
07901 
07902    ATD_ARRAY_IDX(tmp_idx)       = ntr_array_in_bd_tbl(bd_idx);
07903 
07904    /* fill in first word of tmp array */
07905    /* holds version and count */
07906 
07907    NTR_IR_TBL(asg_idx);
07908    IR_OPR(asg_idx)      = Asg_Opr;
07909    IR_TYPE_IDX(asg_idx) = type_idx;
07910    IR_LINE_NUM(asg_idx) = line;
07911    IR_COL_NUM(asg_idx)  = col;
07912    IR_FLD_R(asg_idx)    = CN_Tbl_Idx;
07913    IR_IDX_R(asg_idx)    = gen_alloc_header_const(type_idx,
07914                                                  count,
07915                                                  shared_heap,
07916                                                  &second_cn_idx);
07917    IR_LINE_NUM_R(asg_idx) = line;
07918    IR_COL_NUM_R(asg_idx)  = col;
07919 
07920    NTR_IR_TBL(subscript_idx);
07921    IR_OPR(subscript_idx) = Subscript_Opr;
07922    IR_TYPE_IDX(subscript_idx) = type_idx;
07923    IR_LINE_NUM(subscript_idx) = line;
07924    IR_COL_NUM(subscript_idx)  = col;
07925    IR_FLD_L(subscript_idx)    = AT_Tbl_Idx;
07926    IR_IDX_L(subscript_idx)    = tmp_idx;
07927    IR_LINE_NUM_L(subscript_idx) = line;
07928    IR_COL_NUM_L(subscript_idx)  = col;
07929 
07930    NTR_IR_LIST_TBL(list_idx);
07931    IR_FLD_R(subscript_idx)    = IL_Tbl_Idx;
07932    IR_LIST_CNT_R(subscript_idx) = 1;
07933    IR_IDX_R(subscript_idx)      = list_idx;
07934    IL_FLD(list_idx)             = CN_Tbl_Idx;
07935    IL_IDX(list_idx)             = CN_INTEGER_ONE_IDX;
07936    IL_LINE_NUM(list_idx)        = line;
07937    IL_COL_NUM(list_idx)         = col;
07938 
07939    IR_FLD_L(asg_idx)            = IR_Tbl_Idx;
07940    IR_IDX_L(asg_idx)            = subscript_idx;
07941 
07942    gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
07943    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
07944    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07945 
07946 # if defined(GENERATE_WHIRL)
07947    if (TYP_LINEAR(type_idx) == Integer_4) {
07948       NTR_IR_TBL(asg_idx);
07949       IR_OPR(asg_idx) = Asg_Opr;
07950       IR_TYPE_IDX(asg_idx) = type_idx;
07951       IR_LINE_NUM(asg_idx) = line;
07952       IR_COL_NUM(asg_idx)  = col;
07953       NTR_IR_TBL(subscript_idx);
07954       IR_OPR(subscript_idx) = Subscript_Opr;
07955       IR_TYPE_IDX(subscript_idx) = type_idx;
07956       IR_LINE_NUM(subscript_idx) = line;
07957       IR_COL_NUM(subscript_idx)  = col;
07958       IR_FLD_L(subscript_idx)    = AT_Tbl_Idx;
07959       IR_IDX_L(subscript_idx)    = tmp_idx;
07960       IR_LINE_NUM_L(subscript_idx) = line;
07961       IR_COL_NUM_L(subscript_idx)  = col;
07962 
07963       NTR_IR_LIST_TBL(list_idx);
07964       IR_FLD_R(subscript_idx)      = IL_Tbl_Idx;
07965       IR_LIST_CNT_R(subscript_idx) = 1;
07966       IR_IDX_R(subscript_idx)      = list_idx;
07967       IL_FLD(list_idx)             = CN_Tbl_Idx;
07968 
07969       IL_IDX(list_idx)             = CN_INTEGER_TWO_IDX;
07970       IL_LINE_NUM(list_idx)        = line;
07971       IL_COL_NUM(list_idx)         = col;
07972 
07973       IR_FLD_L(asg_idx)            = IR_Tbl_Idx;
07974       IR_IDX_L(asg_idx)            = subscript_idx;
07975 
07976 # ifdef _DEBUG
07977       if (second_cn_idx == NULL_IDX) {
07978          PRINTMSG(line, 626, Internal, col,
07979                   "second_cn_idx", "create_alloc_descriptor");
07980       }
07981 # endif
07982 
07983       IR_FLD_R(asg_idx)            = CN_Tbl_Idx;
07984       IR_IDX_R(asg_idx)            = second_cn_idx;
07985       IR_LINE_NUM_R(asg_idx) = line;
07986       IR_COL_NUM_R(asg_idx)  = col;
07987 
07988       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
07989       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
07990       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07991    }
07992 # endif
07993 
07994 
07995    TRACE (Func_Exit, "create_alloc_descriptor", NULL);
07996 
07997    return(tmp_idx);
07998 
07999 }  /* create_alloc_descriptor */
08000 
08001 /******************************************************************************\
08002 |*                                                                            *|
08003 |* Description:                                                               *|
08004 |*      <description>                                                         *|
08005 |*                                                                            *|
08006 |* Input parameters:                                                          *|
08007 |*      NONE                                                                  *|
08008 |*                                                                            *|
08009 |* Output parameters:                                                         *|
08010 |*      NONE                                                                  *|
08011 |*                                                                            *|
08012 |* Returns:                                                                   *|
08013 |*      NOTHING                                                               *|
08014 |*                                                                            *|
08015 \******************************************************************************/
08016 
08017 int gen_alloc_header_const(int          type_idx,
08018                            int          count,
08019                            boolean      shared_heap,
08020                            int          *second_cn_idx)
08021 
08022 {
08023    int          cn_idx;
08024    long_type    version[2];
08025 
08026 
08027 typedef struct AllocHead {
08028         unsigned int    version :8;     /* contains ALLOC_VERSION */
08029         unsigned int            :24;    /* unused */
08030         unsigned int            :15;     /* unused */
08031         unsigned int    imalloc :1;     /* call special malloc */
08032         unsigned int    icount  :16;    /* size of struct alloclist in */
08033                                         /* words. */
08034 } AllocHeadType;
08035 
08036    AllocHeadType        *allochdr;
08037 
08038    TRACE (Func_Entry, "gen_alloc_header_const", NULL);
08039 
08040    /* make sure count is 16 bits */
08041    count = count & 0xFFFF;
08042 
08043    version[0] = 0;
08044    version[1] = 0;
08045 
08046    allochdr = (AllocHeadType *)version;
08047    
08048    allochdr->version = 1;
08049    allochdr->icount = count;
08050 
08051    if (shared_heap) {
08052       allochdr->imalloc = 1;
08053    }
08054 
08055 
08056    if (TYP_LINEAR(type_idx) == Integer_4) {
08057       cn_idx = ntr_const_tbl(type_idx,
08058                              FALSE,
08059                              version);
08060 
08061       *second_cn_idx = ntr_const_tbl(type_idx,
08062                                      FALSE,
08063                                      &(version[1]));
08064    }
08065    else {
08066       *second_cn_idx = NULL_IDX;
08067       cn_idx = ntr_const_tbl(type_idx,
08068                              FALSE,
08069                              version);
08070    }
08071 
08072    TRACE (Func_Exit, "gen_alloc_header_const", NULL);
08073 
08074    return(cn_idx);
08075 
08076 }  /* gen_alloc_header_const */
08077 
08078 /******************************************************************************\
08079 |*                                                                            *|
08080 |* Description:                                                               *|
08081 |*      Create the tmp array for allocate/deallocate calls.                   *|
08082 |*                                                                            *|
08083 |* Input parameters:                                                          *|
08084 |*      NONE                                                                  *|
08085 |*                                                                            *|
08086 |* Output parameters:                                                         *|
08087 |*      NONE                                                                  *|
08088 |*                                                                            *|
08089 |* Returns:                                                                   *|
08090 |*      NOTHING                                                               *|
08091 |*                                                                            *|
08092 \******************************************************************************/
08093 
08094 void    set_directives_on_label(int     label_attr)
08095 
08096 {
08097    int          idx;
08098    int          il_idx;
08099    int          il_idx2;
08100    int          new_idx;
08101    int          save_free_list;
08102 
08103 
08104    TRACE (Func_Entry, "set_directives_on_label", NULL);
08105 
08106    ATL_ALIGN(label_attr)        = cdir_switches.align;
08107    ATL_BL(label_attr)           = cdir_switches.bl;           /* Toggle */
08108    ATL_CNCALL(label_attr)       = cdir_switches.cncall;
08109    ATL_CONCURRENT(label_attr)   = cdir_switches.concurrent;
08110    ATL_IVDEP(label_attr)        = cdir_switches.ivdep;
08111    ATL_MAXCPUS(label_attr)      = cdir_switches.maxcpus;
08112    ATL_NEXTSCALAR(label_attr)   = cdir_switches.nextscalar;
08113    ATL_NOVSEARCH(label_attr)    = ! cdir_switches.vsearch;    /* Toggle */
08114    ATL_PERMUTATION(label_attr)  = cdir_switches.permutation;
08115    ATL_PREFERSTREAM(label_attr) = cdir_switches.preferstream;
08116    ATL_PREFERSTREAM_NOCINV(label_attr)  = cdir_switches.preferstream_nocinv;
08117    ATL_PREFERTASK(label_attr)   = cdir_switches.prefertask;
08118    ATL_PREFERVECTOR(label_attr) = cdir_switches.prefervector;
08119    ATL_NORECURRENCE(label_attr) = ! cdir_switches.recurrence; /* Toggle */
08120    ATL_SHORTLOOP(label_attr)    = cdir_switches.shortloop;
08121    ATL_SHORTLOOP128(label_attr) = cdir_switches.shortloop128;
08122    ATL_SPLIT(label_attr)        = cdir_switches.split;
08123 
08124    ATL_AGGRESSIVEINNERLOOPFISSION(label_attr)   = 
08125                                   cdir_switches.aggressiveinnerloopfission;
08126    ATL_FISSIONABLE(label_attr)  = cdir_switches.fissionable;
08127    ATL_FUSABLE(label_attr)      = cdir_switches.fusable;
08128    ATL_FUSION(label_attr)       = opt_flags.fusion;
08129    ATL_NOFISSION(label_attr)    = cdir_switches.nofission;
08130    ATL_NOFUSION(label_attr)     = cdir_switches.nofusion;
08131    ATL_NOINTERCHANGE(label_attr)= cdir_switches.nointerchange;
08132    ATL_NOBLOCKING(label_attr)   = cdir_switches.noblocking;
08133 
08134    if (! cdir_switches.vector) {
08135       ATL_NOVECTOR(label_attr)  = TRUE;
08136    }
08137 
08138    if (cdir_switches.stream) {
08139       ATL_STREAM(label_attr)    = TRUE;
08140    }
08141 
08142    if (cdir_switches.pattern) {
08143       ATL_PATTERN(label_attr)   = TRUE;
08144    }
08145 
08146 # if defined(GENERATE_WHIRL)
08147    if (cdir_switches.notask_region) {
08148       ATL_NOTASK(label_attr)    = TRUE;
08149    }
08150 # else
08151    if (! cdir_switches.task) {
08152       ATL_NOTASK(label_attr)    = TRUE;
08153    }
08154 # endif
08155 
08156    /* Insure that these directive lists are consecutive. */
08157 
08158    /* ATL_DIRECTIVE_LIST is set as follows:              */
08159    /* ATL_DIRECTIVE_LIST holds an il_idx which describes */
08160    /* the subsequent dir list.  The list is accessed     */
08161    /* by the directive_label_type enum.   The first IL   */
08162    /* entry is waht holds the size of the list.          */
08163 
08164    save_free_list                       = IL_NEXT_LIST_IDX(NULL_IDX);
08165    IL_NEXT_LIST_IDX(NULL_IDX)           = NULL_IDX;
08166    NTR_IR_LIST_TBL(il_idx);
08167    ATL_DIRECTIVE_LIST(label_attr)       = il_idx;
08168    IL_LIST_CNT(il_idx)                  = Num_Dir_On_List;
08169    IL_FLD(il_idx)                       = IL_Tbl_Idx;
08170    NTR_IR_LIST_TBL(new_idx);
08171    IL_IDX(il_idx)                       = new_idx;  /* List start */
08172    IL_LINE_NUM(new_idx)                 = AT_DEF_LINE(label_attr);
08173    IL_COL_NUM(new_idx)                  = AT_DEF_COLUMN(label_attr);
08174    il_idx                               = new_idx;
08175 
08176    for (idx = 1; idx < Num_Dir_On_List; idx++) {
08177       NTR_IR_LIST_TBL(new_idx);
08178       IL_NEXT_LIST_IDX(il_idx)  = new_idx;
08179       IL_PREV_LIST_IDX(new_idx) = il_idx;
08180       IL_LINE_NUM(new_idx)      = AT_DEF_LINE(label_attr);
08181       IL_COL_NUM(new_idx)       = AT_DEF_COLUMN(label_attr);
08182       il_idx                    = new_idx;
08183    }
08184 
08185    IL_NEXT_LIST_IDX(NULL_IDX)   = save_free_list;
08186 
08187    if (cdir_switches.safevl_idx != NULL_IDX) {
08188       il_idx            = IL_IDX(ATL_DIRECTIVE_LIST(label_attr))+Safevl_Dir_Idx;
08189       IL_FLD(il_idx)    = CN_Tbl_Idx;
08190       IL_IDX(il_idx)    = cdir_switches.safevl_idx;
08191    }
08192 
08193    if (cdir_switches.concurrent_idx != NULL_IDX) {
08194       il_idx            = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) +
08195                                  Concurrent_Dir_Idx;
08196       IL_FLD(il_idx)    = CN_Tbl_Idx;
08197       IL_IDX(il_idx)    = cdir_switches.concurrent_idx;
08198    }
08199 
08200    if (cdir_switches.maxcpus) {
08201       il_idx    = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) + Maxcpus_Dir_Idx;
08202       COPY_OPND(IL_OPND(il_idx), cdir_switches.maxcpus_opnd);
08203    }
08204 
08205    if (cdir_switches.mark) {
08206       il_idx            = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) + Mark_Dir_Idx;
08207       IL_FLD(il_idx)    = CN_Tbl_Idx;
08208       IL_IDX(il_idx)    = (cdir_switches.mark_dir_idx == NULL_IDX) ?
08209                                          cdir_switches.mark_cmdline_idx :
08210                                          cdir_switches.mark_dir_idx;
08211    }
08212       
08213    if (cdir_switches.cache_bypass_ir_idx != NULL_IDX) {
08214       il_idx    = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) + Cache_Bypass_Dir_Idx;
08215       IL_FLD(il_idx)      = IR_FLD_L(cdir_switches.cache_bypass_ir_idx);
08216       IL_IDX(il_idx)      = IR_IDX_L(cdir_switches.cache_bypass_ir_idx);
08217       IL_LIST_CNT(il_idx) = IR_LIST_CNT_L(cdir_switches.cache_bypass_ir_idx);
08218    }
08219 
08220    /* ATL_UNROLL_DIR is set TRUE if either a UNROLL directive or a */
08221    /* NOUNROLL directive is seen for this loop.                    */
08222 
08223    ATL_UNROLL_DIR(label_attr)   = cdir_switches.unroll_dir ||
08224                                   (opt_flags.unroll_lvl == Unroll_Lvl_2);
08225                                         
08226 
08227    if (cdir_switches.unroll_count_idx != NULL_IDX) {
08228       il_idx    = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) + Unroll_Dir_Idx;
08229       IL_FLD(il_idx)    = CN_Tbl_Idx;
08230       IL_IDX(il_idx)    = cdir_switches.unroll_count_idx;
08231    }
08232 
08233    /* 0 means optimizer sets unroll count.  1 means no unrolling.  If  */
08234    /* the default level is set to 2, then automatic unrolling happens. */
08235    /* If the default level is set to 1, we only unroll those loops     */
08236    /* for which the user specifies the UNROLL directive.               */
08237 
08238    cdir_switches.unroll_dir       = FALSE;
08239    cdir_switches.unroll_count_idx = (opt_flags.unroll_lvl == Unroll_Lvl_2) ?
08240                                      CN_INTEGER_ZERO_IDX : CN_INTEGER_ONE_IDX;
08241 
08242    if (cdir_switches.interchange_count > 0) {
08243       il_idx    = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) + Interchange_Dir_Idx;
08244       IL_FLD(il_idx)    = CN_Tbl_Idx;
08245       IL_IDX(il_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08246                                       cdir_switches.interchange_group);
08247 
08248       il_idx            = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) + 
08249                                                Interchange_Level_Dir_Idx;
08250       IL_FLD(il_idx)    = CN_Tbl_Idx;
08251       IL_IDX(il_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08252                                       cdir_switches.interchange_level);
08253       --cdir_switches.interchange_count;
08254    }
08255 
08256    if (cdir_switches.blockable_count > 0) {
08257       il_idx    = IL_IDX(ATL_DIRECTIVE_LIST(label_attr)) + Blockable_Dir_Idx;
08258       IL_FLD(il_idx)    = CN_Tbl_Idx;
08259       IL_IDX(il_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08260                                       cdir_switches.blockable_group);
08261       --cdir_switches.blockable_count;
08262    }
08263       
08264    /* reset cdir switches for one loop only directives. */
08265 
08266    clear_cdir_switches();
08267 
08268    TRACE (Func_Exit, "set_directives_on_label", NULL);
08269 
08270    return;
08271 
08272 }  /* set_directives_on_label */
08273 
08274 /******************************************************************************\
08275 |*                                                                            *|
08276 |* Description:                                                               *|
08277 |*      <description>                                                         *|
08278 |*                                                                            *|
08279 |* Input parameters:                                                          *|
08280 |*      NONE                                                                  *|
08281 |*                                                                            *|
08282 |* Output parameters:                                                         *|
08283 |*      NONE                                                                  *|
08284 |*                                                                            *|
08285 |* Returns:                                                                   *|
08286 |*      NOTHING                                                               *|
08287 |*                                                                            *|
08288 \******************************************************************************/
08289 
08290 static void clear_cdir_switches(void)
08291 
08292 {
08293 
08294 
08295    TRACE (Func_Entry, "clear_cdir_switches", NULL);
08296 
08297    /* reset cdir switches for one loop only directives. */
08298 
08299    cdir_switches.align                  = FALSE;
08300    cdir_switches.cache_bypass_ir_idx    = NULL_IDX;
08301    cdir_switches.concurrent             = FALSE;
08302    cdir_switches.concurrent_idx         = NULL_IDX;
08303    cdir_switches.cncall                 = FALSE;
08304    cdir_switches.ivdep                  = FALSE;
08305    cdir_switches.maxcpus                = FALSE;
08306    cdir_switches.nextscalar             = FALSE;
08307    cdir_switches.permutation            = FALSE;
08308    cdir_switches.preferstream           = FALSE;
08309    cdir_switches.preferstream_nocinv    = FALSE;
08310    cdir_switches.prefertask             = FALSE;
08311    cdir_switches.prefervector           = FALSE;
08312    cdir_switches.safevl_idx             = const_safevl_idx;
08313    cdir_switches.shortloop              = FALSE;
08314    cdir_switches.shortloop128           = FALSE;
08315    cdir_switches.split                  = (opt_flags.split_lvl == Split_Lvl_2);
08316 
08317    cdir_switches.aggressiveinnerloopfission     = FALSE;
08318    cdir_switches.fissionable                    = FALSE;
08319    cdir_switches.fusable                        = FALSE;
08320    cdir_switches.nofission                      = FALSE;
08321    cdir_switches.nofusion                       = FALSE;
08322    cdir_switches.nointerchange                  = opt_flags.nointerchange;
08323    cdir_switches.noblocking                     = FALSE;
08324 
08325    cdir_switches.doacross_sh_idx                = NULL_IDX;
08326    cdir_switches.paralleldo_sh_idx              = NULL_IDX;
08327    cdir_switches.pdo_sh_idx                     = NULL_IDX;
08328 
08329 
08330    TRACE (Func_Exit, "clear_cdir_switches", NULL);
08331 
08332    return;
08333 
08334 }  /* clear_cdir_switches */
08335 
08336 /******************************************************************************\
08337 |*                                                                            *|
08338 |* Description:                                                               *|
08339 |*      Short circuit high level if stmts if a Present_Opr is present.        *|
08340 |*                                                                            *|
08341 |* Input parameters:                                                          *|
08342 |*      NONE                                                                  *|
08343 |*                                                                            *|
08344 |* Output parameters:                                                         *|
08345 |*      NONE                                                                  *|
08346 |*                                                                            *|
08347 |* Returns:                                                                   *|
08348 |*      NOTHING                                                               *|
08349 |*                                                                            *|
08350 \******************************************************************************/
08351 
08352 static void short_circuit_high_level_if(void)
08353 
08354 {
08355    opnd_type    cn_opnd;
08356    int          col;
08357    int          cond_ir_idx;
08358    opnd_type    cond_opnd;
08359    opnd_type    first_opnd;
08360    int          if_idx;
08361    int          ir_idx;
08362    int          line;
08363    int          not_cnt;
08364    int          not_idx;
08365    opnd_type    opnd;
08366    int          save_curr_stmt_sh_idx;
08367    opnd_type    second_opnd;
08368    long_type    the_constant[MAX_WORDS_FOR_INTEGER];
08369    int          tmp_idx;
08370 
08371 
08372    TRACE (Func_Entry, "short_circuit_high_level_if", NULL);
08373 
08374 # ifdef _DEBUG
08375    if (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) != If_Opr &&
08376        IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) != Br_True_Opr) {
08377       PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 626, Internal,
08378                SH_COL_NUM(curr_stmt_sh_idx),
08379                "If_Opr", "short_circuit_high_level_if");
08380    }
08381 # endif
08382 
08383    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
08384 
08385    cond_ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
08386 
08387    COPY_OPND(cond_opnd, IR_OPND_L(cond_ir_idx));
08388    COPY_OPND(opnd, IR_OPND_L(cond_ir_idx));
08389 
08390    find_opnd_line_and_column(&cond_opnd, &line, &col);
08391 
08392    not_cnt = 0;
08393 
08394    while (OPND_FLD(opnd) == IR_Tbl_Idx &&
08395           (IR_OPR(OPND_IDX(opnd)) == Not_Opr ||
08396            IR_OPR(OPND_IDX(opnd)) == Paren_Opr)) {
08397 
08398       if (IR_OPR(OPND_IDX(opnd)) == Not_Opr) {
08399          not_cnt++;
08400       }
08401 
08402       COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
08403    }
08404 
08405    if (not_cnt%2 == 0) {
08406       COPY_OPND(cond_opnd, opnd);
08407       COPY_OPND(IR_OPND_L(cond_ir_idx), cond_opnd);
08408    }
08409    else if (not_cnt > 1) {
08410       NTR_IR_TBL(not_idx);
08411       IR_OPR(not_idx) = Not_Opr;
08412       IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE;
08413       IR_LINE_NUM(not_idx) = line;
08414       IR_COL_NUM(not_idx)  = col;
08415       COPY_OPND(IR_OPND_L(not_idx), opnd);
08416       OPND_FLD(cond_opnd) = IR_Tbl_Idx;
08417       OPND_IDX(cond_opnd) = not_idx;
08418       COPY_OPND(IR_OPND_L(cond_ir_idx), cond_opnd);
08419    }
08420 
08421    if (OPND_FLD(opnd) == IR_Tbl_Idx &&
08422        (IR_OPR(OPND_IDX(opnd)) == And_Opr ||
08423         IR_OPR(OPND_IDX(opnd)) == Or_Opr) &&
08424        (IR_SHORT_CIRCUIT_L(OPND_IDX(opnd)) ||
08425         IR_SHORT_CIRCUIT_R(OPND_IDX(opnd)) ||
08426         opt_flags.short_circuit_lvl == Short_Circuit_Left_Right)) {
08427 
08428       if (not_cnt%2 == 0) {
08429          /* nots cancel out */
08430          /* intentionally blank */
08431       }
08432       else {
08433          /* demorgan it */
08434 
08435          /* switch and/or */
08436 
08437          if (IR_OPR(OPND_IDX(opnd)) == And_Opr) {
08438             IR_OPR(OPND_IDX(opnd)) = Or_Opr;
08439          }
08440          else {
08441             IR_OPR(OPND_IDX(opnd)) = And_Opr;
08442          }
08443 
08444          /* negate the opnds */
08445 
08446          NTR_IR_TBL(not_idx);
08447          IR_OPR(not_idx) = Not_Opr;
08448          IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE;
08449          IR_LINE_NUM(not_idx) = line;
08450          IR_COL_NUM(not_idx)  = col;
08451          COPY_OPND(IR_OPND_L(not_idx), IR_OPND_L(OPND_IDX(opnd)));
08452          IR_FLD_L(OPND_IDX(opnd)) = IR_Tbl_Idx;
08453          IR_IDX_L(OPND_IDX(opnd)) = not_idx;
08454 
08455          NTR_IR_TBL(not_idx);
08456          IR_OPR(not_idx) = Not_Opr;
08457          IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE;
08458          IR_LINE_NUM(not_idx) = line;
08459          IR_COL_NUM(not_idx)  = col;
08460          COPY_OPND(IR_OPND_L(not_idx), IR_OPND_R(OPND_IDX(opnd)));
08461          IR_FLD_R(OPND_IDX(opnd)) = IR_Tbl_Idx;
08462          IR_IDX_R(OPND_IDX(opnd)) = not_idx;
08463       }
08464 
08465       /* now opnd holds the top of the conditional tree */
08466 
08467       GEN_COMPILER_TMP_ASG(ir_idx,
08468                            tmp_idx,
08469                            TRUE,       /* Semantics done */
08470                            line,
08471                            col,
08472                            LOGICAL_DEFAULT_TYPE,
08473                            Priv);
08474 
08475       gen_sh(Before, Assignment_Stmt, line, col,
08476              FALSE, FALSE, TRUE);
08477       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
08478       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08479 
08480       if (opt_flags.short_circuit_lvl == Short_Circuit_Functions &&
08481           IR_SHORT_CIRCUIT_L(OPND_IDX(opnd)) &&
08482           ! IR_SHORT_CIRCUIT_R(OPND_IDX(opnd))) {
08483 
08484          COPY_OPND(first_opnd, IR_OPND_R(OPND_IDX(opnd)));
08485          COPY_OPND(second_opnd, IR_OPND_L(OPND_IDX(opnd)));
08486       }
08487       else {
08488          COPY_OPND(first_opnd, IR_OPND_L(OPND_IDX(opnd)));
08489          COPY_OPND(second_opnd, IR_OPND_R(OPND_IDX(opnd)));
08490       }
08491 
08492       if (IR_OPR(OPND_IDX(opnd)) == And_Opr) {
08493          IR_FLD_R(ir_idx) = CN_Tbl_Idx;
08494          IR_IDX_R(ir_idx) = set_up_logical_constant(the_constant, 
08495                                                     CG_LOGICAL_DEFAULT_TYPE, 
08496                                                     TRUE_VALUE,
08497                                                     TRUE);
08498          IR_LINE_NUM_R(ir_idx) = line;
08499          IR_COL_NUM_R(ir_idx) = col;
08500 
08501          OPND_FLD(cn_opnd) = CN_Tbl_Idx;
08502          OPND_LINE_NUM(cn_opnd) = line;
08503          OPND_COL_NUM(cn_opnd) = col;
08504          OPND_IDX(cn_opnd) = set_up_logical_constant(the_constant, 
08505                                                      CG_LOGICAL_DEFAULT_TYPE, 
08506                                                      FALSE_VALUE,
08507                                                      TRUE);
08508          /* negate the opnds */
08509 
08510          NTR_IR_TBL(not_idx);
08511          IR_OPR(not_idx) = Not_Opr;
08512          IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE;
08513          IR_LINE_NUM(not_idx) = line;
08514          IR_COL_NUM(not_idx)  = col;
08515          COPY_OPND(IR_OPND_L(not_idx), first_opnd);
08516          OPND_FLD(first_opnd) = IR_Tbl_Idx;
08517          OPND_IDX(first_opnd) = not_idx;
08518 
08519          NTR_IR_TBL(not_idx);
08520          IR_OPR(not_idx) = Not_Opr;
08521          IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE;
08522          IR_LINE_NUM(not_idx) = line;
08523          IR_COL_NUM(not_idx)  = col;
08524          COPY_OPND(IR_OPND_L(not_idx), second_opnd);
08525          OPND_FLD(second_opnd) = IR_Tbl_Idx;
08526          OPND_IDX(second_opnd) = not_idx;
08527 
08528       }
08529       else {
08530          IR_FLD_R(ir_idx) = CN_Tbl_Idx;
08531          IR_IDX_R(ir_idx) = set_up_logical_constant(the_constant, 
08532                                                     CG_LOGICAL_DEFAULT_TYPE, 
08533                                                     FALSE_VALUE,
08534                                                     TRUE);
08535          IR_LINE_NUM_R(ir_idx) = line;
08536          IR_COL_NUM_R(ir_idx) = col;
08537 
08538          OPND_FLD(cn_opnd) = CN_Tbl_Idx;
08539          OPND_LINE_NUM(cn_opnd) = line;
08540          OPND_COL_NUM(cn_opnd) = col;
08541          OPND_IDX(cn_opnd) = set_up_logical_constant(the_constant, 
08542                                                      CG_LOGICAL_DEFAULT_TYPE, 
08543                                                      TRUE_VALUE,
08544                                                      TRUE);
08545       }
08546 
08547       /* gen IF (first_opnd) Before */
08548 
08549       NTR_IR_TBL(if_idx);
08550       IR_OPR(if_idx) = If_Opr;
08551       IR_TYPE_IDX(if_idx) = LOGICAL_DEFAULT_TYPE;
08552       IR_LINE_NUM(if_idx) = line;
08553       IR_COL_NUM(if_idx) = col;
08554 
08555       COPY_OPND(IR_OPND_L(if_idx), first_opnd);
08556 
08557       gen_sh(Before, If_Stmt, line, col,
08558              FALSE, FALSE, TRUE);
08559       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
08560       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08561 
08562       /* short circuit IF Before */
08563 
08564       save_curr_stmt_sh_idx = curr_stmt_sh_idx;
08565       curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
08566 
08567       short_circuit_high_level_if();
08568 
08569       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
08570 
08571       /* gen temp = cn_opnd Before */
08572 
08573       NTR_IR_TBL(if_idx);
08574       IR_OPR(if_idx) = Asg_Opr;
08575       IR_TYPE_IDX(if_idx) = LOGICAL_DEFAULT_TYPE;
08576       IR_LINE_NUM(if_idx) = line;
08577       IR_COL_NUM(if_idx) = col;
08578 
08579       IR_FLD_L(if_idx) = AT_Tbl_Idx;
08580       IR_IDX_L(if_idx) = tmp_idx;
08581       IR_LINE_NUM_L(if_idx) = line;
08582       IR_COL_NUM_L(if_idx) = col;
08583 
08584       COPY_OPND(IR_OPND_R(if_idx), cn_opnd);
08585 
08586       gen_sh(Before, Assignment_Stmt, line, col,
08587              FALSE, FALSE, TRUE);
08588       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
08589       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08590 
08591       /* gen ELSE stmt Before */
08592 
08593       NTR_IR_TBL(if_idx);
08594       IR_OPR(if_idx) = Else_Opr;
08595       IR_TYPE_IDX(if_idx) = LOGICAL_DEFAULT_TYPE;
08596       IR_LINE_NUM(if_idx) = line;
08597       IR_COL_NUM(if_idx) = col;
08598 
08599       gen_sh(Before, Else_Stmt, line, col,
08600              FALSE, FALSE, TRUE);
08601       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
08602       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08603 
08604       /* gen IF (second_opnd) Before */
08605 
08606       NTR_IR_TBL(if_idx);
08607       IR_OPR(if_idx) = If_Opr;
08608       IR_TYPE_IDX(if_idx) = LOGICAL_DEFAULT_TYPE;
08609       IR_LINE_NUM(if_idx) = line;
08610       IR_COL_NUM(if_idx) = col;
08611 
08612       COPY_OPND(IR_OPND_L(if_idx), second_opnd);
08613 
08614       gen_sh(Before, If_Stmt, line, col,
08615              FALSE, FALSE, TRUE);
08616       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
08617       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08618 
08619       /* short circuit IF Before */
08620 
08621       save_curr_stmt_sh_idx = curr_stmt_sh_idx;
08622       curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
08623 
08624       short_circuit_high_level_if();
08625 
08626       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
08627 
08628       /* gen temp = cn_opnd Before */
08629 
08630       NTR_IR_TBL(if_idx);
08631       IR_OPR(if_idx) = Asg_Opr;
08632       IR_TYPE_IDX(if_idx) = LOGICAL_DEFAULT_TYPE;
08633       IR_LINE_NUM(if_idx) = line;
08634       IR_COL_NUM(if_idx) = col;
08635 
08636       IR_FLD_L(if_idx) = AT_Tbl_Idx;
08637       IR_IDX_L(if_idx) = tmp_idx;
08638       IR_LINE_NUM_L(if_idx) = line;
08639       IR_COL_NUM_L(if_idx) = col;
08640 
08641       COPY_OPND(IR_OPND_R(if_idx), cn_opnd);
08642 
08643       gen_sh(Before, Assignment_Stmt, line, col,
08644              FALSE, FALSE, TRUE);
08645       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
08646       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08647 
08648       /* gen ENDIF stmt Before */
08649 
08650       NTR_IR_TBL(if_idx);
08651       IR_OPR(if_idx) = Endif_Opr;
08652       IR_TYPE_IDX(if_idx) = LOGICAL_DEFAULT_TYPE;
08653       IR_LINE_NUM(if_idx) = line;
08654       IR_COL_NUM(if_idx) = col;
08655 
08656       gen_sh(Before, End_If_Stmt, line, col,
08657              FALSE, FALSE, TRUE);
08658       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
08659       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08660 
08661       /* gen ENDIF stmt Before */
08662 
08663       NTR_IR_TBL(if_idx);
08664       IR_OPR(if_idx) = Endif_Opr;
08665       IR_TYPE_IDX(if_idx) = LOGICAL_DEFAULT_TYPE;
08666       IR_LINE_NUM(if_idx) = line;
08667       IR_COL_NUM(if_idx) = col;
08668 
08669       gen_sh(Before, End_If_Stmt, line, col,
08670              FALSE, FALSE, TRUE);
08671       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
08672       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08673 
08674       /* replace original condition with temp */
08675 
08676       OPND_FLD(cond_opnd) = AT_Tbl_Idx;
08677       OPND_IDX(cond_opnd) = tmp_idx;
08678       OPND_LINE_NUM(cond_opnd) = line;
08679       OPND_COL_NUM(cond_opnd) = col;
08680 
08681       COPY_OPND(IR_OPND_L(cond_ir_idx), cond_opnd);
08682    }
08683    else {
08684 
08685       if (tree_produces_dealloc(&cond_opnd) ||
08686           io_item_must_flatten) {
08687 
08688          GEN_COMPILER_TMP_ASG(ir_idx,
08689                               tmp_idx,
08690                               TRUE,       /* Semantics done */
08691                               line,
08692                               col,
08693                               LOGICAL_DEFAULT_TYPE,
08694                               Priv);
08695 
08696          gen_sh(Before, Assignment_Stmt, line, col,
08697                 FALSE, FALSE, TRUE);
08698 
08699          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
08700 
08701          SH_IR_IDX(curr_stmt_sh_idx)     = ir_idx;
08702          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
08703 
08704          process_deferred_functions(&cond_opnd);
08705          COPY_OPND(IR_OPND_R(ir_idx), cond_opnd);
08706 
08707          IR_FLD_L(cond_ir_idx)      = AT_Tbl_Idx;
08708          IR_IDX_L(cond_ir_idx)      = tmp_idx;
08709          IR_LINE_NUM_L(cond_ir_idx) = line;
08710          IR_COL_NUM_L(cond_ir_idx)  = col;
08711       }
08712       else {
08713          process_deferred_functions(&cond_opnd);
08714          COPY_OPND(IR_OPND_L(cond_ir_idx), cond_opnd);
08715       }
08716    }
08717 
08718    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
08719    TRACE (Func_Exit, "short_circuit_high_level_if", NULL);
08720 
08721    return;
08722 
08723 }  /* short_circuit_high_level_if */
08724 
08725 /******************************************************************************\
08726 |*                                                                            *|
08727 |* Description:                                                               *|
08728 |*      <description>                                                         *|
08729 |*                                                                            *|
08730 |* Input parameters:                                                          *|
08731 |*      NONE                                                                  *|
08732 |*                                                                            *|
08733 |* Output parameters:                                                         *|
08734 |*      NONE                                                                  *|
08735 |*                                                                            *|
08736 |* Returns:                                                                   *|
08737 |*      NOTHING                                                               *|
08738 |*                                                                            *|
08739 \******************************************************************************/
08740 
08741 static boolean check_stat_variable(int          ir_idx,
08742                                    opnd_type    *stat_opnd,
08743                                    int          stat_list_idx)
08744 
08745 {
08746    int                  attr_idx;
08747    int                  col;
08748    expr_arg_type        exp_desc;
08749    int                  line;
08750    int                  loc_idx;
08751    boolean              ok = TRUE;
08752    opnd_type            opnd;
08753    int                  stat_col;
08754    int                  stat_line;
08755 
08756 # if defined(_TARGET_OS_MAX) || defined(_TARGET_OS_SOLARIS) || \
08757      (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
08758    int                  asg_idx;
08759    int                  tmp_idx;
08760 # endif
08761 
08762 
08763    TRACE (Func_Entry, "check_stat_variable", NULL);
08764 
08765    /* check for call_opr before expr_semantics */
08766    if (IR_FLD_R(ir_idx) == IR_Tbl_Idx &&
08767        IR_OPR(IR_IDX_R(ir_idx)) == Call_Opr) {
08768 
08769       /* error .. must catch here to stop misleading messages */
08770       PRINTMSG(IR_LINE_NUM_L(IR_IDX_R(ir_idx)), 202, Error,
08771                IR_COL_NUM_L(IR_IDX_R(ir_idx)));
08772       ok = FALSE;
08773    }
08774    else {
08775       COPY_OPND(opnd, IR_OPND_R(ir_idx));
08776       exp_desc.rank = 0;
08777       xref_state    = CIF_Symbol_Modification;
08778       ok = expr_semantics(&opnd, &exp_desc);
08779       COPY_OPND(IR_OPND_R(ir_idx), opnd);
08780 
08781       attr_idx = find_base_attr(&opnd, &stat_line, &stat_col);
08782 
08783       if (attr_idx               == NULL_IDX   ||
08784           AT_OBJ_CLASS(attr_idx) != Data_Obj   ||
08785           exp_desc.constant                    ||
08786           exp_desc.type          != Integer    ||
08787           exp_desc.rank          != 0) {
08788 
08789          /* error 202  in stat variable */
08790          PRINTMSG(stat_line, 202, Error, stat_col);
08791          ok = FALSE;
08792       }
08793 
08794       if (! check_for_legal_define(&opnd)) {
08795          ok = FALSE;
08796       }
08797 
08798       *stat_opnd = null_opnd;
08799 
08800       if (ok) {
08801 
08802          if (OPND_FLD(opnd) == IR_Tbl_Idx             &&
08803              IR_OPR(OPND_IDX(opnd)) == Subscript_Opr) {
08804             COPY_OPND((*stat_opnd), IR_OPND_L(OPND_IDX(opnd)));
08805          }
08806          else {
08807             COPY_OPND((*stat_opnd), opnd);
08808          }
08809 
08810          find_opnd_line_and_column(&opnd, &line, &col);
08811 
08812 # if defined(_TARGET_OS_MAX) || defined(_TARGET_OS_SOLARIS) || \
08813      (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
08814 # ifdef _TARGET_OS_MAX
08815          if (exp_desc.linear_type == Integer_1 ||
08816              exp_desc.linear_type == Integer_2 ||
08817              exp_desc.linear_type == Integer_4)
08818 # else
08819          if (exp_desc.linear_type == Integer_8)
08820 # endif
08821             {
08822             tmp_idx              = gen_compiler_tmp(line, col, Priv, TRUE);
08823             AT_SEMANTICS_DONE(tmp_idx)= TRUE;
08824             ATD_TYPE_IDX(tmp_idx)     = CG_INTEGER_DEFAULT_TYPE;
08825             ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
08826 
08827             NTR_IR_TBL(asg_idx);
08828             IR_OPR(asg_idx) = Asg_Opr;
08829             IR_TYPE_IDX(asg_idx) = exp_desc.type_idx;
08830             IR_LINE_NUM(asg_idx) = line;
08831             IR_COL_NUM(asg_idx)  = col;
08832             COPY_OPND(IR_OPND_L(asg_idx), opnd);
08833             IR_FLD_R(asg_idx) = AT_Tbl_Idx;
08834             IR_IDX_R(asg_idx) = tmp_idx;
08835             IR_LINE_NUM_R(asg_idx) = line;
08836             IR_COL_NUM_R(asg_idx)  = col;
08837 
08838             gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
08839             SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
08840             SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
08841             curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
08842 
08843             OPND_FLD(opnd) = AT_Tbl_Idx;
08844             OPND_IDX(opnd) = tmp_idx;
08845             OPND_LINE_NUM(opnd) = line;
08846             OPND_COL_NUM(opnd)  = col;
08847 
08848          }
08849 # endif
08850 
08851 
08852          NTR_IR_TBL(loc_idx);
08853          IR_OPR(loc_idx) = Aloc_Opr;
08854          IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
08855          IR_LINE_NUM(loc_idx) = line;
08856          IR_COL_NUM(loc_idx)  = col;
08857          IL_FLD(stat_list_idx) = IR_Tbl_Idx;
08858          IL_IDX(stat_list_idx) = loc_idx;
08859          IL_LINE_NUM(stat_list_idx) = line;
08860          IL_COL_NUM(stat_list_idx)  = col;
08861 
08862          COPY_OPND(IR_OPND_L(loc_idx), opnd);
08863       }
08864    }
08865 
08866    TRACE (Func_Exit, "check_stat_variable", NULL);
08867 
08868    return(ok);
08869 
08870 }  /* check_stat_variable */
08871 
08872 /******************************************************************************\
08873 |*                                                                            *|
08874 |* Description:                                                               *|
08875 |*      <description>                                                         *|
08876 |*                                                                            *|
08877 |* Input parameters:                                                          *|
08878 |*      NONE                                                                  *|
08879 |*                                                                            *|
08880 |* Output parameters:                                                         *|
08881 |*      NONE                                                                  *|
08882 |*                                                                            *|
08883 |* Returns:                                                                   *|
08884 |*      NOTHING                                                               *|
08885 |*                                                                            *|
08886 \******************************************************************************/
08887 
08888 static void asg_opnd_to_tmp(int                 tmp_idx,
08889                             opnd_type           *opnd,
08890                             int                 line,
08891                             int                 col,
08892                             sh_position_type    position)
08893 
08894 {
08895    int          asg_idx;
08896 
08897    TRACE (Func_Entry, "asg_opnd_to_tmp", NULL);
08898 
08899    NTR_IR_TBL(asg_idx);
08900    IR_OPR(asg_idx) = Asg_Opr;
08901    IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(tmp_idx);
08902    IR_LINE_NUM(asg_idx) = line;
08903    IR_COL_NUM(asg_idx)  = col;
08904    IR_FLD_L(asg_idx) = AT_Tbl_Idx;
08905    IR_IDX_L(asg_idx) = tmp_idx;
08906    IR_LINE_NUM_L(asg_idx) = line;
08907    IR_COL_NUM_L(asg_idx)  = col;
08908 
08909    COPY_OPND(IR_OPND_R(asg_idx), (*opnd));
08910 
08911    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
08912 
08913    if (position == Before) {
08914       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08915       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08916    }
08917    else {
08918       SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
08919       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
08920    }
08921 
08922 
08923    TRACE (Func_Exit, "asg_opnd_to_tmp", NULL);
08924 
08925    return;
08926 
08927 }  /* asg_opnd_to_tmp */
08928 
08929 /******************************************************************************\
08930 |*                                                                            *|
08931 |* Description:                                                               *|
08932 |*      <description>                                                         *|
08933 |*                                                                            *|
08934 |* Input parameters:                                                          *|
08935 |*      NONE                                                                  *|
08936 |*                                                                            *|
08937 |* Output parameters:                                                         *|
08938 |*      NONE                                                                  *|
08939 |*                                                                            *|
08940 |* Returns:                                                                   *|
08941 |*      NOTHING                                                               *|
08942 |*                                                                            *|
08943 \******************************************************************************/
08944 
08945 static void gen_Dv_Set_stmt(opnd_type          *dope_opnd,
08946                             operator_type       opr,
08947                             int                 ir_dv_dim,
08948                             opnd_type           *opnd,
08949                             sh_position_type    position)
08950 
08951 {
08952    int          col;
08953    int          dv_idx;
08954    int          line;
08955 
08956 
08957    TRACE (Func_Entry, "gen_Dv_Set_stmt", NULL);
08958 
08959    find_opnd_line_and_column(dope_opnd, &line, &col);
08960 
08961    NTR_IR_TBL(dv_idx);
08962    IR_OPR(dv_idx) = opr;
08963    IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
08964    IR_LINE_NUM(dv_idx) = line;
08965    IR_COL_NUM(dv_idx)  = col;
08966    COPY_OPND(IR_OPND_L(dv_idx), (*dope_opnd));
08967    COPY_OPND(IR_OPND_R(dv_idx), (*opnd));
08968 
08969    if (ir_dv_dim) {
08970       IR_DV_DIM(dv_idx) = ir_dv_dim;
08971    }
08972 
08973    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
08974 
08975    if (position == Before) {
08976       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
08977       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08978    }
08979    else {
08980       SH_IR_IDX(curr_stmt_sh_idx) = dv_idx;
08981       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
08982    }
08983 
08984 
08985    TRACE (Func_Exit, "gen_Dv_Set_stmt", NULL);
08986 
08987    return;
08988 
08989 }  /* gen_Dv_Set_stmt */
08990 
08991 /******************************************************************************\
08992 |*                                                                            *|
08993 |* Description:                                                               *|
08994 |*      <description>                                                         *|
08995 |*                                                                            *|
08996 |* Input parameters:                                                          *|
08997 |*      NONE                                                                  *|
08998 |*                                                                            *|
08999 |* Output parameters:                                                         *|
09000 |*      NONE                                                                  *|
09001 |*                                                                            *|
09002 |* Returns:                                                                   *|
09003 |*      NOTHING                                                               *|
09004 |*                                                                            *|
09005 \******************************************************************************/
09006 
09007 void set_up_allocate_as_call(int                ir_idx,
09008                              int                attr_idx,
09009                              int                stat_list_idx,
09010                              boolean            shared_heap)
09011 
09012 
09013 {
09014    int                  asg_idx;
09015    int                  call_idx;
09016    int                  idx;
09017    int                  idx1;
09018    int                  col;
09019    int                  line;
09020    int                  list_idx;
09021    int                  list_idx2;
09022    int                  loc_idx;
09023    int                  subscript_idx;
09024    int                  tmp_array_idx;
09025    long_type            the_constant;
09026 
09027 
09028    TRACE (Func_Entry, "set_up_allocate_as_call", NULL);
09029 
09030    line = IR_LINE_NUM(ir_idx);
09031    col = IR_COL_NUM(ir_idx);
09032 /*    tmp_array_idx = create_alloc_descriptor(IR_LIST_CNT_L(ir_idx),
09033                                            line,
09034                                            col,
09035                                            shared_heap);
09036 
09037    list_idx = IR_IDX_L(ir_idx);
09038    the_constant = 2;
09039 
09040 # if defined(GENERATE_WHIRL)
09041    if (TYP_LINEAR(ATD_TYPE_IDX(tmp_array_idx)) == Integer_4) {
09042       the_constant++;
09043    }
09044 # endif
09045 
09046    while (list_idx) {
09047 */
09048       /* put loc of dope vector into tmp_array */
09049 /* 
09050       NTR_IR_TBL(asg_idx);
09051       IR_OPR(asg_idx) = Asg_Opr;
09052       IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(tmp_array_idx);
09053       IR_LINE_NUM(asg_idx) = line;
09054       IR_COL_NUM(asg_idx)  = col;
09055 
09056       COPY_OPND(IR_OPND_R(asg_idx), IL_OPND(list_idx));
09057 
09058       NTR_IR_TBL(subscript_idx);
09059       IR_OPR(subscript_idx) = Subscript_Opr;
09060       IR_TYPE_IDX(subscript_idx) = ATD_TYPE_IDX(tmp_array_idx);
09061       IR_LINE_NUM(subscript_idx) = line;
09062       IR_COL_NUM(subscript_idx)  = col;
09063       IR_FLD_L(subscript_idx) = AT_Tbl_Idx;
09064       IR_IDX_L(subscript_idx) = tmp_array_idx;
09065       IR_LINE_NUM_L(subscript_idx) = line;
09066       IR_COL_NUM_L(subscript_idx)  = col;
09067 
09068       IR_FLD_L(asg_idx) = IR_Tbl_Idx;
09069       IR_IDX_L(asg_idx) = subscript_idx;
09070 
09071       NTR_IR_LIST_TBL(list_idx2);
09072       IL_FLD(list_idx2) = CN_Tbl_Idx;
09073       IL_IDX(list_idx2) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant);
09074       IL_LINE_NUM(list_idx2) = line;
09075       IL_COL_NUM(list_idx2)  = col;
09076 
09077       IR_FLD_R(subscript_idx) = IL_Tbl_Idx;
09078       IR_LIST_CNT_R(subscript_idx) = 1;
09079       IR_IDX_R(subscript_idx) = list_idx2;
09080 
09081       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
09082       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
09083       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
09084 
09085       list_idx = IL_NEXT_LIST_IDX(list_idx);
09086       the_constant++;
09087    }
09088 */
09089 
09090    NTR_IR_TBL(call_idx);
09091    IR_OPR(call_idx)             = Call_Opr;
09092    IR_TYPE_IDX(call_idx)        = TYPELESS_DEFAULT_TYPE;
09093    IR_LINE_NUM(call_idx)        = line;
09094    IR_COL_NUM(call_idx)         = col;
09095    IR_FLD_L(call_idx)           = AT_Tbl_Idx;
09096    IR_LINE_NUM_L(call_idx)      = line;
09097    IR_COL_NUM_L(call_idx)       = col;
09098    IR_IDX_L(call_idx)           = attr_idx;
09099    IR_FLD_R(call_idx)           = IL_Tbl_Idx;
09100 
09101    IR_LIST_CNT_R(call_idx)      = ++IR_LIST_CNT_L(ir_idx);
09102 
09103    IR_IDX_R(call_idx)           = IR_IDX_L(ir_idx);
09104 
09105 /*   NTR_IR_TBL(loc_idx);
09106    IR_OPR(loc_idx)              = Aloc_Opr;
09107    IR_TYPE_IDX(loc_idx)         = CRI_Ptr_8;
09108    IR_LINE_NUM(loc_idx)         = line;
09109    IR_COL_NUM(loc_idx)          = col;
09110    IR_FLD_L(loc_idx)            = AT_Tbl_Idx;
09111    IR_IDX_L(loc_idx)            = tmp_array_idx;
09112    IR_LINE_NUM_L(loc_idx)       = line;
09113    IR_COL_NUM_L(loc_idx)        = col;
09114    IL_FLD(list_idx)             = IR_Tbl_Idx;
09115    IL_IDX(list_idx)             = loc_idx;
09116    IL_NEXT_LIST_IDX(list_idx)   = stat_list_idx;
09117 */
09118    idx  =  IR_IDX_L(ir_idx);
09119    idx1  =  IL_NEXT_LIST_IDX (idx);
09120    while (idx1 != NULL_IDX) {
09121        idx = idx1;
09122        idx1 = IL_NEXT_LIST_IDX (idx);
09123    }
09124    IL_NEXT_LIST_IDX(idx)  = stat_list_idx;  
09125    
09126    SH_IR_IDX(curr_stmt_sh_idx)  = call_idx;
09127 
09128 
09129    TRACE (Func_Exit, "set_up_allocate_as_call", NULL);
09130 
09131    return;
09132 
09133 }  /* set_up_allocate_as_call */
09134 
09135 /******************************************************************************\
09136 |*                                                                            *|
09137 |* Description:                                                               *|
09138 |*      <description>                                                         *|
09139 |*                                                                            *|
09140 |* Input parameters:                                                          *|
09141 |*      NONE                                                                  *|
09142 |*                                                                            *|
09143 |* Output parameters:                                                         *|
09144 |*      NONE                                                                  *|
09145 |*                                                                            *|
09146 |* Returns:                                                                   *|
09147 |*      NOTHING                                                               *|
09148 |*                                                                            *|
09149 \******************************************************************************/
09150 
09151 void gen_split_alloc(int                ir_idx,
09152                      int                lib_attr_idx,
09153                      int                stat_list_idx)
09154 
09155 {
09156    int          attr_idx;
09157    int          cn_idx;
09158    int          col;
09159    int          line;
09160    int          list_idx;
09161    int          list_idx2 = NULL_IDX;
09162    int          new_ir_idx;
09163 
09164    TRACE (Func_Entry, "gen_split_alloc", NULL);
09165 
09166    NTR_IR_TBL(new_ir_idx);
09167    COPY_TBL_NTRY(ir_tbl, new_ir_idx, ir_idx);
09168 
09169    line = IR_LINE_NUM(ir_idx);
09170    col = IR_COL_NUM(ir_idx);
09171 
09172    IR_IDX_L(new_ir_idx) = NULL_IDX;
09173    IR_LIST_CNT_L(new_ir_idx) = 0;
09174 
09175    list_idx = IR_IDX_L(ir_idx);
09176 
09177    while (list_idx) {
09178       attr_idx = find_left_attr(&IL_OPND(list_idx));
09179 
09180       if (!ATD_ALLOCATABLE(attr_idx) ||
09181           ATD_PE_ARRAY_IDX(attr_idx) == NULL_IDX) {
09182 
09183          if (list_idx == IR_IDX_L(ir_idx)) {
09184             IR_IDX_L(ir_idx) = IL_NEXT_LIST_IDX(list_idx);
09185             IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = NULL_IDX;
09186          }
09187          else {
09188             IL_NEXT_LIST_IDX(IL_PREV_LIST_IDX(list_idx)) =
09189                                           IL_NEXT_LIST_IDX(list_idx);
09190             IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) =
09191                                           IL_PREV_LIST_IDX(list_idx);
09192          }
09193          IR_LIST_CNT_L(ir_idx)--;
09194 
09195          if (list_idx2 == NULL_IDX) {
09196             IR_IDX_L(new_ir_idx) = list_idx;
09197             IL_PREV_LIST_IDX(list_idx) = NULL_IDX;
09198             IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
09199          }
09200          else {
09201             IL_NEXT_LIST_IDX(list_idx2) = list_idx;
09202             IL_PREV_LIST_IDX(list_idx) = list_idx2;
09203             IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
09204          }
09205          list_idx2 = list_idx;
09206          IR_LIST_CNT_L(new_ir_idx)++;
09207 
09208       }
09209       list_idx = IL_NEXT_LIST_IDX(list_idx);
09210    }
09211 
09212 # ifdef _ALLOCATE_IS_CALL
09213    set_up_allocate_as_call(new_ir_idx,
09214                            lib_attr_idx,
09215                            stat_list_idx,
09216                            FALSE);
09217 # else
09218 
09219    NTR_IR_LIST_TBL(list_idx);
09220    IR_FLD_R(new_ir_idx) = IL_Tbl_Idx;
09221    IR_IDX_R(new_ir_idx) = list_idx;
09222    IR_LIST_CNT_R(new_ir_idx) = 3;
09223 
09224    IL_FLD(list_idx) = AT_Tbl_Idx;
09225    IL_IDX(list_idx) = lib_attr_idx;
09226    IL_LINE_NUM(list_idx) = line;
09227    IL_COL_NUM(list_idx)  = col;
09228 
09229    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
09230    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
09231    list_idx = IL_NEXT_LIST_IDX(list_idx);
09232 
09233    IL_FLD(list_idx) = CN_Tbl_Idx;
09234    IL_IDX(list_idx) = gen_alloc_header_const(Integer_8,
09235                                              IR_LIST_CNT_L(new_ir_idx),
09236                                              FALSE,
09237                                              &cn_idx);
09238    IL_LINE_NUM(list_idx) = line;
09239    IL_COL_NUM(list_idx)  = col;
09240 
09241    IL_NEXT_LIST_IDX(list_idx) = stat_list_idx;
09242    IL_PREV_LIST_IDX(stat_list_idx) = list_idx;
09243 
09244 # endif
09245 
09246 
09247    gen_sh(Before, Allocate_Stmt, line, col, FALSE, FALSE, TRUE);
09248 
09249    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_ir_idx;
09250    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
09251 
09252 
09253    TRACE (Func_Exit, "gen_split_alloc", NULL);
09254 
09255    return;
09256 
09257 }  /* gen_split_alloc */
09258 
09259 /******************************************************************************\
09260 |*                                                                            *|
09261 |* Description:                                                               *|
09262 |*      <description>                                                         *|
09263 |*                                                                            *|
09264 |* Input parameters:                                                          *|
09265 |*      NONE                                                                  *|
09266 |*                                                                            *|
09267 |* Output parameters:                                                         *|
09268 |*      NONE                                                                  *|
09269 |*                                                                            *|
09270 |* Returns:                                                                   *|
09271 |*      NOTHING                                                               *|
09272 |*                                                                            *|
09273 \******************************************************************************/
09274 
09275 boolean is_local_forall_index(int       attr_idx)
09276 
09277 {
09278    int          list_idx;
09279    boolean      result = FALSE;
09280 
09281    TRACE (Func_Entry, "is_local_forall_index", NULL);
09282 
09283    list_idx = IR_IDX_R(SH_IR_IDX(active_forall_sh_idx));
09284 
09285    while (list_idx &&
09286           IL_FLD(list_idx) == IL_Tbl_Idx) {
09287 
09288       if (ATD_FORALL_INDEX(attr_idx)) {
09289          if (attr_idx == AT_ATTR_LINK(IL_IDX(IL_IDX(list_idx)))) {
09290             result = TRUE;
09291             break;
09292          }
09293       }
09294       else if (attr_idx == IL_IDX(IL_IDX(list_idx))) {
09295          result = TRUE;
09296          break;
09297       }
09298           
09299       list_idx = IL_NEXT_LIST_IDX(list_idx);
09300    }
09301    
09302 
09303    TRACE (Func_Exit, "is_local_forall_index", NULL);
09304 
09305    return(result);
09306 
09307 }  /* is_local_forall_index */
09308 
09309 /******************************************************************************\
09310 |*                                                                            *|
09311 |* Description:                                                               *|
09312 |*      <description>                                                         *|
09313 |*                                                                            *|
09314 |* Input parameters:                                                          *|
09315 |*      NONE                                                                  *|
09316 |*                                                                            *|
09317 |* Output parameters:                                                         *|
09318 |*      NONE                                                                  *|
09319 |*                                                                            *|
09320 |* Returns:                                                                   *|
09321 |*      NOTHING                                                               *|
09322 |*                                                                            *|
09323 \******************************************************************************/
09324 
09325 static boolean check_forall_triplet_for_index(opnd_type *top_opnd)
09326 
09327 {
09328    int          list_idx;
09329    boolean      ok = TRUE;
09330 
09331 
09332    TRACE (Func_Entry, "check_forall_triplet_for_index", NULL);
09333 
09334    switch (OPND_FLD((*top_opnd))) {
09335    case AT_Tbl_Idx:
09336       if (AT_OBJ_CLASS(OPND_IDX((*top_opnd))) == Data_Obj &&
09337           ATD_FORALL_INDEX(OPND_IDX((*top_opnd))) &&
09338           is_local_forall_index(OPND_IDX((*top_opnd)))) {
09339 
09340          PRINTMSG(OPND_LINE_NUM((*top_opnd)), 1605, Error,
09341                   OPND_COL_NUM((*top_opnd)));
09342          ok = FALSE;
09343       }
09344       break;
09345 
09346    case IR_Tbl_Idx:
09347       ok &= check_forall_triplet_for_index(&(IR_OPND_L(
09348                                         OPND_IDX((*top_opnd)))));
09349       ok &= check_forall_triplet_for_index(&(IR_OPND_R(
09350                                         OPND_IDX((*top_opnd)))));
09351       break;
09352 
09353    case IL_Tbl_Idx:
09354       list_idx = OPND_IDX((*top_opnd));
09355 
09356       while (list_idx) {
09357          ok &= check_forall_triplet_for_index(&(IL_OPND(list_idx)));
09358          list_idx = IL_NEXT_LIST_IDX(list_idx);
09359       }
09360       break;
09361 
09362    default:
09363        break;
09364    }
09365 
09366 
09367    TRACE (Func_Exit, "check_forall_triplet_for_index", NULL);
09368 
09369    return(ok);
09370 
09371 }  /* check_forall_triplet_for_index */
09372 
09373 /******************************************************************************\
09374 |*                                                                            *|
09375 |* Description:                                                               *|
09376 |*      <description>                                                         *|
09377 |*                                                                            *|
09378 |* Input parameters:                                                          *|
09379 |*      NONE                                                                  *|
09380 |*                                                                            *|
09381 |* Output parameters:                                                         *|
09382 |*      NONE                                                                  *|
09383 |*                                                                            *|
09384 |* Returns:                                                                   *|
09385 |*      NOTHING                                                               *|
09386 |*                                                                            *|
09387 \******************************************************************************/
09388 
09389 static boolean gen_forall_max_expr(int          start_list_idx,
09390                                    opnd_type    *result_opnd)
09391 
09392 {
09393 
09394    int                  col;
09395    int                  div_idx;
09396    int                  end_list_idx;
09397    expr_arg_type        exp_desc;
09398    int                  le_idx;
09399    int                  line;
09400    int                  minus_idx;
09401    boolean              ok = TRUE;
09402    int                  plus_idx;
09403    int                  stride_list_idx;
09404    int                  type_idx;
09405 
09406    TRACE (Func_Entry, "gen_forall_max_expr", NULL);
09407 
09408    if (IL_FLD(start_list_idx) == CN_Tbl_Idx) {
09409       type_idx = CN_TYPE_IDX(IL_IDX(start_list_idx));
09410    }
09411    else if (IL_FLD(start_list_idx) == AT_Tbl_Idx) {
09412       type_idx = ATD_TYPE_IDX(IL_IDX(start_list_idx));
09413    }
09414 
09415    find_opnd_line_and_column(&(IL_OPND(start_list_idx)), &line, &col);
09416 
09417    end_list_idx = IL_NEXT_LIST_IDX(start_list_idx);
09418    stride_list_idx = IL_NEXT_LIST_IDX(end_list_idx);
09419 
09420    if (IL_FLD(stride_list_idx) == CN_Tbl_Idx &&
09421        compare_cn_and_value(IL_IDX(stride_list_idx), 0, Eq_Opr)) {
09422 
09423       PRINTMSG(IL_LINE_NUM(stride_list_idx), 1606, Error, 
09424                IL_COL_NUM(stride_list_idx));
09425       ok = FALSE;
09426    }
09427 
09428    minus_idx = gen_ir(IL_FLD(end_list_idx), IL_IDX(end_list_idx),
09429                  Minus_Opr, type_idx, line, col,
09430                       IL_FLD(start_list_idx), IL_IDX(start_list_idx));
09431 
09432    plus_idx = gen_ir(IR_Tbl_Idx, minus_idx,
09433                 Plus_Opr, type_idx, line, col,
09434                      IL_FLD(stride_list_idx), IL_IDX(stride_list_idx));
09435 
09436    div_idx = gen_ir(IR_Tbl_Idx, plus_idx,
09437                 Div_Opr, type_idx, line, col,
09438                     IL_FLD(stride_list_idx), IL_IDX(stride_list_idx));
09439 
09440    le_idx = gen_ir(IR_Tbl_Idx, div_idx,
09441                Le_Opr, LOGICAL_DEFAULT_TYPE, line, col,
09442                    CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
09443 
09444    OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
09445    OPND_IDX((*result_opnd)) = le_idx;
09446 
09447    if (ok &&
09448        IL_FLD(start_list_idx)  == CN_Tbl_Idx &&
09449        IL_FLD(end_list_idx)    == CN_Tbl_Idx &&
09450        IL_FLD(stride_list_idx) == CN_Tbl_Idx) {
09451 
09452       exp_desc.rank = 0;
09453       xref_state    = CIF_No_Usage_Rec;
09454       ok &= expr_semantics(result_opnd, &exp_desc);
09455    }
09456 
09457 
09458    TRACE (Func_Exit, "gen_forall_max_expr", NULL);
09459 
09460    return(ok);
09461 
09462 }  /* gen_forall_max_expr */
09463 
09464 /******************************************************************************\
09465 |*                                                                            *|
09466 |* Description:                                                               *|
09467 |*      <description>                                                         *|
09468 |*                                                                            *|
09469 |* Input parameters:                                                          *|
09470 |*      NONE                                                                  *|
09471 |*                                                                            *|
09472 |* Output parameters:                                                         *|
09473 |*      NONE                                                                  *|
09474 |*                                                                            *|
09475 |* Returns:                                                                   *|
09476 |*      NOTHING                                                               *|
09477 |*                                                                            *|
09478 \******************************************************************************/
09479 
09480 static void gen_forall_branch_around(opnd_type  *br_around_opnd)
09481 
09482 {
09483    int          br_idx;
09484    int          col;
09485    int          label_idx;
09486    int          line;
09487    int          save_curr_stmt_sh_idx;
09488 
09489    TRACE (Func_Entry, "gen_forall_branch_around", NULL);
09490 
09491    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
09492 
09493    find_opnd_line_and_column(br_around_opnd, &line, &col);
09494 
09495    label_idx = gen_internal_lbl(line);
09496 
09497    br_idx = gen_ir(OPND_FLD((*br_around_opnd)), OPND_IDX((*br_around_opnd)),
09498               Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col,
09499                    AT_Tbl_Idx, label_idx);
09500 
09501    curr_stmt_sh_idx = active_forall_sh_idx;
09502 
09503    gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
09504    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_idx;
09505    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
09506 
09507    curr_stmt_sh_idx = IR_IDX_L(SH_IR_IDX(active_forall_sh_idx));
09508 
09509    br_idx = gen_ir(AT_Tbl_Idx, label_idx,
09510               Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
09511                    NO_Tbl_Idx, NULL_IDX);
09512 
09513    gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
09514    SH_IR_IDX(curr_stmt_sh_idx) = br_idx;
09515    SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
09516 
09517    AT_DEFINED(label_idx) = TRUE;
09518    ATL_DEF_STMT_IDX(label_idx) = curr_stmt_sh_idx;
09519 
09520 
09521    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
09522 
09523    TRACE (Func_Exit, "gen_forall_branch_around", NULL);
09524 
09525    return;
09526 
09527 }  /* gen_forall_branch_around */
09528 
09529 /******************************************************************************\
09530 |*                                                                            *|
09531 |* Description:                                                               *|
09532 |*      <description>                                                         *|
09533 |*                                                                            *|
09534 |* Input parameters:                                                          *|
09535 |*      NONE                                                                  *|
09536 |*                                                                            *|
09537 |* Output parameters:                                                         *|
09538 |*      NONE                                                                  *|
09539 |*                                                                            *|
09540 |* Returns:                                                                   *|
09541 |*      NOTHING                                                               *|
09542 |*                                                                            *|
09543 \******************************************************************************/
09544 
09545 void gen_forall_loops(int       start_body_sh_idx,
09546                       int       end_body_sh_idx)
09547 
09548 {
09549    opnd_type    end_opnd;
09550    int          lcv_idx;
09551    int          list_idx;
09552    opnd_type    start_opnd;
09553    opnd_type    stride_opnd;
09554 
09555    TRACE (Func_Entry, "gen_forall_loops", NULL);
09556 
09557    list_idx = IR_IDX_R(SH_IR_IDX(active_forall_sh_idx));
09558 
09559    while (list_idx &&
09560           IL_FLD(list_idx) == IL_Tbl_Idx) {
09561 
09562       lcv_idx = AT_ATTR_LINK(IL_IDX(IL_IDX(list_idx)));
09563       COPY_OPND(start_opnd, IL_OPND(IL_NEXT_LIST_IDX(IL_IDX(list_idx))));
09564       COPY_OPND(end_opnd,  
09565               IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IL_IDX(list_idx)))));
09566       COPY_OPND(stride_opnd, 
09567               IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
09568                                IL_NEXT_LIST_IDX(IL_IDX(list_idx))))));
09569 
09570       create_loop_stmts(lcv_idx, &start_opnd, &end_opnd, &stride_opnd,
09571                         start_body_sh_idx, 
09572                         end_body_sh_idx);
09573 
09574       list_idx = IL_NEXT_LIST_IDX(list_idx);
09575    }
09576 
09577    TRACE (Func_Exit, "gen_forall_loops", NULL);
09578 
09579    return;
09580 
09581 }  /* gen_forall_loops */
09582 
09583 /******************************************************************************\
09584 |*                                                                            *|
09585 |* Description:                                                               *|
09586 |*      <description>                                                         *|
09587 |*                                                                            *|
09588 |* Input parameters:                                                          *|
09589 |*      NONE                                                                  *|
09590 |*                                                                            *|
09591 |* Output parameters:                                                         *|
09592 |*      NONE                                                                  *|
09593 |*                                                                            *|
09594 |* Returns:                                                                   *|
09595 |*      NOTHING                                                               *|
09596 |*                                                                            *|
09597 \******************************************************************************/
09598 
09599 void gen_forall_tmp(expr_arg_type       *exp_desc,
09600                     opnd_type           *result_opnd,
09601                     int                 line,
09602                     int                 col,
09603                     boolean             is_pointer)
09604 
09605 {
09606    int                  alloc_idx;
09607    int                  base_asg_idx;
09608    int                  base_tmp_idx;
09609    int                  bd_idx;
09610    boolean              constant_shape;
09611    int                  dealloc_idx;
09612    int                  i;
09613    int                  list_idx;
09614    int                  list_idx2;
09615    int                  list_idx3;
09616    expr_arg_type        loc_exp_desc;
09617    int                  max_idx;
09618    int                  save_curr_stmt_sh_idx;
09619    opnd_type            size_opnd;
09620    int                  struct_idx;
09621    int                  sub_idx;
09622    int                  tmp_idx;
09623    int                  triplet_idx;
09624 
09625 
09626    TRACE (Func_Entry, "gen_forall_tmp", NULL);
09627 
09628    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
09629    curr_stmt_sh_idx = active_forall_sh_idx;
09630 
09631    tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
09632    AT_SEMANTICS_DONE(tmp_idx) = TRUE;
09633 
09634    if (is_pointer) {
09635       ATD_TYPE_IDX(tmp_idx) = gen_forall_derived_type(exp_desc->type_idx,
09636                                                       exp_desc->rank,
09637                                                       line, 
09638                                                       col);
09639    }
09640    else {
09641       ATD_TYPE_IDX(tmp_idx) = exp_desc->type_idx;
09642    }
09643 
09644    ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
09645 
09646    if (is_pointer) {
09647       loc_exp_desc = init_exp_desc;
09648       loc_exp_desc.type_idx = ATD_TYPE_IDX(tmp_idx);
09649       loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx);
09650       loc_exp_desc.linear_type = TYP_LINEAR(loc_exp_desc.type_idx);
09651       constant_shape = gen_forall_tmp_bd_entry(&loc_exp_desc, 
09652                                                &bd_idx, line, col);
09653    }
09654    else {
09655       constant_shape = gen_forall_tmp_bd_entry(exp_desc, &bd_idx, line, col);
09656    }
09657 
09658    ATD_ARRAY_IDX(tmp_idx) = bd_idx;
09659 
09660    if (!constant_shape) {
09661 
09662       ATD_STOR_BLK_IDX(tmp_idx) =  SCP_SB_BASED_IDX(curr_scp_idx);
09663 
09664       /* initialize size_opnd to the number of elements for */
09665       /* determine_tmp_size.                                */
09666 
09667       gen_opnd(&size_opnd, BD_LEN_IDX(bd_idx), BD_LEN_FLD(bd_idx), line, col);
09668 
09669       /* now for the alloc and dealloc stmts */
09670 
09671       ATD_AUTOMATIC(tmp_idx) = TRUE;
09672 
09673       GEN_COMPILER_TMP_ASG(base_asg_idx,
09674                            base_tmp_idx,
09675                            TRUE,        /* Semantics done */
09676                            line,
09677                            col,
09678                            SA_INTEGER_DEFAULT_TYPE,
09679                            Priv);
09680 
09681       ATD_AUTO_BASE_IDX(tmp_idx)        = base_tmp_idx;
09682 
09683       determine_tmp_size(&size_opnd, exp_desc->type_idx);
09684 
09685       NTR_IR_TBL(max_idx);
09686       IR_OPR(max_idx) = Max_Opr;
09687       IR_TYPE_IDX(max_idx) = SA_INTEGER_DEFAULT_TYPE;
09688       IR_LINE_NUM(max_idx) = line;
09689       IR_COL_NUM(max_idx)  = col;
09690       IR_FLD_L(max_idx) = IL_Tbl_Idx;
09691       IR_LIST_CNT_L(max_idx) = 2;
09692 
09693       NTR_IR_LIST_TBL(list_idx);
09694       IR_IDX_L(max_idx) = list_idx;
09695 
09696       IL_FLD(list_idx) = CN_Tbl_Idx;
09697       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
09698       IL_LINE_NUM(list_idx) = line;
09699       IL_COL_NUM(list_idx)  = col;
09700 
09701       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
09702       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
09703       list_idx = IL_NEXT_LIST_IDX(list_idx);
09704 
09705       COPY_OPND(IL_OPND(list_idx), size_opnd);
09706 
09707       OPND_FLD(size_opnd) = IR_Tbl_Idx;
09708       OPND_IDX(size_opnd) = max_idx;
09709 
09710 
09711       alloc_idx = gen_ir(OPND_FLD(size_opnd), OPND_IDX(size_opnd),
09712                      Alloc_Opr, TYPELESS_DEFAULT_TYPE, line, col,
09713                          NO_Tbl_Idx, NULL_IDX);
09714 
09715       IR_FLD_R(base_asg_idx) = IR_Tbl_Idx;
09716       IR_IDX_R(base_asg_idx) = alloc_idx;
09717 
09718       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
09719 
09720       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = base_asg_idx;
09721       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
09722 
09723       /* The dealloc goes after the end_forall */
09724 
09725       curr_stmt_sh_idx = IR_IDX_L(SH_IR_IDX(active_forall_sh_idx));
09726 
09727       dealloc_idx = gen_ir(IR_FLD_L(base_asg_idx), IR_IDX_L(base_asg_idx),
09728                        Dealloc_Opr, TYPELESS_DEFAULT_TYPE, line, col,
09729                            NO_Tbl_Idx, NULL_IDX);
09730 
09731       gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
09732 
09733       SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx;
09734       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
09735 
09736    }
09737 
09738    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
09739 
09740    /* need to set the result_opnd with full array sections   */
09741    /* for the array syntax dims, and the index variables for */
09742    /* the remaining dims.                                    */
09743 
09744    NTR_IR_TBL(sub_idx);
09745    if (is_pointer) {
09746       IR_OPR(sub_idx) = Subscript_Opr;
09747    }
09748    else {
09749       IR_OPR(sub_idx) = (exp_desc->rank > 0 ? Section_Subscript_Opr :
09750                                                Subscript_Opr);
09751       IR_RANK(sub_idx) = exp_desc->rank;
09752    }
09753 
09754    IR_TYPE_IDX(sub_idx) = exp_desc->type_idx;
09755    IR_LINE_NUM(sub_idx) = line;
09756    IR_COL_NUM(sub_idx) = col;
09757 
09758    IR_FLD_L(sub_idx) = AT_Tbl_Idx;
09759    IR_IDX_L(sub_idx) = tmp_idx;
09760    IR_LINE_NUM_L(sub_idx) = line;
09761    IR_COL_NUM_L(sub_idx) = col;
09762 
09763    list_idx2 = NULL_IDX;
09764    list_idx = IR_IDX_R(SH_IR_IDX(active_forall_sh_idx));
09765 
09766    for (i = 1; i <= BD_RANK(bd_idx); i++) {
09767 
09768       if (list_idx2 == NULL_IDX) {
09769          NTR_IR_LIST_TBL(list_idx2);
09770          IR_FLD_R(sub_idx) = IL_Tbl_Idx;
09771          IR_IDX_R(sub_idx) = list_idx2;
09772          IR_LIST_CNT_R(sub_idx) = 1;
09773       }
09774       else {
09775          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
09776          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
09777          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
09778          IR_LIST_CNT_R(sub_idx) += 1;
09779       }
09780 
09781       if (! is_pointer &&
09782           i <= exp_desc->rank) {
09783          /* gen a whole section of this dim */
09784 
09785          NTR_IR_TBL(triplet_idx);
09786          IR_OPR(triplet_idx) = Triplet_Opr;
09787          IR_RANK(triplet_idx) = 1;
09788          IR_TYPE_IDX(triplet_idx) = CG_INTEGER_DEFAULT_TYPE;
09789          IR_LINE_NUM(triplet_idx) = line;
09790          IR_COL_NUM(triplet_idx) = col;
09791          IR_FLD_L(triplet_idx) = IL_Tbl_Idx;
09792          NTR_IR_LIST_TBL(list_idx3);
09793          IR_IDX_L(triplet_idx) = list_idx3;
09794          IR_LIST_CNT_L(triplet_idx) = 3;
09795 
09796          IL_FLD(list_idx3) = BD_LB_FLD(bd_idx,i);
09797          IL_IDX(list_idx3) = BD_LB_IDX(bd_idx,i);
09798          IL_LINE_NUM(list_idx3) = line;
09799          IL_COL_NUM(list_idx3) = col;
09800 
09801          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx3));
09802          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx3)) = list_idx3;
09803          list_idx3 = IL_NEXT_LIST_IDX(list_idx3);
09804 
09805          IL_FLD(list_idx3) = BD_UB_FLD(bd_idx,i);
09806          IL_IDX(list_idx3) = BD_UB_IDX(bd_idx,i);
09807          IL_LINE_NUM(list_idx3) = line;
09808          IL_COL_NUM(list_idx3) = col;
09809 
09810          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx3));
09811          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx3)) = list_idx3;
09812          list_idx3 = IL_NEXT_LIST_IDX(list_idx3);
09813 
09814          IL_FLD(list_idx3) = CN_Tbl_Idx;
09815          IL_IDX(list_idx3) = CN_INTEGER_ONE_IDX;
09816          IL_LINE_NUM(list_idx3) = line;
09817          IL_COL_NUM(list_idx3) = col;
09818 
09819          IL_FLD(list_idx2) = IR_Tbl_Idx;
09820          IL_IDX(list_idx2) = triplet_idx;
09821       }
09822       else {
09823 
09824          /* this is a forall index dim */
09825 
09826          IL_FLD(list_idx2) = AT_Tbl_Idx;
09827          IL_IDX(list_idx2) = AT_ATTR_LINK(IL_IDX(IL_IDX(list_idx)));
09828          IL_LINE_NUM(list_idx2) = line;
09829          IL_COL_NUM(list_idx2) = col;
09830 
09831          list_idx = IL_NEXT_LIST_IDX(list_idx);
09832       }
09833    }
09834 
09835    OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
09836    OPND_IDX((*result_opnd)) = sub_idx;
09837 
09838    if (is_pointer) {
09839       NTR_IR_TBL(struct_idx);
09840       IR_OPR(struct_idx) = Struct_Opr;
09841       IR_TYPE_IDX(struct_idx) = exp_desc->type_idx;
09842       IR_LINE_NUM(struct_idx) = line;
09843       IR_COL_NUM(struct_idx) = col;
09844       COPY_OPND(IR_OPND_L(struct_idx), (*result_opnd));
09845       IR_FLD_R(struct_idx) = AT_Tbl_Idx;
09846       IR_IDX_R(struct_idx) = SN_ATTR_IDX(ATT_FIRST_CPNT_IDX(
09847                                         TYP_IDX(ATD_TYPE_IDX(tmp_idx))));
09848       IR_LINE_NUM_R(struct_idx) = line;
09849       IR_COL_NUM_R(struct_idx) = col;
09850 
09851       OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
09852       OPND_IDX((*result_opnd)) = struct_idx;
09853 
09854       exp_desc->rank = 0;
09855       xref_state = CIF_No_Usage_Rec;
09856       expr_semantics(result_opnd, exp_desc);
09857    }
09858    else if (exp_desc->type == Character) {
09859       gen_whole_substring(result_opnd, exp_desc->rank);
09860    }
09861    
09862 
09863    TRACE (Func_Exit, "gen_forall_tmp", NULL);
09864 
09865    return;
09866 
09867 }  /* gen_forall_tmp */
09868 
09869 /******************************************************************************\
09870 |*                                                                            *|
09871 |* Description:                                                               *|
09872 |*      <description>                                                         *|
09873 |*                                                                            *|
09874 |* Input parameters:                                                          *|
09875 |*      NONE                                                                  *|
09876 |*                                                                            *|
09877 |* Output parameters:                                                         *|
09878 |*      NONE                                                                  *|
09879 |*                                                                            *|
09880 |* Returns:                                                                   *|
09881 |*      NOTHING                                                               *|
09882 |*                                                                            *|
09883 \******************************************************************************/
09884 
09885 static boolean gen_forall_tmp_bd_entry(expr_arg_type    *exp_desc,
09886                                        int              *new_bd_idx,
09887                                        int              line,
09888                                        int              col)
09889 
09890 {
09891    int                  asg_idx;
09892    int                  bd_idx;
09893    boolean              constant_shape = TRUE;
09894    expr_arg_type        loc_exp_desc;
09895    int                  i;
09896    int                  list_idx;
09897    int                  list_idx2;
09898    int                  mult_idx;
09899    opnd_type            num_el_opnd;
09900    int                  plus_idx;
09901    int                  rank;
09902    opnd_type            sm_opnd;
09903    size_offset_type     stride;
09904    int                  tmp_idx;
09905    opnd_type            xt_opnd;
09906 
09907 
09908    TRACE (Func_Entry, "gen_forall_tmp_bd_entry", NULL);
09909 
09910    rank = 0;
09911 
09912    list_idx = IR_IDX_R(SH_IR_IDX(active_forall_sh_idx));
09913 
09914    while (list_idx &&
09915           IL_FLD(list_idx) == IL_Tbl_Idx) {
09916 
09917       rank++;
09918       list_idx = IL_NEXT_LIST_IDX(list_idx);
09919    }
09920 
09921    rank += exp_desc->rank;
09922 
09923 # ifdef _DEBUG
09924    if (rank > 7) {
09925       PRINTMSG(line, 626, Internal, col,
09926                "rank <= 7", "gen_forall_tmp_bd_entry");
09927    }
09928 # endif
09929 
09930    bd_idx = reserve_array_ntry(rank);
09931    BD_RANK(bd_idx)        = rank;
09932    BD_LINE_NUM(bd_idx)    = line;
09933    BD_COLUMN_NUM(bd_idx)  = col;
09934    BD_RESOLVED(bd_idx)    = TRUE;
09935 
09936    num_el_opnd = null_opnd;
09937 
09938    /* the first dimensions are from array syntax */
09939 
09940    for (i = 1; i <= exp_desc->rank; i++) {
09941       BD_LB_FLD(bd_idx,i) = CN_Tbl_Idx;
09942       BD_LB_IDX(bd_idx,i) = CN_INTEGER_ONE_IDX;
09943 
09944       if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx) {
09945          BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]);
09946          BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]);
09947       }
09948       else {
09949          constant_shape = FALSE;
09950 
09951          if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx &&
09952              ATD_CLASS(OPND_IDX(exp_desc->shape[i-1])) == Compiler_Tmp) {
09953 
09954             BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]);
09955             BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]);
09956          }
09957          else { /* must do tmp assignments */
09958 
09959             GEN_COMPILER_TMP_ASG(asg_idx,
09960                                  tmp_idx,
09961                                  TRUE,    /* Semantics done */
09962                                  line,
09963                                  col,
09964                                  SA_INTEGER_DEFAULT_TYPE,
09965                                  Priv);
09966 
09967             IR_FLD_R(asg_idx) = OPND_FLD(exp_desc->shape[i-1]);
09968             IR_IDX_R(asg_idx) = OPND_IDX(exp_desc->shape[i-1]);
09969             IR_LINE_NUM_R(asg_idx) = line;
09970             IR_COL_NUM_R(asg_idx)  = col;
09971 
09972             gen_sh(Before, Assignment_Stmt, line,
09973                             col, FALSE, FALSE, TRUE);
09974 
09975             SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))      = asg_idx;
09976             SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx))  = TRUE;
09977 
09978             gen_copyin_bounds_stmt(tmp_idx);
09979 
09980             BD_UB_FLD(bd_idx, i)          = AT_Tbl_Idx;
09981             BD_UB_IDX(bd_idx, i)          = tmp_idx;
09982             OPND_FLD(exp_desc->shape[i-1])        = AT_Tbl_Idx;
09983             OPND_IDX(exp_desc->shape[i-1])        = tmp_idx;
09984             SHAPE_FOLDABLE(exp_desc->shape[i-1])  = FALSE;
09985             SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE;
09986          }
09987       }
09988 
09989       /* might need max (extent, 0) here  */
09990 
09991       BD_XT_FLD(bd_idx,i) = BD_UB_FLD(bd_idx,i);
09992       BD_XT_IDX(bd_idx,i) = BD_UB_IDX(bd_idx,i);
09993 
09994       if (OPND_FLD(num_el_opnd) == NO_Tbl_Idx) {
09995          gen_opnd(&num_el_opnd, BD_XT_IDX(bd_idx,i), BD_XT_FLD(bd_idx,i),
09996                   line, col);
09997       }
09998       else {
09999          mult_idx = gen_ir(OPND_FLD(num_el_opnd), OPND_IDX(num_el_opnd),
10000                        Mult_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
10001                            BD_XT_FLD(bd_idx,i), BD_XT_IDX(bd_idx,i));
10002 
10003          OPND_IDX(num_el_opnd) = mult_idx;
10004          OPND_FLD(num_el_opnd) = IR_Tbl_Idx;
10005       }
10006    }
10007 
10008    /* the remaining dimensions are the forall indexes */
10009 
10010 
10011    list_idx = IR_IDX_R(SH_IR_IDX(active_forall_sh_idx));
10012 
10013    for ( ;i <= rank; i++) {
10014 
10015 
10016       if (IL_LIST_CNT(list_idx) == 7) {
10017          list_idx2 = IL_NEXT_LIST_IDX(IL_IDX(list_idx)); /* start opnd */
10018          list_idx2 = IL_NEXT_LIST_IDX(list_idx2); /* end opnd */
10019          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* stride opnd */
10020 
10021          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* LB tmp opnd */
10022          BD_LB_FLD(bd_idx,i) = IL_FLD(list_idx2);
10023          BD_LB_IDX(bd_idx,i) = IL_IDX(list_idx2);
10024 
10025          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* UB tmp opnd */
10026          BD_UB_FLD(bd_idx,i) = IL_FLD(list_idx2);
10027          BD_UB_IDX(bd_idx,i) = IL_IDX(list_idx2);
10028         
10029          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* XT tmp opnd */
10030          BD_XT_FLD(bd_idx,i) = IL_FLD(list_idx2);
10031          BD_XT_IDX(bd_idx,i) = IL_IDX(list_idx2);
10032       }
10033       else {
10034 
10035          list_idx2 = IL_NEXT_LIST_IDX(IL_IDX(list_idx)); /* start opnd */
10036 
10037          determine_lb_ub(list_idx2, 
10038                          bd_idx,
10039                          i);
10040 
10041          list_idx2 = IL_NEXT_LIST_IDX(list_idx2); /* end opnd */
10042 
10043          if (BD_LB_FLD(bd_idx,i) == CN_Tbl_Idx &&
10044              compare_cn_and_value(BD_LB_IDX(bd_idx,i),
10045                                   1,
10046                                   Eq_Opr)) {
10047 
10048             BD_XT_FLD(bd_idx, i) = BD_UB_FLD(bd_idx,i);
10049             BD_XT_IDX(bd_idx, i) = BD_UB_IDX(bd_idx,i);
10050          }
10051          else {
10052             /* make expression for extent */
10053             /* upper - lower + 1 */
10054             plus_idx = gen_ir(IR_Tbl_Idx,
10055                            gen_ir(BD_UB_FLD(bd_idx,i), BD_UB_IDX(bd_idx,i),
10056                                Minus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
10057                                   BD_LB_FLD(bd_idx,i), BD_LB_IDX(bd_idx,i)),
10058                             Plus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
10059                               CN_Tbl_Idx, CN_INTEGER_ONE_IDX);
10060 
10061             gen_opnd(&xt_opnd, plus_idx, IR_Tbl_Idx, line, col);
10062 
10063             if (BD_LB_FLD(bd_idx,i) == CN_Tbl_Idx &&
10064                 BD_UB_FLD(bd_idx,i) == CN_Tbl_Idx) {
10065                loc_exp_desc.rank = 0;
10066                xref_state        = CIF_No_Usage_Rec;
10067                expr_semantics(&xt_opnd, &loc_exp_desc);
10068             }
10069 
10070             if (OPND_FLD(xt_opnd) != CN_Tbl_Idx &&
10071                 (OPND_FLD(xt_opnd) != AT_Tbl_Idx ||
10072                  ATD_CLASS(OPND_IDX(xt_opnd)) != Compiler_Tmp)) {
10073    
10074                /* must do tmp assignments */
10075 
10076                GEN_COMPILER_TMP_ASG(asg_idx,
10077                                     tmp_idx,
10078                                     TRUE,    /* Semantics done */
10079                                     line,
10080                                     col,
10081                                     SA_INTEGER_DEFAULT_TYPE,
10082                                     Priv);
10083 
10084                IR_FLD_R(asg_idx) = OPND_FLD(xt_opnd);
10085                IR_IDX_R(asg_idx) = OPND_IDX(xt_opnd);
10086                IR_LINE_NUM_R(asg_idx) = line;
10087                IR_COL_NUM_R(asg_idx)  = col;
10088    
10089                gen_sh(Before, Assignment_Stmt, line,
10090                                col, FALSE, FALSE, TRUE);
10091 
10092                SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))      = asg_idx;
10093                SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx))  = TRUE;
10094 
10095                gen_copyin_bounds_stmt(tmp_idx);
10096 
10097                OPND_FLD(xt_opnd) = AT_Tbl_Idx;
10098                OPND_IDX(xt_opnd) = tmp_idx;
10099             }
10100 
10101             BD_XT_FLD(bd_idx, i) = OPND_FLD(xt_opnd);
10102             BD_XT_IDX(bd_idx, i) = OPND_IDX(xt_opnd);
10103          }
10104 
10105          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* stride opnd */
10106          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
10107          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
10108 
10109          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* LB tmp opnd */
10110 
10111          gen_opnd(&IL_OPND(list_idx2), BD_LB_IDX(bd_idx,i), BD_LB_FLD(bd_idx,i),
10112                   line, col);
10113 
10114 
10115          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
10116          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
10117 
10118          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* UB tmp opnd */
10119 
10120          gen_opnd(&IL_OPND(list_idx2), BD_UB_IDX(bd_idx,i), BD_UB_FLD(bd_idx,i),
10121                   line, col);
10122 
10123          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
10124          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
10125 
10126          list_idx2 = IL_NEXT_LIST_IDX(list_idx2);  /* XT tmp opnd */
10127          gen_opnd(&IL_OPND(list_idx2), BD_XT_IDX(bd_idx,i), BD_XT_FLD(bd_idx,i),
10128                   line, col);
10129 
10130          IL_LIST_CNT(list_idx) = 7;
10131       }
10132 
10133       if (OPND_FLD(num_el_opnd) == NO_Tbl_Idx) {
10134          gen_opnd(&num_el_opnd, BD_XT_IDX(bd_idx,i), BD_XT_FLD(bd_idx,i),
10135                   line, col);
10136       }
10137       else {
10138          mult_idx = gen_ir(OPND_FLD(num_el_opnd), OPND_IDX(num_el_opnd),
10139                        Mult_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
10140                            BD_XT_FLD(bd_idx,i), BD_XT_IDX(bd_idx,i));
10141 
10142          OPND_IDX(num_el_opnd) = mult_idx;
10143          OPND_FLD(num_el_opnd) = IR_Tbl_Idx;
10144       }
10145 
10146       if (BD_LB_FLD(bd_idx,i) != CN_Tbl_Idx) {
10147          constant_shape = FALSE;
10148       }
10149 
10150       if (BD_UB_FLD(bd_idx,i) != CN_Tbl_Idx) {
10151          constant_shape = FALSE;
10152       }
10153 
10154       list_idx = IL_NEXT_LIST_IDX(list_idx);
10155    }
10156    
10157    /* someone needs to validate_char_len */
10158 
10159    if (exp_desc->type == Character &&
10160        TYP_FLD(exp_desc->type_idx) != CN_Tbl_Idx) {
10161       constant_shape = FALSE;
10162    }
10163 
10164    loc_exp_desc.rank = 0;
10165    xref_state        = CIF_No_Usage_Rec;
10166 
10167    expr_semantics(&num_el_opnd, &loc_exp_desc);
10168 
10169    if (OPND_FLD(num_el_opnd) == CN_Tbl_Idx) {
10170       BD_LEN_FLD(bd_idx)     = CN_Tbl_Idx;
10171       BD_LEN_IDX(bd_idx)     = OPND_IDX(num_el_opnd);
10172    }
10173    else if (OPND_FLD(num_el_opnd)            == AT_Tbl_Idx    &&
10174             ATD_CLASS(OPND_IDX(num_el_opnd)) == Compiler_Tmp) {
10175       BD_LEN_FLD(bd_idx)     = AT_Tbl_Idx;
10176       BD_LEN_IDX(bd_idx)     = OPND_IDX(num_el_opnd);
10177    }
10178    else { /* tmp assign the num_elements */
10179 
10180       GEN_COMPILER_TMP_ASG(asg_idx,
10181                            tmp_idx,
10182                            TRUE,     /* Semantics done */
10183                            line,
10184                            col,
10185                            loc_exp_desc.type_idx,
10186                            Priv);
10187 
10188       COPY_OPND(IR_OPND_R(asg_idx), num_el_opnd);
10189       gen_sh(Before, Assignment_Stmt, line,
10190                       col, FALSE, FALSE, TRUE);
10191 
10192       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))       = asg_idx;
10193       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx))   = TRUE;
10194 
10195       BD_LEN_FLD(bd_idx) = AT_Tbl_Idx;
10196       BD_LEN_IDX(bd_idx) = tmp_idx;
10197    }
10198 
10199    if (constant_shape) {
10200       BD_ARRAY_SIZE(bd_idx)  = Constant_Size;
10201    }
10202    else {
10203       BD_ARRAY_SIZE(bd_idx)  = Var_Len_Array;
10204    }
10205 
10206    set_stride_for_first_dim(exp_desc->type_idx, &stride);
10207 
10208    BD_SM_FLD(bd_idx, 1) = stride.fld;
10209    BD_SM_IDX(bd_idx, 1) = stride.idx;
10210 
10211    for (i = 2; i <= BD_RANK(bd_idx); i++) {
10212       mult_idx = gen_ir(BD_SM_FLD(bd_idx, i - 1), BD_SM_IDX(bd_idx, i - 1),
10213                    Mult_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
10214                         BD_XT_FLD(bd_idx, i - 1), BD_XT_IDX(bd_idx, i - 1));
10215 
10216       OPND_FLD(sm_opnd)          = IR_Tbl_Idx;
10217       OPND_IDX(sm_opnd)          = mult_idx;
10218 
10219       loc_exp_desc.rank = 0;
10220       xref_state        = CIF_No_Usage_Rec;
10221 
10222       expr_semantics(&sm_opnd, &loc_exp_desc);
10223 
10224       if (loc_exp_desc.constant) {
10225          BD_SM_FLD(bd_idx, i) = CN_Tbl_Idx;
10226          BD_SM_IDX(bd_idx, i) = OPND_IDX(sm_opnd);
10227       }
10228       else if (OPND_FLD(sm_opnd)            == AT_Tbl_Idx    &&
10229                ATD_CLASS(OPND_IDX(sm_opnd)) == Compiler_Tmp) {
10230          BD_SM_FLD(bd_idx, i) = AT_Tbl_Idx;
10231          BD_SM_IDX(bd_idx, i) = OPND_IDX(sm_opnd);
10232       }
10233      else {
10234 
10235          GEN_COMPILER_TMP_ASG(asg_idx,
10236                               tmp_idx,
10237                               TRUE,  /* Semantics done */
10238                               line,
10239                               col,
10240                               loc_exp_desc.type_idx,
10241                               Priv);
10242 
10243          COPY_OPND(IR_OPND_R(asg_idx), sm_opnd);
10244          gen_sh(Before, Assignment_Stmt, line,
10245                          col, FALSE, FALSE, TRUE);
10246 
10247          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
10248          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10249 
10250          BD_SM_FLD(bd_idx, i) = AT_Tbl_Idx;
10251          BD_SM_IDX(bd_idx, i) = tmp_idx;
10252       }
10253    }
10254 
10255    BD_FLOW_DEPENDENT(bd_idx) = TRUE;
10256 
10257    *new_bd_idx = ntr_array_in_bd_tbl(bd_idx);
10258 
10259    TRACE (Func_Exit, "gen_forall_tmp_bd_entry", NULL);
10260 
10261    return(constant_shape);
10262 
10263 }  /* gen_forall_tmp_bd_entry */
10264 
10265 /******************************************************************************\
10266 |*                                                                            *|
10267 |* Description:                                                               *|
10268 |*      <description>                                                         *|
10269 |*                                                                            *|
10270 |* Input parameters:                                                          *|
10271 |*      NONE                                                                  *|
10272 |*                                                                            *|
10273 |* Output parameters:                                                         *|
10274 |*      NONE                                                                  *|
10275 |*                                                                            *|
10276 |* Returns:                                                                   *|
10277 |*      NOTHING                                                               *|
10278 |*                                                                            *|
10279 \******************************************************************************/
10280 
10281 static void determine_lb_ub(int start_list_idx,
10282                             int bd_idx,
10283                             int idx)
10284 
10285 {
10286    int          asg_idx;
10287    int          col;
10288    int          else_idx;
10289    int          end_list_idx;
10290    int          gt_idx;
10291    int          if_idx;
10292    int          line;
10293    int          stride_list_idx;
10294    int          tmp_idx;
10295    int          type_idx;
10296 
10297 # if defined(_HIGH_LEVEL_IF_FORM)
10298    int          else_sh_idx;
10299    int          endif_idx;
10300    int          if_sh_idx;
10301 # else
10302    int          label1;
10303    int          label2;
10304 # endif
10305 
10306 
10307    TRACE (Func_Entry, "determine_lb_ub", NULL);
10308 
10309    /* if start <= end => lb=start, ub=end */
10310    /* else if end < start => lb=end, ub=start */
10311 
10312    /* if not both constant, and stride is constant, then assume direction */
10313 
10314    line = BD_LINE_NUM(bd_idx);
10315    col = BD_COLUMN_NUM(bd_idx);
10316 
10317    end_list_idx = IL_NEXT_LIST_IDX(start_list_idx);
10318    stride_list_idx = IL_NEXT_LIST_IDX(end_list_idx);
10319 
10320    if (IL_FLD(start_list_idx) == CN_Tbl_Idx &&
10321        IL_FLD(end_list_idx) == CN_Tbl_Idx) {
10322 
10323       if (fold_relationals(IL_IDX(start_list_idx),
10324                            IL_IDX(end_list_idx),
10325                            Le_Opr)) {
10326 
10327          BD_LB_FLD(bd_idx,idx) = IL_FLD(start_list_idx);
10328          BD_LB_IDX(bd_idx,idx) = IL_IDX(start_list_idx);
10329 
10330          BD_UB_FLD(bd_idx,idx) = IL_FLD(end_list_idx);
10331          BD_UB_IDX(bd_idx,idx) = IL_IDX(end_list_idx);
10332       }
10333       else {
10334          BD_LB_FLD(bd_idx,idx) = IL_FLD(end_list_idx);
10335          BD_LB_IDX(bd_idx,idx) = IL_IDX(end_list_idx);
10336 
10337          BD_UB_FLD(bd_idx,idx) = IL_FLD(start_list_idx);
10338          BD_UB_IDX(bd_idx,idx) = IL_IDX(start_list_idx);
10339       }
10340    }
10341    else if (IL_FLD(stride_list_idx) == CN_Tbl_Idx) {
10342 
10343       if (compare_cn_and_value(IL_IDX(stride_list_idx),
10344                                0,
10345                                Gt_Opr)) {
10346 
10347          BD_LB_FLD(bd_idx,idx) = IL_FLD(start_list_idx);
10348          BD_LB_IDX(bd_idx,idx) = IL_IDX(start_list_idx);
10349 
10350          BD_UB_FLD(bd_idx,idx) = IL_FLD(end_list_idx);
10351          BD_UB_IDX(bd_idx,idx) = IL_IDX(end_list_idx);
10352       }
10353       else {
10354          BD_LB_FLD(bd_idx,idx) = IL_FLD(end_list_idx);
10355          BD_LB_IDX(bd_idx,idx) = IL_IDX(end_list_idx);
10356 
10357          BD_UB_FLD(bd_idx,idx) = IL_FLD(start_list_idx);
10358          BD_UB_IDX(bd_idx,idx) = IL_IDX(start_list_idx);
10359       }
10360    }
10361    else {
10362       tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
10363 
10364       BD_LB_FLD(bd_idx,idx) = AT_Tbl_Idx;
10365       BD_LB_IDX(bd_idx,idx) = tmp_idx;
10366 
10367       type_idx = (IL_FLD(start_list_idx) == CN_Tbl_Idx ?
10368                      CN_TYPE_IDX(IL_IDX(start_list_idx)) : 
10369                      ATD_TYPE_IDX((IL_IDX(start_list_idx))));
10370 
10371       if (TYP_LINEAR(type_idx)<TYP_LINEAR((IL_FLD(end_list_idx) == CN_Tbl_Idx ?
10372                      CN_TYPE_IDX(IL_IDX(end_list_idx)) : 
10373                      ATD_TYPE_IDX((IL_IDX(end_list_idx)))))) {
10374 
10375          type_idx = (IL_FLD(end_list_idx) == CN_Tbl_Idx ?
10376                      CN_TYPE_IDX(IL_IDX(end_list_idx)) : 
10377                      ATD_TYPE_IDX((IL_IDX(end_list_idx))));
10378       }
10379 
10380       ATD_TYPE_IDX(tmp_idx) = type_idx;
10381       AT_SEMANTICS_DONE(tmp_idx)= TRUE;
10382       ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
10383 
10384 
10385       tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
10386 
10387       BD_UB_FLD(bd_idx,idx) = AT_Tbl_Idx;
10388       BD_UB_IDX(bd_idx,idx) = tmp_idx;
10389 
10390       ATD_TYPE_IDX(tmp_idx) = type_idx;
10391       AT_SEMANTICS_DONE(tmp_idx)= TRUE;
10392       ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
10393 
10394 # if defined(_HIGH_LEVEL_IF_FORM)
10395 
10396       gt_idx = gen_ir(IL_FLD(start_list_idx), IL_IDX(start_list_idx),
10397                       Gt_Opr, CG_LOGICAL_DEFAULT_TYPE, line, col,
10398                       IL_FLD(end_list_idx), IL_IDX(end_list_idx));
10399 
10400 
10401       if_idx = gen_ir(IR_Tbl_Idx, gt_idx,
10402                       If_Opr, CG_LOGICAL_DEFAULT_TYPE, line, col,
10403                       NO_Tbl_Idx, NULL_IDX);
10404 
10405       gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
10406       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10407       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
10408 
10409       if_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
10410 # else
10411 
10412       gt_idx = gen_ir(IL_FLD(start_list_idx), IL_IDX(start_list_idx),
10413                       Le_Opr, CG_LOGICAL_DEFAULT_TYPE, line, col,
10414                       IL_FLD(end_list_idx), IL_IDX(end_list_idx));
10415 
10416 
10417       label1 = gen_internal_lbl(line);
10418       label2 = gen_internal_lbl(line);
10419 
10420       if_idx = gen_ir(IR_Tbl_Idx, gt_idx,
10421                  Br_True_Opr, CG_LOGICAL_DEFAULT_TYPE, line, col,
10422                       AT_Tbl_Idx, label1);
10423 
10424       gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
10425       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10426       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
10427 
10428 # endif
10429 
10430       /* if (start > end) => lb=end ub=start */
10431 
10432       asg_idx = gen_ir(BD_LB_FLD(bd_idx,idx), BD_LB_IDX(bd_idx,idx),
10433                    Asg_Opr, type_idx, line, col,
10434                        IL_FLD(end_list_idx), IL_IDX(end_list_idx));
10435 
10436       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10437       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10438       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10439 
10440       asg_idx = gen_ir(BD_UB_FLD(bd_idx,idx), BD_UB_IDX(bd_idx,idx),
10441                    Asg_Opr, type_idx, line, col,
10442                        IL_FLD(start_list_idx), IL_IDX(start_list_idx));
10443 
10444       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10445       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10446       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10447 
10448 
10449 # if defined(_HIGH_LEVEL_IF_FORM)
10450       else_idx = gen_ir(SH_Tbl_Idx, if_sh_idx,
10451                    Else_Opr, CG_LOGICAL_DEFAULT_TYPE, line, col,
10452                         NO_Tbl_Idx, NULL_IDX);
10453 
10454       gen_sh(Before, Else_Stmt, line, col, FALSE, FALSE, TRUE);
10455       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10456       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = else_idx;
10457       SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_sh_idx;
10458 
10459       else_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
10460 # else
10461       else_idx = gen_ir(NO_Tbl_Idx, NULL_IDX,
10462                    Br_Uncond_Opr, TYPELESS_DEFAULT_TYPE, line, col,
10463                         AT_Tbl_Idx, label2);
10464 
10465       gen_sh(Before, Goto_Stmt, line, col, FALSE, FALSE, TRUE);
10466       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10467       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = else_idx;
10468 
10469       else_idx = gen_ir(AT_Tbl_Idx, label1,
10470                    Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
10471                         NO_Tbl_Idx, NULL_IDX);
10472 
10473       gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
10474       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10475       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = else_idx;
10476 
10477       AT_DEFINED(label1) = TRUE;
10478       ATL_DEF_STMT_IDX(label1) = SH_PREV_IDX(curr_stmt_sh_idx);
10479 # endif
10480 
10481       /* else  => lb=start ub=end */
10482 
10483       asg_idx = gen_ir(BD_LB_FLD(bd_idx,idx), BD_LB_IDX(bd_idx,idx),
10484                    Asg_Opr, type_idx, line, col,
10485                        IL_FLD(start_list_idx), IL_IDX(start_list_idx));
10486 
10487       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10488       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10489       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10490 
10491       asg_idx = gen_ir(BD_UB_FLD(bd_idx,idx), BD_UB_IDX(bd_idx,idx),
10492                    Asg_Opr, type_idx, line, col,
10493                        IL_FLD(end_list_idx), IL_IDX(end_list_idx));
10494 
10495       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10496       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10497       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10498 
10499 
10500 # if defined(_HIGH_LEVEL_IF_FORM)
10501       endif_idx = gen_ir(SH_Tbl_Idx, if_sh_idx,
10502                     Endif_Opr, TYPELESS_DEFAULT_TYPE, line, col,
10503                          NO_Tbl_Idx, NULL_IDX);
10504 
10505       gen_sh(Before, End_If_Stmt, line, col, FALSE, FALSE, TRUE);
10506       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10507       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = endif_idx;
10508       SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = else_sh_idx;
10509 
10510       IR_FLD_R(if_idx) = SH_Tbl_Idx;
10511       IR_IDX_R(if_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
10512       IR_LINE_NUM_R(if_idx) = line;
10513       IR_COL_NUM_R(if_idx) = col;
10514 # else
10515       else_idx = gen_ir(AT_Tbl_Idx, label2,
10516                    Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
10517                         NO_Tbl_Idx, NULL_IDX);
10518 
10519       gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
10520       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10521       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = else_idx;
10522 
10523       AT_DEFINED(label2) = TRUE;
10524       ATL_DEF_STMT_IDX(label2) = SH_PREV_IDX(curr_stmt_sh_idx);
10525 # endif
10526 
10527       
10528    }
10529 
10530 
10531    TRACE (Func_Exit, "determine_lb_ub", NULL);
10532 
10533    return;
10534 
10535 }  /* determine_lb_ub */
10536 
10537 /******************************************************************************\
10538 |*                                                                            *|
10539 |* Description:                                                               *|
10540 |*      <description>                                                         *|
10541 |*                                                                            *|
10542 |* Input parameters:                                                          *|
10543 |*      NONE                                                                  *|
10544 |*                                                                            *|
10545 |* Output parameters:                                                         *|
10546 |*      NONE                                                                  *|
10547 |*                                                                            *|
10548 |* Returns:                                                                   *|
10549 |*      NOTHING                                                               *|
10550 |*                                                                            *|
10551 \******************************************************************************/
10552 
10553 void gen_forall_if_mask(int     start_sh_idx,
10554                         int     end_sh_idx)
10555 
10556 {
10557    int          col;
10558    opnd_type    forall_mask_opnd;
10559    int          line;
10560    int          list_idx;
10561 
10562    TRACE (Func_Entry, "gen_forall_if_mask", NULL);
10563 
10564    line = SH_GLB_LINE(start_sh_idx);
10565    col = SH_COL_NUM(start_sh_idx);
10566 
10567 # ifdef _DEBUG
10568    if (active_forall_sh_idx == NULL_IDX) {
10569       PRINTMSG(line, 626, Internal, col,
10570                "active_forall_sh_idx", "gen_forall_if_mask");
10571    }
10572 # endif
10573 
10574    list_idx = IR_IDX_R(SH_IR_IDX(active_forall_sh_idx));
10575 
10576    while (list_idx &&
10577           IL_FLD(list_idx) == IL_Tbl_Idx) {
10578       list_idx = IL_NEXT_LIST_IDX(list_idx);
10579    }
10580 
10581    if (list_idx &&
10582        IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
10583 
10584       copy_subtree(&IL_OPND(IL_NEXT_LIST_IDX(list_idx)), &forall_mask_opnd);
10585 
10586    }
10587    else {
10588       goto EXIT;
10589    }
10590 
10591 
10592    gen_if_stmt(&forall_mask_opnd, 
10593                start_sh_idx,
10594                end_sh_idx,
10595                NULL_IDX,
10596                NULL_IDX,
10597                line,
10598                col);
10599 
10600 
10601 EXIT:
10602 
10603    TRACE (Func_Exit, "gen_forall_if_mask", NULL);
10604 
10605    return;
10606 
10607 }  /* gen_forall_if_mask */
10608 
10609 /******************************************************************************\
10610 |*                                                                            *|
10611 |* Description:                                                               *|
10612 |*      <description>                                                         *|
10613 |*                                                                            *|
10614 |* Input parameters:                                                          *|
10615 |*      NONE                                                                  *|
10616 |*                                                                            *|
10617 |* Output parameters:                                                         *|
10618 |*      NONE                                                                  *|
10619 |*                                                                            *|
10620 |* Returns:                                                                   *|
10621 |*      NOTHING                                                               *|
10622 |*                                                                            *|
10623 \******************************************************************************/
10624 
10625 static boolean forall_mask_needs_tmp(opnd_type  *top_opnd)
10626 
10627 {
10628    boolean      needs_tmp = FALSE;
10629    opnd_type    lhs_opnd;
10630    opnd_type    mask_opnd;
10631    int          sh_idx;
10632 
10633 
10634    TRACE (Func_Entry, "forall_mask_needs_tmp", NULL);
10635 
10636    sh_idx = active_forall_sh_idx;
10637 
10638    COPY_OPND(mask_opnd, (*top_opnd));
10639    copy_subtree(&mask_opnd, &mask_opnd);
10640    process_attr_links(&mask_opnd);
10641 
10642    while (sh_idx != IR_IDX_L(SH_IR_IDX(active_forall_sh_idx))) {
10643       if (SH_STMT_TYPE(sh_idx) == Assignment_Stmt) {
10644          COPY_OPND(lhs_opnd, IR_OPND_L(SH_IR_IDX(sh_idx)));
10645          copy_subtree(&lhs_opnd, &lhs_opnd);
10646          process_attr_links(&lhs_opnd);
10647 
10648          check_dependence(&needs_tmp,
10649                           lhs_opnd,
10650                           mask_opnd);
10651 
10652          if (OPND_FLD(lhs_opnd) == IR_Tbl_Idx) {
10653             free_ir_stream(OPND_IDX(lhs_opnd));
10654          }
10655 
10656          if (needs_tmp) {
10657             break;
10658          }
10659       }
10660       sh_idx = SH_NEXT_IDX(sh_idx);
10661    }
10662 
10663    if (OPND_FLD(mask_opnd) == IR_Tbl_Idx) {
10664       free_ir_stream(OPND_IDX(mask_opnd));
10665    }
10666 
10667    TRACE (Func_Exit, "forall_mask_needs_tmp", NULL);
10668 
10669    return(needs_tmp);
10670 
10671 }  /* forall_mask_needs_tmp */
10672 
10673 /******************************************************************************\
10674 |*                                                                            *|
10675 |* Description:                                                               *|
10676 |*      <description>                                                         *|
10677 |*                                                                            *|
10678 |* Input parameters:                                                          *|
10679 |*      NONE                                                                  *|
10680 |*                                                                            *|
10681 |* Output parameters:                                                         *|
10682 |*      NONE                                                                  *|
10683 |*                                                                            *|
10684 |* Returns:                                                                   *|
10685 |*      NOTHING                                                               *|
10686 |*                                                                            *|
10687 \******************************************************************************/
10688 
10689 static void process_attr_links(opnd_type        *opnd)
10690 
10691 {
10692    int          attr_idx;
10693    int          ir_idx;
10694    int          list_idx;
10695 
10696 
10697    TRACE (Func_Entry, "process_attr_links", NULL);
10698 
10699    switch (OPND_FLD((*opnd))) {
10700    case AT_Tbl_Idx:
10701       attr_idx = OPND_IDX((*opnd));
10702 
10703       while (AT_ATTR_LINK(attr_idx)) {
10704          attr_idx = AT_ATTR_LINK(attr_idx);
10705       }
10706 
10707       OPND_IDX((*opnd)) = attr_idx;
10708 
10709       break;
10710 
10711    case CN_Tbl_Idx:
10712    case SH_Tbl_Idx:
10713    case NO_Tbl_Idx:
10714       break;
10715 
10716    case IR_Tbl_Idx:
10717       ir_idx = OPND_IDX((*opnd));
10718       process_attr_links(&IR_OPND_L(ir_idx));
10719       process_attr_links(&IR_OPND_R(ir_idx));
10720       break;
10721 
10722    case IL_Tbl_Idx:
10723       list_idx = OPND_IDX((*opnd));
10724       while (list_idx) {
10725          process_attr_links(&IL_OPND(list_idx));
10726          list_idx = IL_NEXT_LIST_IDX(list_idx);
10727       }
10728       break;
10729 
10730    }
10731 
10732    TRACE (Func_Exit, "process_attr_links", NULL);
10733 
10734    return;
10735 
10736 }  /* process_attr_links */
10737 
10738 /******************************************************************************\
10739 |*                                                                            *|
10740 |* Description:                                                               *|
10741 |*      <description>                                                         *|
10742 |*                                                                            *|
10743 |* Input parameters:                                                          *|
10744 |*      NONE                                                                  *|
10745 |*                                                                            *|
10746 |* Output parameters:                                                         *|
10747 |*      NONE                                                                  *|
10748 |*                                                                            *|
10749 |* Returns:                                                                   *|
10750 |*      NOTHING                                                               *|
10751 |*                                                                            *|
10752 \******************************************************************************/
10753 
10754 static int gen_forall_derived_type(int  type_idx,
10755                                    int  rank,
10756                                    int  line,
10757                                    int  col)
10758 
10759 {
10760    int                  attr_idx;
10761    int                  dt_idx;
10762    int                  length;
10763    id_str_type          name;
10764    int                  np_idx;
10765    int                  sn_idx;
10766    int                  dt_type_idx;
10767 
10768    extern void set_up_fake_dt_blk(int);
10769 
10770 
10771    TRACE (Func_Entry, "gen_forall_derived_type", NULL);
10772 
10773    /****************************\
10774    |* create derived type attr *|
10775    \****************************/
10776 
10777    CREATE_ID(name, " ", 1);
10778 
10779    dt_counter++;
10780 
10781 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
10782    length = sprintf(name.string, "dt$%d", dt_counter);
10783 # else
10784    sprintf(name.string, "dt$%d", dt_counter);
10785    length = strlen(name.string);
10786 # endif
10787 
10788    NTR_NAME_POOL(&(name.words[0]), length, np_idx);
10789 
10790    NTR_ATTR_TBL(dt_idx);
10791    AT_DEF_LINE(dt_idx)         = line;
10792    AT_DEF_COLUMN(dt_idx)       = col;
10793    AT_NAME_LEN(dt_idx)         = length;
10794    AT_NAME_IDX(dt_idx)         = np_idx;
10795    AT_DEFINED(dt_idx)          = TRUE;
10796    AT_LOCKED_IN(dt_idx)        = TRUE;
10797    AT_OBJ_CLASS(dt_idx)        = Derived_Type;
10798    ATT_SCP_IDX(dt_idx)         = curr_scp_idx;
10799    ATT_NUMERIC_CPNT(dt_idx)    = TRUE;
10800    ATT_DCL_NUMERIC_SEQ(dt_idx) = TRUE;
10801    ATT_SEQUENCE_SET(dt_idx)    = TRUE;
10802    AT_SEMANTICS_DONE(dt_idx)   = TRUE;
10803    ATT_POINTER_CPNT(dt_idx)    = TRUE;
10804    ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx;
10805    ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX;
10806 
10807    if (cmd_line_flags.s_pointer8) {
10808       ATT_ALIGNMENT(dt_idx) = Align_64;
10809    }
10810    else {
10811       ATT_ALIGNMENT(dt_idx) = WORD_ALIGN;
10812    }
10813 
10814    ATT_NUM_CPNTS(dt_idx) = 1;
10815 
10816    /*************************\
10817    |* now for the component *|
10818    \*************************/
10819 
10820    /* pointer component */
10821 
10822    CREATE_ID(TOKEN_ID(token), "PTR", 3);
10823    TOKEN_LEN(token)         = 3;
10824    TOKEN_VALUE(token)       = Tok_Id;
10825    TOKEN_LINE(token)        = line;
10826    TOKEN_COLUMN(token)      = col;
10827 
10828    NTR_SN_TBL(sn_idx);
10829    NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx);
10830    NTR_ATTR_TBL(attr_idx);
10831    AT_OBJ_CLASS(attr_idx)  = Data_Obj;
10832    AT_DEF_LINE(attr_idx)   = line;
10833    AT_DEF_COLUMN(attr_idx) = col;
10834    AT_NAME_LEN(attr_idx)   = TOKEN_LEN(token);
10835    AT_NAME_IDX(attr_idx)   = np_idx;
10836    SN_NAME_LEN(sn_idx)     = TOKEN_LEN(token);
10837    SN_NAME_IDX(sn_idx)     = np_idx;
10838    SN_ATTR_IDX(sn_idx)     = attr_idx;
10839 
10840    AT_SEMANTICS_DONE(attr_idx) = TRUE;
10841    ATD_CLASS(attr_idx)         = Struct_Component;
10842    ATD_DERIVED_TYPE_IDX(attr_idx)       = dt_idx;
10843    AT_TYPED(attr_idx)          = TRUE;
10844 
10845    ATD_TYPE_IDX(attr_idx)      = type_idx;
10846    ATD_ARRAY_IDX(attr_idx)     = rank;
10847 
10848    ATD_OFFSET_ASSIGNED(attr_idx) = TRUE;
10849    ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx;
10850    ATD_CPNT_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX;
10851    ATT_FIRST_CPNT_IDX(dt_idx) = sn_idx;
10852 
10853    set_up_fake_dt_blk(dt_idx);
10854    assign_offset(attr_idx);
10855    set_up_fake_dt_blk(NULL_IDX);
10856 
10857    CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
10858    TYP_TYPE(TYP_WORK_IDX)   = Structure;
10859    TYP_LINEAR(TYP_WORK_IDX) = Structure_Type;
10860    TYP_IDX(TYP_WORK_IDX)    = dt_idx;
10861    dt_type_idx              = ntr_type_tbl();
10862 
10863    TRACE (Func_Exit, "gen_forall_derived_type", NULL);
10864 
10865    return(dt_type_idx);
10866 
10867 }  /* gen_forall_derived_type */
10868 
10869 /******************************************************************************\
10870 |*                                                                            *|
10871 |* Description:                                                               *|
10872 |*      <description>                                                         *|
10873 |*                                                                            *|
10874 |* Input parameters:                                                          *|
10875 |*      NONE                                                                  *|
10876 |*                                                                            *|
10877 |* Output parameters:                                                         *|
10878 |*      NONE                                                                  *|
10879 |*                                                                            *|
10880 |* Returns:                                                                   *|
10881 |*      NOTHING                                                               *|
10882 |*                                                                            *|
10883 \******************************************************************************/
10884 
10885 boolean check_where_conformance(expr_arg_type   *exp_desc)
10886 
10887 {
10888    int                  i;
10889    boolean              ok = TRUE;
10890    int                  tmp_idx;
10891 
10892    TRACE (Func_Entry, "check_where_conformance", NULL);
10893 
10894 # if 0
10895 
10896 /* We keep the original mask or logical expression
10897  * instead of generating array types temporary variables
10898  * especially  unwanted  "deferred shape" logical arrays
10899  * such as  "LOGICAL($) t$1(:,:,:)" ---fzhao
10900  */
10901 
10902    tmp_idx = find_left_attr(&IR_OPND_L(where_ir_idx));
10903 
10904 # ifdef _DEBUG
10905    if (AT_OBJ_CLASS(tmp_idx) != Data_Obj ||
10906        ATD_CLASS(tmp_idx) != Compiler_Tmp) {
10907       PRINTMSG(IR_LINE_NUM(where_ir_idx), 626, Internal,
10908                IR_COL_NUM(where_ir_idx),
10909                "Compiler_Tmp", "check_where_conformance");
10910    }
10911 # endif
10912 
10913    if (exp_desc->rank != BD_RANK(ATD_ARRAY_IDX(tmp_idx))) {
10914       ok = FALSE;
10915    }
10916    else {
10917       for (i = 0; i < exp_desc->rank; i++) {
10918          if (OPND_FLD(exp_desc->shape[i])           == CN_Tbl_Idx &&
10919              BD_XT_FLD(ATD_ARRAY_IDX(tmp_idx), i+1) == CN_Tbl_Idx &&
10920              fold_relationals(OPND_IDX(exp_desc->shape[i]),
10921                            BD_XT_IDX(ATD_ARRAY_IDX(tmp_idx), i+1),
10922                               Ne_Opr)) {
10923 
10924             /* non conforming array syntax */
10925 
10926             ok = FALSE;
10927             break;
10928          }
10929       }
10930    }
10931 # endif
10932    ok = TRUE;
10933 
10934    TRACE (Func_Exit, "check_where_conformance", NULL);
10935 
10936    return(ok);
10937 
10938 }  /* check_where_conformance */
10939 
10940 /******************************************************************************\
10941 |*                                                                            *|
10942 |* Description:                                                               *|
10943 |*      <description>                                                         *|
10944 |*                                                                            *|
10945 |* Input parameters:                                                          *|
10946 |*      NONE                                                                  *|
10947 |*                                                                            *|
10948 |* Output parameters:                                                         *|
10949 |*      NONE                                                                  *|
10950 |*                                                                            *|
10951 |* Returns:                                                                   *|
10952 |*      NOTHING                                                               *|
10953 |*                                                                            *|
10954 \******************************************************************************/
10955 
10956 static void setup_interchange_level_list(opnd_type      do_var_opnd)
10957 
10958 {
10959    int          count;
10960    boolean      found_non_tmp;
10961    int          il_idx;
10962    int          ir_idx;
10963 
10964 
10965    TRACE (Func_Entry, "setup_interchange_level_list", NULL);
10966 
10967    /* This is only necessary for pdgcs based platforms.  This     */
10968    /* sets up the level list to match the do list.  For example   */
10969    /* if the user specifies  interchange(k,i,j) and the do's are  */
10970    /* nested like  do i, do j, do k, then the level list should   */
10971    /* read 2, 3, 1 (as in i is 2nd in the list, j is 3rd in the   */
10972    /* list and k is 1st in the list).                             */
10973       
10974    if (cdir_switches.interchange_sh_idx != NULL_IDX) {
10975       found_non_tmp     = FALSE;
10976       ir_idx            = SH_IR_IDX(cdir_switches.interchange_sh_idx);
10977       il_idx            = IR_IDX_L(ir_idx);
10978       count             = 1;
10979 
10980       while (il_idx != NULL_IDX) {
10981 
10982          if (IL_FLD(il_idx) == AT_Tbl_Idx &&
10983              OPND_IDX(do_var_opnd) == IL_IDX(il_idx)) {
10984             break;  /* This do var is #count in the list */
10985          }
10986 
10987          if (IL_FLD(il_idx) != AT_Tbl_Idx ||
10988             AT_OBJ_CLASS(IL_IDX(il_idx)) != Data_Obj ||
10989             ATD_CLASS(IL_IDX(il_idx)) != Compiler_Tmp) {
10990             found_non_tmp = TRUE;
10991          }
10992          il_idx         = IL_NEXT_LIST_IDX(il_idx);
10993          ++count;
10994       }
10995 
10996       cdir_switches.interchange_level = count;
10997 
10998       if (!found_non_tmp) {
10999          cdir_switches.interchange_sh_idx = NULL_IDX;
11000       }
11001    }
11002 
11003 
11004    TRACE (Func_Exit, "setup_interchange_level_list", NULL);
11005 
11006    return;
11007 
11008 }  /* setup_interchange_level_list */