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