Open64: osprey/crayf90/fe90/s_ctl

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