|
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_asg_expr.c 5.10 10/26/99 17:20:56\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 00046 # include "globals.m" 00047 # include "tokens.m" 00048 # include "sytb.m" 00049 # include "s_globals.m" 00050 # include "debug.m" 00051 # include "s_asg_expr.m" 00052 00053 # include "globals.h" 00054 # include "tokens.h" 00055 # include "sytb.h" 00056 # include "s_globals.h" 00057 00058 # include "s_asg_expr.h" 00059 00060 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 00061 # include <fortran.h> 00062 # endif 00063 00064 boolean has_present_opr; 00065 00066 /*****************************************************************\ 00067 |* Function prototypes of static functions declared in this file. | 00068 \*****************************************************************/ 00069 00070 static boolean array_construct_semantics(opnd_type *, expr_arg_type *); 00071 static boolean bin_array_syntax_check(expr_arg_type *, expr_arg_type *, 00072 expr_arg_type *, int, int); 00073 00074 static void make_logical_array_tmp(opnd_type *, expr_arg_type *); 00075 static void fold_nested_substrings(int); 00076 static boolean uplus_opr_handler(opnd_type *, expr_arg_type *); 00077 static boolean power_opr_handler(opnd_type *, expr_arg_type *); 00078 static boolean mult_opr_handler(opnd_type *, expr_arg_type *); 00079 static boolean minus_opr_handler(opnd_type *, expr_arg_type *); 00080 static boolean plus_opr_handler(opnd_type *, expr_arg_type *); 00081 static boolean concat_opr_handler(opnd_type *, expr_arg_type *); 00082 static boolean eq_opr_handler(opnd_type *, expr_arg_type *); 00083 static boolean lg_opr_handler(opnd_type *, expr_arg_type *); 00084 static boolean lt_opr_handler(opnd_type *, expr_arg_type *); 00085 static boolean not_opr_handler(opnd_type *, expr_arg_type *); 00086 static boolean and_opr_handler(opnd_type *, expr_arg_type *); 00087 static boolean defined_un_opr_handler(opnd_type *, expr_arg_type *); 00088 static boolean defined_bin_opr_handler(opnd_type *, expr_arg_type *); 00089 static boolean max_opr_handler(opnd_type *, expr_arg_type *); 00090 static boolean struct_opr_handler(opnd_type *, expr_arg_type *, int); 00091 static boolean struct_construct_opr_handler(opnd_type *, expr_arg_type *); 00092 static boolean array_construct_opr_handler(opnd_type *, expr_arg_type *); 00093 static boolean subscript_opr_handler(opnd_type *, expr_arg_type *, int); 00094 static boolean substring_opr_handler(opnd_type *, expr_arg_type *, int); 00095 static boolean triplet_opr_handler(opnd_type *, expr_arg_type *); 00096 static boolean dealloc_obj_opr_handler(opnd_type *, expr_arg_type *, int); 00097 static boolean alloc_obj_opr_handler(opnd_type *, expr_arg_type *, int); 00098 static boolean cvrt_opr_handler(opnd_type *, expr_arg_type *); 00099 static boolean paren_opr_handler(opnd_type *, expr_arg_type *); 00100 static boolean stmt_func_call_opr_handler(opnd_type *, expr_arg_type *); 00101 static int implied_do_depth(opnd_type *); 00102 static long64 outer_imp_do_count(opnd_type *); 00103 static void lower_ptr_asg(expr_arg_type *); 00104 # if defined(COARRAY_FORTRAN) 00105 static void translate_distant_ref1(opnd_type *, expr_arg_type *, int); 00106 00107 # if defined(_TARGET_OS_MAX) 00108 static void translate_t3e_distant_ref(opnd_type *, expr_arg_type *, int); 00109 static void translate_t3e_dv_component(opnd_type *, expr_arg_type *); 00110 static int capture_bounds_from_dv(int, int, int); 00111 # endif 00112 00113 static void translate_distant_dv_ref(opnd_type *, expr_arg_type *, int); 00114 static void translate_distant_ref2(opnd_type *, expr_arg_type *, int); 00115 static int set_up_pe_offset_attr(void); 00116 static void gen_bias_ref(opnd_type *); 00117 static void linearize_pe_dims(int, int, int, int, opnd_type *); 00118 # endif 00119 #ifdef KEY /* Bug 934 */ 00120 static boolean expr_sem_d(opnd_type *result_opnd, expr_arg_type *exp_desc, 00121 boolean derived_assign); 00122 static boolean expr_semantics_d (opnd_type *result_opnd, 00123 expr_arg_type *exp_desc, boolean derived_assign); 00124 #endif /* KEY Bug 934 */ 00125 00126 00127 # if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) 00128 # pragma inline uplus_opr_handler 00129 # pragma inline power_opr_handler 00130 # pragma inline mult_opr_handler 00131 # pragma inline minus_opr_handler 00132 # pragma inline plus_opr_handler 00133 # pragma inline concat_opr_handler 00134 # pragma inline eq_opr_handler 00135 # pragma inline lg_opr_handler 00136 # pragma inline lt_opr_handler 00137 # pragma inline not_opr_handler 00138 # pragma inline and_opr_handler 00139 # pragma inline defined_un_opr_handler 00140 # pragma inline defined_bin_opr_handler 00141 # pragma inline max_opr_handler 00142 # pragma inline struct_opr_handler 00143 # pragma inline struct_construct_opr_handler 00144 # pragma inline array_construct_opr_handler 00145 # pragma inline subscript_opr_handler 00146 # pragma inline substring_opr_handler 00147 # pragma inline triplet_opr_handler 00148 # pragma inline dealloc_obj_opr_handler 00149 # pragma inline alloc_obj_opr_handler 00150 # pragma inline cvrt_opr_handler 00151 # pragma inline paren_opr_handler 00152 # pragma inline stmt_func_call_opr_handler 00153 # else 00154 # pragma _CRI inline uplus_opr_handler 00155 # pragma _CRI inline power_opr_handler 00156 # pragma _CRI inline mult_opr_handler 00157 # pragma _CRI inline minus_opr_handler 00158 # pragma _CRI inline plus_opr_handler 00159 # pragma _CRI inline concat_opr_handler 00160 # pragma _CRI inline eq_opr_handler 00161 # pragma _CRI inline lg_opr_handler 00162 # pragma _CRI inline lt_opr_handler 00163 # pragma _CRI inline not_opr_handler 00164 # pragma _CRI inline and_opr_handler 00165 # pragma _CRI inline defined_un_opr_handler 00166 # pragma _CRI inline defined_bin_opr_handler 00167 # pragma _CRI inline max_opr_handler 00168 # pragma _CRI inline struct_opr_handler 00169 # pragma _CRI inline struct_construct_opr_handler 00170 # pragma _CRI inline array_construct_opr_handler 00171 # pragma _CRI inline subscript_opr_handler 00172 # pragma _CRI inline substring_opr_handler 00173 # pragma _CRI inline triplet_opr_handler 00174 # pragma _CRI inline dealloc_obj_opr_handler 00175 # pragma _CRI inline alloc_obj_opr_handler 00176 # pragma _CRI inline cvrt_opr_handler 00177 # pragma _CRI inline paren_opr_handler 00178 # pragma _CRI inline stmt_func_call_opr_handler 00179 # endif 00180 00181 00182 /******************************************************************************\ 00183 |* *| 00184 |* Description: *| 00185 |* Top semantics routine for assignment and pointer assignment. *| 00186 |* *| 00187 |* Input parameters: *| 00188 |* NONE *| 00189 |* *| 00190 |* Output parameters: *| 00191 |* NONE *| 00192 |* *| 00193 |* Returns: *| 00194 |* NONE *| 00195 |* *| 00196 \******************************************************************************/ 00197 00198 void assignment_stmt_semantics (void) 00199 00200 { 00201 int asg_idx; 00202 int attr_idx; 00203 int col; 00204 expr_arg_type exp_desc_l; 00205 expr_arg_type exp_desc_r; 00206 opnd_type forall_tmp_opnd; 00207 opnd_type forall_tmp_opnd_l; 00208 boolean forall_dependence; 00209 expr_arg_type forall_exp_desc; 00210 int i; 00211 int ir_idx; 00212 int idx; 00213 char l_err_word[40]; 00214 opnd_type l_opnd; 00215 int line; 00216 int list_idx; 00217 int label_idx; 00218 boolean ok = TRUE; 00219 opnd_type opnd; 00220 int opnd_col; 00221 int opnd_line; 00222 char r_err_word[40]; 00223 opnd_type r_opnd; 00224 linear_type_type result_type; 00225 int save_curr_stmt_sh_idx; 00226 int save_where_ir_idx; 00227 00228 00229 TRACE (Func_Entry, "assignment_stmt_semantics", NULL); 00230 00231 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 00232 00233 line = IR_LINE_NUM(ir_idx); 00234 col = IR_COL_NUM(ir_idx); 00235 00236 if (IR_OPR(ir_idx) == Asg_Opr) { 00237 00238 00239 /* clear the where_ir_idx so that intrinsics on left hand */ 00240 /* side (in subscripts) are handled without mask. */ 00241 00242 save_where_ir_idx = where_ir_idx; 00243 where_ir_idx = NULL_IDX; 00244 00245 if (active_forall_sh_idx) { 00246 defer_stmt_expansion = TRUE; 00247 } 00248 00249 xref_state = CIF_Symbol_Modification; 00250 COPY_OPND(l_opnd, IR_OPND_L(ir_idx)); 00251 exp_desc_l.rank = 0; 00252 ok = expr_semantics(&l_opnd, &exp_desc_l); 00253 COPY_OPND(IR_OPND_L(ir_idx), l_opnd); 00254 00255 where_ir_idx = save_where_ir_idx; 00256 00257 if (IR_FLD_R(ir_idx) == IR_Tbl_Idx && 00258 IR_OPR(IR_IDX_R(ir_idx)) == Call_Opr && 00259 AT_IS_INTRIN(IR_IDX_L(IR_IDX_R(ir_idx))) && 00260 (strcmp(AT_OBJ_NAME_PTR(IR_IDX_L(IR_IDX_R(ir_idx))), "NULL") == 0)) { 00261 ok = FALSE; 00262 PRINTMSG(IR_LINE_NUM_R(ir_idx), 1557, Error, IR_COL_NUM_R(ir_idx)); 00263 } 00264 00265 if (! ok) { 00266 /* intentionally blank */ 00267 } 00268 else if (exp_desc_l.constant) { 00269 ok = FALSE; 00270 00271 if (OPND_FLD(l_opnd) == AT_Tbl_Idx && 00272 AT_OBJ_CLASS(OPND_IDX(l_opnd)) == Data_Obj && 00273 ATD_SYMBOLIC_CONSTANT(OPND_IDX(l_opnd))) { 00274 PRINTMSG(IR_LINE_NUM(ir_idx), 1632, Error, IR_COL_NUM(ir_idx), 00275 AT_OBJ_NAME_PTR(OPND_IDX(l_opnd))); 00276 } 00277 else { 00278 PRINTMSG(IR_LINE_NUM(ir_idx), 326, Error, IR_COL_NUM(ir_idx)); 00279 } 00280 } 00281 else if (SH_COMPILER_GEN(curr_stmt_sh_idx)) { 00282 /* intentionally empty, to prevent the following clauses */ 00283 00284 } 00285 else if (! check_for_legal_define(&l_opnd)) { 00286 ok = FALSE; 00287 } 00288 00289 if (cif_flags & MISC_RECS) { 00290 cif_stmt_type_rec(TRUE, 00291 (exp_desc_l.rank == 0) ? 00292 CIF_Assignment_Stmt : CIF_Array_Assignment_Stmt, 00293 statement_number); 00294 } 00295 00296 xref_state = CIF_Symbol_Reference; 00297 COPY_OPND(r_opnd, IR_OPND_R(ir_idx)); 00298 exp_desc_r.rank = 0; 00299 #ifdef KEY /* Bug 934 */ 00300 ok &= expr_semantics_d(&r_opnd, &exp_desc_r, 00301 (exp_desc_l.type == Structure)); 00302 #else /* KEY Bug 934 */ 00303 ok &= expr_semantics(&r_opnd, &exp_desc_r); 00304 #endif /* KEY Bug 934 */ 00305 COPY_OPND(IR_OPND_R(ir_idx), r_opnd); 00306 00307 if (! ok) { 00308 goto EXIT; 00309 } 00310 00311 OPND_FLD(r_opnd) = IR_Tbl_Idx; 00312 OPND_IDX(r_opnd) = ir_idx; 00313 00314 if (exp_desc_l.rank == exp_desc_r.rank) { 00315 for (i = 0; i < exp_desc_r.rank; i++) { 00316 if (OPND_FLD(exp_desc_l.shape[i]) == CN_Tbl_Idx && 00317 OPND_FLD(exp_desc_r.shape[i]) == CN_Tbl_Idx && 00318 fold_relationals(OPND_IDX(exp_desc_l.shape[i]), 00319 OPND_IDX(exp_desc_r.shape[i]), 00320 Ne_Opr)) { 00321 00322 /* non conforming array syntax */ 00323 PRINTMSG(IR_LINE_NUM(ir_idx), 253, Error, 00324 IR_COL_NUM(ir_idx)); 00325 ok = FALSE; 00326 break; 00327 } 00328 } 00329 } 00330 00331 result_type = ASG_TYPE(exp_desc_l.linear_type, exp_desc_r.linear_type); 00332 00333 # if defined(_EXTENDED_CRI_CHAR_POINTER) 00334 if (result_type == CRI_Ch_Ptr_8 && 00335 exp_desc_r.linear_type != CRI_Ch_Ptr_8) { 00336 00337 transform_cri_ch_ptr(&l_opnd); 00338 COPY_OPND(IR_OPND_L(ir_idx), l_opnd); 00339 } 00340 # endif 00341 00342 if (result_type != Err_Res && 00343 result_type != Structure_Type && 00344 (exp_desc_l.rank == exp_desc_r.rank || exp_desc_r.rank == 0)) { 00345 00346 if (ASG_EXTN(exp_desc_l.linear_type, exp_desc_r.linear_type)) { 00347 /* check for defined asg */ 00348 00349 if (resolve_ext_opr(&r_opnd, FALSE, FALSE, FALSE, 00350 &ok, 00351 &exp_desc_l, &exp_desc_r)) { 00352 00353 SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(r_opnd); 00354 SH_STMT_TYPE(curr_stmt_sh_idx) = Call_Stmt; 00355 goto CK_WHERE; 00356 } 00357 else if (exp_desc_r.type == Character || 00358 exp_desc_r.linear_type == Short_Typeless_Const) { 00359 00360 find_opnd_line_and_column((opnd_type *) &IR_OPND_R(ir_idx), 00361 &opnd_line, 00362 &opnd_col); 00363 00364 if (exp_desc_r.type == Character) { 00365 00366 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 00367 } 00368 00369 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 00370 exp_desc_l.type_idx, 00371 opnd_line, 00372 opnd_col); 00373 exp_desc_r.type_idx = exp_desc_l.type_idx; 00374 exp_desc_r.type = exp_desc_l.type; 00375 exp_desc_r.linear_type = exp_desc_l.linear_type; 00376 } 00377 } 00378 00379 IR_RANK(ir_idx) = exp_desc_l.rank; 00380 00381 IR_TYPE_IDX(ir_idx) = exp_desc_l.type_idx; 00382 00383 } 00384 else if (result_type == Structure_Type && 00385 (exp_desc_l.rank == exp_desc_r.rank || 00386 exp_desc_r.rank == 0) && 00387 compare_derived_types(exp_desc_l.type_idx, exp_desc_r.type_idx)) { 00388 00389 00390 if (resolve_ext_opr(&r_opnd, FALSE, FALSE, FALSE, 00391 &ok, 00392 &exp_desc_l, &exp_desc_r)) { 00393 SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(r_opnd); 00394 SH_STMT_TYPE(curr_stmt_sh_idx) = Call_Stmt; 00395 } 00396 else { 00397 IR_RANK(ir_idx) = exp_desc_l.rank; 00398 00399 IR_TYPE_IDX(ir_idx) = exp_desc_l.type_idx; 00400 } 00401 } 00402 else if (resolve_ext_opr(&r_opnd, TRUE, FALSE, 00403 (result_type == Err_Res || 00404 (result_type == Structure_Type && 00405 !compare_derived_types(exp_desc_l.type_idx, 00406 exp_desc_r.type_idx) )), 00407 &ok, 00408 &exp_desc_l, &exp_desc_r)) { 00409 00410 SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(r_opnd); 00411 SH_STMT_TYPE(curr_stmt_sh_idx) = Call_Stmt; 00412 } 00413 else { 00414 ok = FALSE; 00415 } 00416 00417 if (ok && 00418 SH_STMT_TYPE(curr_stmt_sh_idx) != Call_Stmt && 00419 exp_desc_l.type == Integer && 00420 exp_desc_r.type == Real) { 00421 00422 COPY_OPND(r_opnd, IR_OPND_R(ir_idx)); 00423 look_for_real_div(&r_opnd); 00424 COPY_OPND(IR_OPND_R(ir_idx), r_opnd); 00425 } 00426 00427 # ifdef _TRANSFORM_CHAR_SEQUENCE 00428 if (ok && 00429 SH_STMT_TYPE(curr_stmt_sh_idx) != Call_Stmt && 00430 exp_desc_l.type == Structure && 00431 ATT_CHAR_SEQ(TYP_IDX(exp_desc_l.type_idx))) { 00432 00433 /* change character sequence assignment to character assignment */ 00434 00435 COPY_OPND(l_opnd, IR_OPND_L(ir_idx)); 00436 transform_char_sequence_ref(&l_opnd, exp_desc_l.type_idx); 00437 COPY_OPND(IR_OPND_L(ir_idx), l_opnd); 00438 00439 COPY_OPND(r_opnd, IR_OPND_R(ir_idx)); 00440 transform_char_sequence_ref(&r_opnd, exp_desc_r.type_idx); 00441 COPY_OPND(IR_OPND_R(ir_idx), r_opnd); 00442 } 00443 # endif 00444 00445 CK_WHERE: 00446 00447 if (ok && 00448 where_ir_idx > 0) { 00449 00450 /* we are in a where block */ 00451 00452 if (SH_STMT_TYPE(curr_stmt_sh_idx) == Call_Stmt && 00453 ! ATP_ELEMENTAL(IR_IDX_L(ir_idx))) { 00454 PRINTMSG(line, 1638, Error, col); 00455 ok = FALSE; 00456 } 00457 else if (! check_where_conformance(&exp_desc_l)) { 00458 00459 find_opnd_line_and_column((opnd_type *) &IR_OPND_L(ir_idx), 00460 &opnd_line, 00461 &opnd_col); 00462 PRINTMSG(opnd_line, 195, Error, opnd_col); 00463 ok = FALSE; 00464 } 00465 00466 if (ok) { 00467 /* set up list */ 00468 change_asg_to_where(ir_idx); 00469 } 00470 } 00471 00472 00473 if (active_forall_sh_idx) { 00474 defer_stmt_expansion = FALSE; 00475 00476 if (IR_OPR(ir_idx) != Call_Opr) { 00477 /* still an assignment */ 00478 00479 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 00480 line = IR_LINE_NUM(ir_idx); 00481 col = IR_COL_NUM(ir_idx); 00482 00483 forall_dependence = FALSE; 00484 check_dependence(&forall_dependence, 00485 IR_OPND_L(ir_idx), 00486 IR_OPND_R(ir_idx)); 00487 00488 if (forall_dependence) { 00489 00490 /* take the type for the tmp from the lhs, */ 00491 /* take the shape from the rhs */ 00492 00493 forall_exp_desc = exp_desc_r; 00494 forall_exp_desc.type_idx = exp_desc_l.type_idx; 00495 forall_exp_desc.type = exp_desc_l.type; 00496 forall_exp_desc.linear_type = exp_desc_l.linear_type; 00497 00498 if (exp_desc_l.type == Character) { 00499 /* use the base attr's char type idx */ 00500 00501 COPY_OPND(l_opnd, IR_OPND_L(ir_idx)); 00502 attr_idx = find_base_attr(&l_opnd, &opnd_line, &opnd_col); 00503 forall_exp_desc.type_idx = ATD_TYPE_IDX(attr_idx); 00504 forall_exp_desc.type = Character; 00505 forall_exp_desc.linear_type = 00506 TYP_LINEAR(forall_exp_desc.type_idx); 00507 forall_exp_desc.char_len.fld = 00508 TYP_FLD(ATD_TYPE_IDX(attr_idx)); 00509 forall_exp_desc.char_len.idx = 00510 TYP_IDX(ATD_TYPE_IDX(attr_idx)); 00511 } 00512 00513 gen_forall_tmp(&forall_exp_desc, 00514 &forall_tmp_opnd, 00515 line, 00516 col, 00517 FALSE); 00518 00519 asg_idx = gen_ir(OPND_FLD(forall_tmp_opnd), 00520 OPND_IDX(forall_tmp_opnd), 00521 Asg_Opr, forall_exp_desc.type_idx, line, col, 00522 IR_FLD_R(ir_idx), IR_IDX_R(ir_idx)); 00523 00524 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 00525 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00526 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 00527 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 00528 00529 gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx); 00530 00531 gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx); 00532 00533 COPY_OPND(opnd, IR_OPND_R(asg_idx)); 00534 process_deferred_functions(&opnd); 00535 COPY_OPND(IR_OPND_R(asg_idx), opnd); 00536 00537 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00538 00539 copy_subtree(&forall_tmp_opnd, &forall_tmp_opnd); 00540 COPY_OPND(IR_OPND_R(ir_idx), forall_tmp_opnd); 00541 00542 gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx); 00543 00544 gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx); 00545 00546 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 00547 process_deferred_functions(&opnd); 00548 COPY_OPND(IR_OPND_L(ir_idx), opnd); 00549 } 00550 else { 00551 gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx); 00552 00553 gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx); 00554 00555 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 00556 process_deferred_functions(&opnd); 00557 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00558 00559 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 00560 process_deferred_functions(&opnd); 00561 COPY_OPND(IR_OPND_L(ir_idx), opnd); 00562 } 00563 } 00564 else { 00565 gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx); 00566 00567 gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx); 00568 00569 gen_opnd(&opnd, 00570 SH_IR_IDX(curr_stmt_sh_idx), 00571 IR_Tbl_Idx, 00572 line, 00573 col); 00574 process_deferred_functions(&opnd); 00575 SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(opnd); 00576 } 00577 } 00578 00579 /* 00580 Generate this label immediately prior to the assignment 00581 statement. PDGCS will extract the information from 00582 this label and put it on the TOP OF LOOP label they 00583 create when they create the DO loop for this assignent statement. 00584 */ 00585 if (IR_RANK(ir_idx) > 0) { 00586 label_idx = gen_internal_lbl(line); 00587 NTR_IR_TBL(idx); 00588 IR_OPR(idx) = Label_Opr; 00589 IR_TYPE_IDX(idx) = TYPELESS_DEFAULT_TYPE; 00590 IR_LINE_NUM(idx) = line; 00591 IR_COL_NUM(idx) = col; 00592 IR_FLD_L(idx) = AT_Tbl_Idx; 00593 IR_IDX_L(idx) = label_idx; 00594 IR_COL_NUM_L(idx) = col; 00595 IR_LINE_NUM_L(idx) = line; 00596 AT_DEFINED(label_idx) = TRUE; 00597 AT_REFERENCED(label_idx) = Not_Referenced; 00598 ATL_TOP_OF_LOOP(label_idx) = TRUE; 00599 ATL_INFORM_ONLY(label_idx) = TRUE; 00600 00601 gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 00602 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00603 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = idx; 00604 ATL_DEF_STMT_IDX(label_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 00605 set_directives_on_label(label_idx); 00606 } 00607 } 00608 else if (IR_OPR(ir_idx) == Ptr_Asg_Opr) { 00609 00610 if (IR_FLD_R(ir_idx) == IR_Tbl_Idx && 00611 IR_OPR(IR_IDX_R(ir_idx)) == Call_Opr && 00612 IR_LIST_CNT_R(IR_IDX_R(ir_idx)) == 0 && 00613 AT_IS_INTRIN(IR_IDX_L(IR_IDX_R(ir_idx))) && 00614 (strcmp(AT_OBJ_NAME_PTR(IR_IDX_L(IR_IDX_R(ir_idx))), "NULL") == 0)) { 00615 00616 NTR_IR_LIST_TBL(list_idx); 00617 attr_idx = find_base_attr(&(IR_OPND_L(ir_idx)), &line, &col); 00618 IL_FLD(list_idx) = AT_Tbl_Idx; 00619 IL_IDX(list_idx) = attr_idx; 00620 IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx); 00621 IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx); 00622 00623 IR_IDX_R(IR_IDX_R(ir_idx)) = list_idx; 00624 IR_FLD_R(IR_IDX_R(ir_idx)) = IL_Tbl_Idx; 00625 IR_LIST_CNT_R(IR_IDX_R(ir_idx)) = 1; 00626 } 00627 00628 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 00629 00630 xref_state = CIF_Symbol_Modification; 00631 COPY_OPND(l_opnd, IR_OPND_L(ir_idx)); 00632 exp_desc_l.rank = 0; 00633 ok = expr_semantics(&l_opnd, &exp_desc_l); 00634 COPY_OPND(IR_OPND_L(ir_idx), l_opnd); 00635 00636 if (! ok) { 00637 goto EXIT; 00638 } 00639 00640 if (! exp_desc_l.pointer) { 00641 attr_idx = find_base_attr(&l_opnd, &line, &col); 00642 PRINTMSG(line, 417, Error, col); 00643 ok = FALSE; 00644 } 00645 00646 ok &= check_for_legal_define(&l_opnd); 00647 00648 attr_idx = find_base_attr(&l_opnd, &line, &col); 00649 00650 if (attr_idx && 00651 AT_OBJ_CLASS(attr_idx) == Data_Obj) { 00652 ATD_PTR_ASSIGNED(attr_idx) = TRUE; 00653 } 00654 00655 # ifdef COARRAY_FORTRAN 00656 /* prevent ptr asg to pointer component of co-array */ 00657 00658 if (ok && 00659 dump_flags.f_minus_minus && 00660 AT_OBJ_CLASS(attr_idx) == Data_Obj && 00661 ATD_CLASS(attr_idx) == Struct_Component) { 00662 00663 attr_idx = find_left_attr(&l_opnd); 00664 00665 if (ATD_PE_ARRAY_IDX(attr_idx)) { 00666 00667 PRINTMSG(line, 1572, Error, col); 00668 } 00669 } 00670 # endif 00671 00672 /* The pointer assignment statement really should have its own CIF stmt */ 00673 /* but libcif did not want to add another value at this time. */ 00674 /* LRR 12 May 1994 */ 00675 00676 if (cif_flags & MISC_RECS) { 00677 cif_stmt_type_rec(TRUE, CIF_Assignment_Stmt, statement_number); 00678 } 00679 00680 xref_state = CIF_Symbol_Reference; 00681 COPY_OPND(r_opnd, IR_OPND_R(ir_idx)); 00682 exp_desc_r.rank = 0; 00683 ok = expr_semantics(&r_opnd, &exp_desc_r) 00684 && ok; 00685 COPY_OPND(IR_OPND_R(ir_idx), r_opnd); 00686 00687 if (! ok) { 00688 goto EXIT; 00689 } 00690 00691 if (OPND_FLD(r_opnd) == AT_Tbl_Idx) { 00692 00693 if (AT_OBJ_CLASS(OPND_IDX(r_opnd)) == Data_Obj && 00694 !ATD_POINTER(OPND_IDX(r_opnd)) && !ATD_TARGET(OPND_IDX(r_opnd))) { 00695 PRINTMSG(OPND_LINE_NUM(r_opnd), 418, Error, OPND_COL_NUM(r_opnd)); 00696 ok = FALSE; 00697 } 00698 00699 if (AT_OBJ_CLASS(OPND_IDX(r_opnd)) == Data_Obj && 00700 ATD_PURE(OPND_IDX(r_opnd))) { 00701 PRINTMSG(OPND_LINE_NUM(r_opnd), 1270, Error, OPND_COL_NUM(r_opnd), 00702 AT_OBJ_NAME_PTR(OPND_IDX(r_opnd)), 00703 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure":"elemental"); 00704 ok = FALSE; 00705 } 00706 } 00707 else if (OPND_FLD(r_opnd) == IR_Tbl_Idx) { 00708 00709 if (IR_OPR(OPND_IDX(r_opnd)) == Call_Opr) { 00710 00711 if (!ATD_POINTER(ATP_RSLT_IDX(IR_IDX_L(OPND_IDX(r_opnd))))) { 00712 PRINTMSG(IR_LINE_NUM_L(OPND_IDX(r_opnd)), 421, Error, 00713 IR_COL_NUM_L(OPND_IDX(r_opnd))); 00714 ok = FALSE; 00715 } 00716 } 00717 else if (exp_desc_r.reference || 00718 exp_desc_r.tmp_reference) { 00719 attr_idx = find_base_attr(&r_opnd, &line, &col); 00720 00721 if (! exp_desc_r.pointer && ! exp_desc_r.target) { 00722 PRINTMSG(line, 418, Error, col); 00723 ok = FALSE; 00724 } 00725 else { 00726 if (exp_desc_r.rank != 0) { 00727 00728 /* check for IL_VECTOR_SUBSCRIPT */ 00729 00730 if (exp_desc_r.vector_subscript) { 00731 00732 /* might want to find a more correct position */ 00733 00734 PRINTMSG(IR_LINE_NUM(OPND_IDX(r_opnd)), 420, Error, 00735 IR_COL_NUM(OPND_IDX(r_opnd))); 00736 ok = FALSE; 00737 } 00738 } 00739 00740 if (IR_OPR(OPND_IDX(r_opnd)) == Dv_Deref_Opr && 00741 IR_FLD_L(OPND_IDX(r_opnd)) == AT_Tbl_Idx && 00742 AT_OBJ_CLASS(IR_IDX_L(OPND_IDX(r_opnd))) == Data_Obj && 00743 ATD_PURE(IR_IDX_L(OPND_IDX(r_opnd)))) { 00744 ok = FALSE; 00745 PRINTMSG(IR_COL_NUM_L(OPND_IDX(r_opnd)), 1270, Error, 00746 IR_COL_NUM_L(OPND_IDX(r_opnd)), 00747 AT_OBJ_NAME_PTR(IR_IDX_L(OPND_IDX(r_opnd))), 00748 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? 00749 "pure" : "elemental"); 00750 } 00751 else { 00752 00753 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)){ 00754 find_opnd_line_and_column(&r_opnd, &opnd_line, &opnd_col); 00755 ok = FALSE; 00756 PRINTMSG(opnd_line, 1270, Error, opnd_col, 00757 AT_OBJ_NAME_PTR(attr_idx), 00758 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? 00759 "pure" : "elemental"); 00760 } 00761 } 00762 } 00763 } 00764 else { /* an expression other than a call .. error */ 00765 find_opnd_line_and_column(&r_opnd, &opnd_line, &opnd_col); 00766 PRINTMSG(opnd_line, 421, Error, opnd_col); 00767 ok = FALSE; 00768 } 00769 } 00770 else { /* error .. must be pointer .. assuming only constants here */ 00771 find_opnd_line_and_column(&r_opnd, &opnd_line, &opnd_col); 00772 PRINTMSG(opnd_line, 418, Error, opnd_col); 00773 ok = FALSE; 00774 } 00775 00776 if (ok) { 00777 00778 if (exp_desc_r.rank != exp_desc_l.rank) { 00779 /* rank error */ 00780 PRINTMSG(IR_LINE_NUM(ir_idx), 431, Error, IR_COL_NUM(ir_idx)); 00781 ok = FALSE; 00782 } 00783 00784 if (exp_desc_r.type != exp_desc_l.type || 00785 (exp_desc_r.type == Structure && 00786 !compare_derived_types(exp_desc_r.type_idx,exp_desc_l.type_idx))){ 00787 r_err_word[0] = '\0'; 00788 l_err_word[0] = '\0'; 00789 00790 strcat(r_err_word, get_basic_type_str(exp_desc_r.type_idx)); 00791 00792 strcat(l_err_word, get_basic_type_str(exp_desc_l.type_idx)); 00793 00794 PRINTMSG(IR_LINE_NUM(ir_idx), 432, Error, 00795 IR_COL_NUM(ir_idx), 00796 r_err_word, 00797 l_err_word); 00798 ok = FALSE; 00799 } 00800 00801 if (exp_desc_r.type == exp_desc_l.type && 00802 exp_desc_r.type != Character && 00803 exp_desc_r.type != Structure && 00804 exp_desc_r.linear_type != exp_desc_l.linear_type) { 00805 00806 PRINTMSG(IR_LINE_NUM(ir_idx), 419, Error, IR_COL_NUM(ir_idx)); 00807 ok = FALSE; 00808 } 00809 else if (exp_desc_r.type == exp_desc_l.type && 00810 exp_desc_r.type == Character && 00811 exp_desc_r.char_len.fld == CN_Tbl_Idx && 00812 exp_desc_l.char_len.fld == CN_Tbl_Idx && 00813 fold_relationals(exp_desc_r.char_len.idx, 00814 exp_desc_l.char_len.idx, 00815 Ne_Opr)) { 00816 00817 PRINTMSG(IR_LINE_NUM(ir_idx), 853, Error, IR_COL_NUM(ir_idx)); 00818 ok = FALSE; 00819 } 00820 } 00821 00822 if (ok) { 00823 00824 if (active_forall_sh_idx) { 00825 defer_stmt_expansion = FALSE; 00826 00827 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 00828 line = IR_LINE_NUM(ir_idx); 00829 col = IR_COL_NUM(ir_idx); 00830 00831 forall_exp_desc = exp_desc_l; 00832 gen_forall_tmp(&forall_exp_desc, &forall_tmp_opnd, 00833 line, col, TRUE); 00834 00835 copy_subtree(&forall_tmp_opnd, &forall_tmp_opnd_l); 00836 asg_idx = gen_ir(OPND_FLD(forall_tmp_opnd_l), 00837 OPND_IDX(forall_tmp_opnd_l), 00838 Ptr_Asg_Opr, exp_desc_r.type_idx, line, col, 00839 IR_FLD_R(ir_idx), IR_IDX_R(ir_idx)); 00840 00841 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 00842 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00843 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 00844 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 00845 00846 gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx); 00847 00848 gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx); 00849 00850 if (OPND_FLD(forall_tmp_opnd_l) == IR_Tbl_Idx) { 00851 if (IR_OPR(OPND_IDX(forall_tmp_opnd_l)) == Whole_Substring_Opr) { 00852 COPY_OPND(forall_tmp_opnd_l, 00853 IR_OPND_L(OPND_IDX(forall_tmp_opnd_l))); 00854 } 00855 00856 if (IR_OPR(OPND_IDX(forall_tmp_opnd_l)) == Whole_Subscript_Opr) { 00857 COPY_OPND(forall_tmp_opnd_l, 00858 IR_OPND_L(OPND_IDX(forall_tmp_opnd_l))); 00859 } 00860 00861 if (IR_OPR(OPND_IDX(forall_tmp_opnd_l)) == Dv_Deref_Opr) { 00862 COPY_OPND(forall_tmp_opnd_l, 00863 IR_OPND_L(OPND_IDX(forall_tmp_opnd_l))); 00864 } 00865 } 00866 00867 copy_subtree(&forall_tmp_opnd_l, &forall_tmp_opnd_l); 00868 00869 attr_idx = find_base_attr(&forall_tmp_opnd_l,&opnd_line,&opnd_col); 00870 00871 gen_dv_whole_def_init(&forall_tmp_opnd_l, 00872 attr_idx, 00873 Before); 00874 00875 COPY_OPND(opnd, IR_OPND_R(asg_idx)); 00876 process_deferred_functions(&opnd); 00877 COPY_OPND(IR_OPND_R(asg_idx), opnd); 00878 00879 00880 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00881 00882 COPY_OPND(IR_OPND_R(ir_idx), forall_tmp_opnd); 00883 00884 gen_forall_loops(curr_stmt_sh_idx, curr_stmt_sh_idx); 00885 00886 gen_forall_if_mask(curr_stmt_sh_idx, curr_stmt_sh_idx); 00887 00888 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 00889 process_deferred_functions(&opnd); 00890 COPY_OPND(IR_OPND_L(ir_idx), opnd); 00891 00892 } 00893 else { 00894 } 00895 } 00896 } 00897 00898 EXIT: 00899 00900 defer_stmt_expansion = FALSE; 00901 00902 TRACE (Func_Exit, "assignment_stmt_semantics", NULL); 00903 00904 return; 00905 00906 } /* assignment_stmt_semantics */ 00907 00908 /******************************************************************************\ 00909 |* *| 00910 |* Description: *| 00911 |* <description> *| 00912 |* *| 00913 |* Input parameters: *| 00914 |* NONE *| 00915 |* *| 00916 |* Output parameters: *| 00917 |* NONE *| 00918 |* *| 00919 |* Returns: *| 00920 |* NOTHING *| 00921 |* *| 00922 \******************************************************************************/ 00923 00924 static void lower_ptr_asg(expr_arg_type *exp_desc_r) 00925 00926 { 00927 int ir_idx; 00928 opnd_type l_opnd; 00929 opnd_type r_opnd; 00930 int sh_idx; 00931 00932 TRACE (Func_Entry, "lower_ptr_asg", NULL); 00933 00934 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 00935 00936 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) { 00937 if (IR_OPR(IR_IDX_L(ir_idx)) == Whole_Substring_Opr) { 00938 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx))); 00939 } 00940 00941 if (IR_OPR(IR_IDX_L(ir_idx)) == Whole_Subscript_Opr) { 00942 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx))); 00943 } 00944 00945 if (IR_OPR(IR_IDX_L(ir_idx)) == Dv_Deref_Opr) { 00946 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx))); 00947 } 00948 } 00949 else { 00950 # ifdef _DEBUG 00951 print_ir(ir_idx); 00952 # endif 00953 PRINTMSG(IR_LINE_NUM(ir_idx), 973, Internal, 00954 IR_COL_NUM(ir_idx)); 00955 } 00956 00957 /* do the stmt thing here */ 00958 00959 COPY_OPND(l_opnd, IR_OPND_L(ir_idx)); 00960 COPY_OPND(r_opnd, IR_OPND_R(ir_idx)); 00961 00962 if (exp_desc_r->pointer || exp_desc_r->allocatable) { 00963 sh_idx = curr_stmt_sh_idx; 00964 ptr_assign_from_ptr(&l_opnd, &r_opnd); 00965 00966 /* Remove the pointer assignment SH unless it is labeled. If */ 00967 /* it was labeled, just turn it into a compiler-generated */ 00968 /* CONTINUE so the SH index in the Label_Def SH remains */ 00969 /* correct. */ 00970 00971 if (SH_LABELED(sh_idx)) { 00972 00973 # ifdef _DEBUG 00974 if (IR_OPR(SH_IR_IDX(sh_idx)) != Ptr_Asg_Opr) { 00975 PRINTMSG(IR_LINE_NUM(ir_idx), 974, Internal, 00976 IR_COL_NUM(ir_idx)); 00977 } 00978 # endif 00979 00980 SH_STMT_TYPE(sh_idx) = Continue_Stmt; 00981 SH_IR_IDX(sh_idx) = NULL_IDX; 00982 SH_COMPILER_GEN(sh_idx) = TRUE; 00983 00984 00985 /* If the pointer assignment stmt is also a loop termination*/ 00986 /* stmt, copy the loop end info to the current assignment */ 00987 /* SH (for Dv_Set_P_Or_A). */ 00988 00989 if (SH_LOOP_END(sh_idx)) { 00990 SH_LOOP_END(curr_stmt_sh_idx) = TRUE; 00991 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = 00992 SH_PARENT_BLK_IDX(sh_idx); 00993 } 00994 } 00995 else { 00996 00997 # ifdef _DEBUG 00998 if (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) != Ptr_Asg_Opr) { 00999 PRINTMSG(IR_LINE_NUM(ir_idx), 974, Internal, 01000 IR_COL_NUM(ir_idx)); 01001 } 01002 # endif 01003 01004 remove_sh(curr_stmt_sh_idx); 01005 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 01006 } 01007 } 01008 else if (exp_desc_r->target) { 01009 dope_vector_setup(&r_opnd, exp_desc_r, &l_opnd, TRUE); 01010 } 01011 01012 TRACE (Func_Exit, "lower_ptr_asg", NULL); 01013 01014 return; 01015 01016 } /* lower_ptr_asg */ 01017 01018 /******************************************************************************\ 01019 |* *| 01020 |* Description: *| 01021 |* This routine is the wrapper for expr_sem. It will fold any aggregate *| 01022 |* expression that are returned by expr_sem(). *| 01023 |* *| 01024 |* Input parameters: *| 01025 |* NONE *| 01026 |* *| 01027 |* Output parameters: *| 01028 |* NONE *| 01029 |* *| 01030 |* Returns: *| 01031 |* NOTHING *| 01032 |* *| 01033 \******************************************************************************/ 01034 01035 boolean expr_semantics (opnd_type *result_opnd, 01036 expr_arg_type *exp_desc) 01037 #ifdef KEY /* Bug 934 */ 01038 { 01039 return expr_semantics_d(result_opnd, exp_desc, FALSE); 01040 } 01041 01042 /* 01043 * Like expr_semantics(), but capable of passing along the knowledge that 01044 * we're dealing with the RHS of an assignment of an entire derived type. 01045 */ 01046 static boolean expr_semantics_d (opnd_type *result_opnd, 01047 expr_arg_type *exp_desc, 01048 boolean derived_assign) 01049 #endif /* KEY Bug 934 */ 01050 01051 { 01052 boolean ok = TRUE; 01053 opnd_type opnd; 01054 boolean save_check_type_conversion; 01055 int save_target_array_idx; 01056 opnd_type save_init_target_opnd; 01057 int save_target_char_len_idx; 01058 int save_target_type_idx; 01059 01060 operator_type fm2; 01061 fld_type fm1; 01062 01063 TRACE (Func_Entry, "expr_semantics", NULL); 01064 01065 save_check_type_conversion = check_type_conversion; 01066 save_target_array_idx = target_array_idx; 01067 COPY_OPND(save_init_target_opnd, init_target_opnd); 01068 save_target_char_len_idx = target_char_len_idx; 01069 save_target_type_idx = target_type_idx; 01070 01071 check_type_conversion = FALSE; 01072 target_array_idx = NULL_IDX; 01073 init_target_opnd = null_opnd; 01074 01075 target_char_len_idx = NULL_IDX; 01076 target_type_idx = NULL_IDX; 01077 01078 #ifdef KEY /* Bug 934 */ 01079 ok = expr_sem_d(result_opnd, exp_desc, derived_assign); 01080 #else /* KEY Bug 934 */ 01081 ok = expr_sem(result_opnd, exp_desc); 01082 #endif /* KEY Bug 934 */ 01083 01084 check_type_conversion = save_check_type_conversion; 01085 target_array_idx = save_target_array_idx; 01086 COPY_OPND(init_target_opnd, save_init_target_opnd); 01087 target_char_len_idx = save_target_char_len_idx; 01088 target_type_idx = save_target_type_idx; 01089 01090 if (ok && 01091 exp_desc->foldable && 01092 ((OPND_FLD((*result_opnd)) != CN_Tbl_Idx && 01093 OPND_FLD((*result_opnd)) != AT_Tbl_Idx && 01094 (OPND_FLD((*result_opnd)) != IR_Tbl_Idx || 01095 (IR_OPR(OPND_IDX((*result_opnd))) != Whole_Subscript_Opr && 01096 (IR_OPR(OPND_IDX((*result_opnd))) != Whole_Substring_Opr || 01097 IR_FLD_L(OPND_IDX((*result_opnd))) != IR_Tbl_Idx || 01098 IR_OPR(IR_IDX_L(OPND_IDX((*result_opnd)))) != 01099 Whole_Subscript_Opr)))) || 01100 check_type_conversion == TRUE || 01101 OPND_FLD(init_target_opnd) != NO_Tbl_Idx || 01102 target_array_idx != NULL_IDX)) { 01103 01104 fm1 = OPND_FLD((*result_opnd)); /* for test only June */ 01105 fm2 = IR_OPR(OPND_IDX((*result_opnd))); 01106 01107 COPY_OPND(opnd, (*result_opnd)); 01108 01109 if (IR_OPR(OPND_IDX((*result_opnd)))==Constant_Array_Construct_Opr || 01110 IR_OPR(OPND_IDX((*result_opnd)))== Null_Opr || 01111 IR_OPR(OPND_IDX((*result_opnd)))== Constant_Struct_Construct_Opr || 01112 IR_OPR(OPND_IDX((*result_opnd)))== Subscript_Opr ) /* June*/ 01113 ok = fold_aggragate_expression(&opnd, exp_desc, FALSE) && ok; 01114 /* June else */ 01115 /* exp_desc->foldable=FALSE; */ 01116 01117 COPY_OPND((*result_opnd), opnd); 01118 } 01119 01120 01121 TRACE (Func_Exit, "expr_semantics", NULL); 01122 01123 return(ok); 01124 01125 } /* expr_semantics */ 01126 01127 /******************************************************************************\ 01128 |* *| 01129 |* Description: *| 01130 |* Expr_semantics is the main expression semantics checker. It works *| 01131 |* recursively to process the entire subtree it is called with. *| 01132 |* Expr_semantics should be called for all references and expressions *| 01133 |* that require attr_link and type resolution. *| 01134 |* It does other things too. *| 01135 |* 1. All attr indexes are resolved to the ultimate attr in an attr_link *| 01136 |* chain. Type, rank and other stuff is propagated up the call chain. *| 01137 |* 2. Semantic checks (type, rank etc) are done on all numeric operators *| 01138 |* and information is propagated up. *| 01139 |* 3. Folding is done for constant operands of some operators. *| 01140 |* 4. Function calls are pulled out of expressions and replaced with *| 01141 |* temps. *| 01142 |* 5. Ambiguous array refs or other blah() formations are possibly *| 01143 |* changed to function calls. *| 01144 |* 6. Subscript oprs are inserted over whole array references. *| 01145 |* 7. Substring Oprs are inserted over character variable refs that *| 01146 |* weren't substringed by the user. *| 01147 |* 8. Calls to resolve_ext_opr check for overloaded operators. *| 01148 |* 9. Calls to call_list_semantics check for generic interface calls *| 01149 |* and do actual argument semantic checks. (back through here) *| 01150 |* 10. Allocate and deallocate objects are semantically checked here. *| 01151 |* 11. Other minor things. *| 01152 |* *| 01153 |* Input parameters: *| 01154 |* result_opnd - operand to examine. *| 01155 |* exp_desc - exp_arg_type (declared in sytb.h) *| 01156 |* This is used to propagate information up the call chain *| 01157 |* and some information down the chain. *| 01158 |* *| 01159 |* exp_desc is declared as follows ... *| 01160 |* struct expr_semantics_args { *| 01161 |* *| 01162 |* basic type of subtree -> basic_type_type type : 8; *| 01163 |* linear type -> linear_type_type linear_type : 8; *| 01164 |* type index of subtree -> Uint type_idx : 16;*| 01165 |* *| 01166 |* unused -> Uint UNUSED1 : 5; *| 01167 |* rank of subtree -> Uint rank : 8; *| 01168 |* subtree is a constant -> boolean constant : 1; *| 01169 |* subtree is foldable now-> boolean foldable : 1; *| 01170 |* *| 01171 |* subtree involves a constant *| 01172 |* value implied do lcv but will *| 01173 |* fold when its replaced -> boolean will_fold_later : 1; *| 01174 |* has pointer attribute -> boolean pointer : 1; *| 01175 |* has target attribute -> boolean target : 1; *| 01176 |* vector subscript ref -> boolean vector_subscript: 1; *| 01177 |* is a data obj ref -> boolean reference : 1; *| 01178 |* ref is a constructor -> boolean constructor : 1; *| 01179 |* structure subobject -> boolean component : 1; *| 01180 |* array section ref -> boolean section : 1; *| 01181 |* tree is a label ref -> boolean label : 1; *| 01182 |* tree is array element -> boolean array_elt : 1; *| 01183 |* whole assumed shape -> boolean assumed_shape : 1; *| 01184 |* whole assumed size -> boolean assumed_size : 1; *| 01185 |* allocatable array ref -> boolean allocatable : 1; *| 01186 |* ref is dope vector -> boolean dope_vector : 1; *| 01187 |* reference to tmp -> boolean tmp_reference : 1; *| 01188 |* tree has constructor -> boolean has_constructor : 1; *| 01189 |* optional dummy ref -> boolean optional_darg : 1; *| 01190 |* expr contains a -> boolean has_symbolic : 1; *| 01191 |* sybolic constant *| 01192 |* *| 01193 |* unused -> Uint UNUSED2 : 32;*| 01194 |* *| 01195 |* unused -> Uint UNUSED3 : 8; *| 01196 |* cif id for ref -> Uint cif_id : 24;*| 01197 |* *| 01198 |* *| 01199 |* character length -> opnd_type char_len; *| 01200 |* shape of subtree -> opnd_type shape[7]; *| 01201 |* }; *| 01202 |* *| 01203 |* *| 01204 |* reference means that subtree describes a data object *| 01205 |* reference, and is not an expression. *| 01206 |* Most of these flags are for special use and any questions *| 01207 |* about specific behavior should be directed to the developer. *| 01208 |* *| 01209 |* =========> RANK MUST BE SET TO ZERO BEFORE CALLING THIS ROUTINE!!!!! *| 01210 |* *| 01211 |* The exp_desc->rank variable is used to propagate the rank *| 01212 |* of a part-ref to the rest of the reference tree and so is *| 01213 |* used to pass information down the call chain. This is to *| 01214 |* catch that wonderful constraint that a pointer subobject *| 01215 |* cannot have a part-ref to the left that has rank > 0. *| 01216 |* *| 01217 |* Always copy your operand to a local variable of type *| 01218 |* opnd_type before the call to expr_semantics and copy the *| 01219 |* returned opnd back to your original. This is because tables *| 01220 |* may be realloc'ed and moved. *| 01221 |* *| 01222 |* Use the information from the exp_desc structure if you want *| 01223 |* things like type, type_idx, rank ... when you don't care *| 01224 |* the tree actually looks like. Constant and reference are *| 01225 |* also handy to quickly see what type of subtree you have. *| 01226 |* *| 01227 |* Output parameters: *| 01228 |* result_opnd - output opnd_type *| 01229 |* exp_desc - the expression descriptor (see above) that describes *| 01230 |* the result tree. *| 01231 |* *| 01232 |* Returns: *| 01233 |* TRUE if no semantic errors. *| 01234 |* FALSE if errors were issued or if an attr with AT_DCL_ERR was found. *| 01235 |* *| 01236 \******************************************************************************/ 01237 01238 boolean expr_sem (opnd_type *result_opnd, 01239 expr_arg_type *exp_desc) 01240 #ifdef KEY /* Bug 934 */ 01241 { 01242 return expr_sem_d(result_opnd, exp_desc, FALSE); 01243 } 01244 01245 /* 01246 * Like expr_sem(), but capable of passing in the knowledge that we're dealing 01247 * with the RHS of an assignment of an entire derived type. 01248 */ 01249 static boolean expr_sem_d(opnd_type *result_opnd, 01250 expr_arg_type *exp_desc, 01251 boolean derived_assign) 01252 #endif /* KEY Bug 934 */ 01253 01254 { 01255 int al_list_idx; 01256 int attr_idx; 01257 int col; 01258 int dv_idx; 01259 expr_arg_type exp_desc_l; 01260 expr_arg_type exp_desc_r; 01261 boolean host_associated; 01262 int ir_idx = NULL_IDX; 01263 int line; 01264 int list_idx; 01265 int msg_num; 01266 opnd_type opnd; 01267 int rank_in; 01268 boolean junk; 01269 boolean save_in_call_list; 01270 boolean save_in_constructor; 01271 boolean save_no_sub_or_deref; 01272 boolean save_insert_subs_ok; 01273 boolean ok = TRUE; 01274 01275 01276 TRACE (Func_Entry, "expr_sem", NULL); 01277 01278 /* these are here to initialize so that cases that are incomplete */ 01279 /* do not return wierd stuff. */ 01280 01281 rank_in = exp_desc->rank; 01282 (*exp_desc) = init_exp_desc; 01283 #ifdef KEY /* Bug 934 */ 01284 exp_desc->derived_assign = derived_assign; 01285 #endif /* KEY Bug 934 */ 01286 exp_desc->linear_type = TYPELESS_DEFAULT_TYPE; 01287 exp_desc->type_idx = TYPELESS_DEFAULT_TYPE; 01288 01289 find_opnd_line_and_column(result_opnd, &line, &col); 01290 01291 switch (OPND_FLD((*result_opnd))) { 01292 01293 case NO_Tbl_Idx : 01294 break; 01295 01296 case CN_Tbl_Idx: 01297 01298 exp_desc->type_idx = CN_TYPE_IDX(OPND_IDX((*result_opnd))); 01299 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 01300 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 01301 01302 if (exp_desc->type == Character) { 01303 exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx); 01304 exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx); 01305 OPND_LINE_NUM(exp_desc->char_len) = line; 01306 OPND_COL_NUM(exp_desc->char_len) = col; 01307 } 01308 01309 if (exp_desc->type == Character && 01310 compare_cn_and_value(TYP_IDX(exp_desc->type_idx), 01311 MAX_CHARS_IN_TYPELESS, 01312 Le_Opr)) { 01313 exp_desc->linear_type = Short_Char_Const; 01314 } 01315 01316 exp_desc->rank = 0; 01317 exp_desc->constant = TRUE; 01318 exp_desc->foldable = TRUE; 01319 exp_desc->will_fold_later = TRUE; 01320 break; 01321 01322 case AT_Tbl_Idx : 01323 01324 attr_idx = OPND_IDX((*result_opnd)); 01325 AT_LOCKED_IN(attr_idx) = TRUE; 01326 host_associated = FALSE; 01327 01328 01329 01330 if (expr_mode == Restricted_Imp_Do_Expr) { 01331 01332 if (in_implied_do && 01333 AT_OBJ_CLASS(attr_idx) == Data_Obj) { 01334 01335 while (AT_ATTR_LINK(attr_idx) && 01336 ! AT_IGNORE_ATTR_LINK(attr_idx)) { 01337 attr_idx = AT_ATTR_LINK(attr_idx); 01338 AT_LOCKED_IN(attr_idx) = TRUE; 01339 host_associated = TRUE; 01340 } 01341 01342 if (AT_ATTR_LINK(attr_idx)) { 01343 attr_idx = AT_ATTR_LINK(attr_idx); 01344 AT_LOCKED_IN(attr_idx) = TRUE; 01345 } 01346 } 01347 else { 01348 01349 while (AT_ATTR_LINK(attr_idx) && 01350 ! AT_IGNORE_ATTR_LINK(attr_idx)) { 01351 01352 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 01353 ATD_IMP_DO_LCV(attr_idx)) { 01354 break; 01355 } 01356 01357 attr_idx = AT_ATTR_LINK(attr_idx); 01358 AT_LOCKED_IN(attr_idx) = TRUE; 01359 } 01360 } 01361 01362 if (AT_NOT_VISIBLE(attr_idx)) { 01363 PRINTMSG(line, 486, Error, 01364 col, 01365 AT_OBJ_NAME_PTR(attr_idx), 01366 AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx)))); 01367 ok = FALSE; 01368 break; 01369 } 01370 01371 if (! AT_DCL_ERR(attr_idx)) { 01372 01373 if (AT_OBJ_CLASS(attr_idx) != Data_Obj || 01374 (ATD_CLASS(attr_idx) != Constant && 01375 ATD_CLASS(attr_idx) != Struct_Component && 01376 ! ATD_IMP_DO_LCV(attr_idx))) { 01377 OPND_IDX((*result_opnd)) = attr_idx; 01378 PRINTMSG(line, 658, Error, col, AT_OBJ_NAME_PTR(attr_idx)); 01379 ok = FALSE; 01380 break; 01381 } 01382 } 01383 } 01384 else if (in_implied_do && 01385 AT_OBJ_CLASS(attr_idx) == Data_Obj) { 01386 01387 while (AT_ATTR_LINK(attr_idx) && 01388 ! AT_IGNORE_ATTR_LINK(attr_idx)) { 01389 attr_idx = AT_ATTR_LINK(attr_idx); 01390 AT_LOCKED_IN(attr_idx) = TRUE; 01391 host_associated = TRUE; 01392 } 01393 01394 if (AT_ATTR_LINK(attr_idx)) { 01395 attr_idx = AT_ATTR_LINK(attr_idx); 01396 AT_LOCKED_IN(attr_idx) = TRUE; 01397 } 01398 01399 01400 if (ATD_IMP_DO_LCV(attr_idx) && 01401 constructor_level > ATD_TMP_IDX(attr_idx)) { 01402 constructor_level = ATD_TMP_IDX(attr_idx); 01403 } 01404 } 01405 else { 01406 while (AT_ATTR_LINK(attr_idx) && 01407 ! AT_IGNORE_ATTR_LINK(attr_idx)) { 01408 01409 attr_idx = AT_ATTR_LINK(attr_idx); 01410 AT_LOCKED_IN(attr_idx) = TRUE; 01411 host_associated = TRUE; 01412 } 01413 01414 if (AT_ATTR_LINK(attr_idx) && 01415 AT_OBJ_CLASS(AT_ATTR_LINK(attr_idx)) == Data_Obj && 01416 ATD_FORALL_INDEX(AT_ATTR_LINK(attr_idx))) { 01417 01418 attr_idx = AT_ATTR_LINK(attr_idx); 01419 AT_LOCKED_IN(attr_idx) = TRUE; 01420 } 01421 } 01422 01423 if (AT_NOT_VISIBLE(attr_idx)) { 01424 PRINTMSG(line, 486, Error, 01425 col, 01426 AT_OBJ_NAME_PTR(attr_idx), 01427 AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx)))); 01428 ok = FALSE; 01429 break; 01430 } 01431 01432 if (expr_mode == Data_Stmt_Target_Expr && 01433 (AT_OBJ_CLASS(attr_idx) != Data_Obj || 01434 (ATD_CLASS(attr_idx) != Constant && 01435 ATD_CLASS(attr_idx) != Struct_Component))) { 01436 01437 PRINTMSG(line, 705, Error, col, AT_OBJ_NAME_PTR(attr_idx)); 01438 ok = FALSE; 01439 } 01440 01441 OPND_IDX((*result_opnd)) = attr_idx; 01442 01443 if (! in_component_ref && 01444 (cif_flags & XREF_RECS) != 0 && 01445 (AT_OBJ_CLASS(attr_idx) != Data_Obj || 01446 ATD_CLASS(attr_idx) != Dummy_Argument || 01447 ! ATD_PARENT_OBJECT(attr_idx) || 01448 ! ATD_SF_DARG(attr_idx)) && 01449 xref_state != CIF_No_Usage_Rec) { 01450 01451 if (in_call_list) { /* output CIF_Symbol_Is_Actual_Arg */ 01452 cif_usage_rec(attr_idx, AT_Tbl_Idx, line, col, 01453 CIF_Symbol_Is_Actual_Arg); 01454 } 01455 else { /* output according xref_state */ 01456 cif_usage_rec(attr_idx, AT_Tbl_Idx, line, col, xref_state); 01457 } 01458 } 01459 01460 exp_desc->cif_id = AT_CIF_SYMBOL_ID(attr_idx); 01461 01462 if (AT_DCL_ERR(attr_idx)) { /* just quit */ 01463 ok = FALSE; 01464 } 01465 01466 if (AT_OPTIONAL(attr_idx)) { 01467 exp_desc->optional_darg = TRUE; 01468 } 01469 01470 switch (AT_OBJ_CLASS(attr_idx)) { 01471 01472 case Data_Obj: 01473 01474 if (ATD_CLASS(attr_idx) == Dummy_Argument && 01475 ATD_COPY_ASSUMED_SHAPE(attr_idx) && 01476 ATD_SF_ARG_IDX(attr_idx) != NULL_IDX) { 01477 01478 attr_idx = ATD_SF_ARG_IDX(attr_idx); 01479 OPND_IDX((*result_opnd)) = attr_idx; 01480 } 01481 # if defined(GENERATE_WHIRL) 01482 # if 0 01483 else if (ATD_CLASS(attr_idx) == Dummy_Argument && 01484 ATD_ARRAY_IDX(attr_idx) && 01485 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx))==Assumed_Shape && 01486 ATD_SF_ARG_IDX(attr_idx) != NULL_IDX && FALSE ) { 01487 01488 attr_idx = ATD_SF_ARG_IDX(attr_idx); 01489 OPND_IDX((*result_opnd)) = attr_idx; 01490 } 01491 # endif 01492 # endif 01493 01494 01495 exp_desc->type_idx = ATD_TYPE_IDX(attr_idx); 01496 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 01497 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 01498 01499 if (ATD_PURE(attr_idx) && 01500 #ifdef KEY /* Bug 934 */ 01501 /* This constraint only applies when assigning an entire 01502 * derived type. Note that it's one of the areas where 01503 * "allocatable" and "pointer" behave differently. */ 01504 exp_desc->derived_assign && 01505 #endif /* KEY Bug 934 */ 01506 stmt_type == Assignment_Stmt && 01507 exp_desc->type == Structure && 01508 ATT_POINTER_CPNT(TYP_IDX(exp_desc->type_idx))) { 01509 ok = FALSE; 01510 PRINTMSG(line, 1270, Error, col, AT_OBJ_NAME_PTR(attr_idx), 01511 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? 01512 "pure":"elemental"); 01513 } 01514 01515 if (exp_desc->type == Character) { 01516 if (!TYP_RESOLVED(ATD_TYPE_IDX(attr_idx))) { 01517 char_bounds_resolution(attr_idx, &junk); 01518 exp_desc->type_idx = ATD_TYPE_IDX(attr_idx); 01519 } 01520 01521 # if defined(_EXTENDED_CRI_CHAR_POINTER) 01522 if (TYP_FLD(exp_desc->type_idx) == AT_Tbl_Idx && 01523 AT_OBJ_CLASS(TYP_IDX(exp_desc->type_idx)) == Data_Obj && 01524 TYP_TYPE(ATD_TYPE_IDX(TYP_IDX(exp_desc->type_idx))) == 01525 CRI_Ch_Ptr) { 01526 01527 NTR_IR_TBL(ir_idx); 01528 IR_OPR(ir_idx) = Clen_Opr; 01529 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 01530 IR_LINE_NUM(ir_idx) = line; 01531 IR_COL_NUM(ir_idx) = col; 01532 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 01533 IR_IDX_L(ir_idx) = attr_idx; 01534 IR_LINE_NUM_L(ir_idx) = line; 01535 IR_COL_NUM_L(ir_idx) = col; 01536 01537 exp_desc->char_len.fld = IR_Tbl_Idx; 01538 exp_desc->char_len.idx = ir_idx; 01539 } 01540 else { 01541 exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx); 01542 exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx); 01543 OPND_LINE_NUM(exp_desc->char_len) = line; 01544 OPND_COL_NUM(exp_desc->char_len) = col; 01545 } 01546 # else 01547 exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx); 01548 exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx); 01549 OPND_LINE_NUM(exp_desc->char_len) = line; 01550 OPND_COL_NUM(exp_desc->char_len) = col; 01551 # endif 01552 01553 if (TYP_FLD(exp_desc->type_idx) == AT_Tbl_Idx) { 01554 ADD_TMP_TO_SHARED_LIST(TYP_IDX(exp_desc->type_idx)); 01555 } 01556 01557 if (ATD_CLASS(attr_idx) == Constant && 01558 compare_cn_and_value(TYP_IDX(exp_desc->type_idx), 01559 MAX_CHARS_IN_TYPELESS, 01560 Le_Opr)) { 01561 exp_desc->linear_type = Short_Char_Const; 01562 } 01563 } 01564 01565 exp_desc->pointer = ATD_POINTER(attr_idx); 01566 exp_desc->target = ATD_TARGET(attr_idx); 01567 exp_desc->allocatable = ATD_ALLOCATABLE(attr_idx); 01568 /* exp_desc->dope_vector = ATD_IM_A_DOPE(attr_idx); */ 01569 exp_desc->dope_vector = FALSE; 01570 01571 if (ATD_POINTER(attr_idx) && rank_in != 0) { 01572 ok = FALSE; 01573 PRINTMSG(line, 408, Error, col); 01574 } 01575 01576 if (cdir_switches.parallel_region && 01577 ATD_CLASS(attr_idx) != Struct_Component && 01578 ATD_CLASS(attr_idx) != Constant && 01579 ATD_CLASS(attr_idx) != Compiler_Tmp && 01580 ATD_CLASS(attr_idx) != CRI__Pointee && 01581 (ATD_CLASS(attr_idx) != Dummy_Argument || 01582 ! ATD_SF_DARG(attr_idx)) && 01583 ! cdir_switches.autoscope && 01584 ! ATD_TASK_PRIVATE(attr_idx) && 01585 ! ATD_TASK_GETFIRST(attr_idx) && 01586 ! ATD_TASK_LASTLOCAL(attr_idx) && 01587 ! ATD_TASK_REDUCTION(attr_idx) && 01588 ! ATD_TASK_LASTTHREAD(attr_idx) && 01589 ! ATD_TASK_FIRSTPRIVATE(attr_idx) && 01590 ! ATD_TASK_COPYIN(attr_idx) && 01591 ! ATD_TASK_LASTPRIVATE(attr_idx) && 01592 ! ATD_TASK_SHARED(attr_idx)) { 01593 01594 01595 if (dump_flags.open_mp && 01596 OPND_FLD(cdir_switches.first_sh_blk_stk) == IL_Tbl_Idx) { 01597 /* this means that we are in some sort of openmp region */ 01598 /* rather than a cmic region. */ 01599 01600 if (cdir_switches.default_scope_list_idx != NULL_IDX && 01601 CN_INT_TO_C(IL_IDX(cdir_switches.default_scope_list_idx)) 01602 == OPEN_MP_DEFAULT_NONE) { 01603 01604 PRINTMSG(line, 1510, Error, col, 01605 AT_OBJ_NAME_PTR(attr_idx)); 01606 ok = FALSE; 01607 /* add it to the shared list to prevent */ 01608 /* further errors. */ 01609 ADD_VAR_TO_SHARED_LIST(attr_idx); 01610 } 01611 } 01612 else if (dump_flags.mp) { 01613 01614 # if 0 01615 if (processing_do_var) { 01616 /* do vars are scope private, by default */ 01617 01618 ADD_VAR_TO_PRIVATE_LIST(attr_idx); 01619 } 01620 else { 01621 ADD_VAR_TO_SHARED_LIST(attr_idx); 01622 } 01623 # endif 01624 } 01625 else { 01626 01627 if (processing_do_var) { 01628 PRINTMSG(line, 1509, Error, col, 01629 AT_OBJ_NAME_PTR(attr_idx)); 01630 /* add it to the private list to prevent */ 01631 /* further errors. */ 01632 ADD_VAR_TO_PRIVATE_LIST(attr_idx); 01633 } 01634 else { 01635 PRINTMSG(line, 960, Error, col, 01636 AT_OBJ_NAME_PTR(attr_idx)); 01637 /* add it to the shared list to prevent */ 01638 /* further errors. */ 01639 ADD_VAR_TO_SHARED_LIST(attr_idx); 01640 } 01641 ok = FALSE; 01642 } 01643 } 01644 01645 ADD_TMP_TO_SHARED_LIST(attr_idx); 01646 01647 if (ATD_ARRAY_IDX(attr_idx)) { 01648 01649 if (! BD_RESOLVED(ATD_ARRAY_IDX(attr_idx))) { 01650 array_bounds_resolution(attr_idx, &junk); 01651 } 01652 01653 exp_desc->assumed_shape = 01654 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape); 01655 exp_desc->assumed_size = 01656 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Size); 01657 01658 exp_desc->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx)); 01659 get_shape_from_attr(exp_desc, 01660 attr_idx, 01661 exp_desc->rank, 01662 line, 01663 col); 01664 01665 /* set contig_array to TRUE even if it is a POINTER */ 01666 /* The a_contig flag in the dope vector will be */ 01667 /* checked to see if copy in/out is needed. */ 01668 01669 exp_desc->contig_array = TRUE; 01670 } 01671 01672 if (ATD_DISTRIBUTION_IDX(attr_idx) != NULL_IDX && 01673 BD_DISTRIBUTE_RESHAPE(ATD_DISTRIBUTION_IDX(attr_idx))) { 01674 01675 exp_desc->dist_reshape_ref = TRUE; 01676 } 01677 01678 if (ATD_IM_A_DOPE(attr_idx) && 01679 ! no_sub_or_deref) { 01680 01681 /* DO NOT SET IR_RANK(dv_idx) */ 01682 /* IT MUST BE ZERO HERE. */ 01683 01684 NTR_IR_TBL(dv_idx); 01685 IR_OPR(dv_idx) = Dv_Deref_Opr; 01686 IR_LINE_NUM(dv_idx) = OPND_LINE_NUM((*result_opnd)); 01687 IR_COL_NUM(dv_idx) = OPND_COL_NUM((*result_opnd)); 01688 01689 IR_TYPE_IDX(dv_idx) = exp_desc->type_idx; 01690 IR_FLD_L(dv_idx) = OPND_FLD((*result_opnd)); 01691 IR_IDX_L(dv_idx) = OPND_IDX((*result_opnd)); 01692 IR_LINE_NUM_L(dv_idx) = OPND_LINE_NUM((*result_opnd)); 01693 IR_COL_NUM_L(dv_idx) = OPND_COL_NUM((*result_opnd)); 01694 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 01695 OPND_IDX((*result_opnd)) = dv_idx; 01696 } 01697 01698 if (ATD_CLASS(attr_idx) == Constant) { 01699 exp_desc->constant = TRUE; 01700 exp_desc->foldable = TRUE; 01701 exp_desc->will_fold_later = TRUE; 01702 01703 if (ATD_CONST_IDX(attr_idx) == NULL_IDX) { 01704 exp_desc->constant = FALSE; 01705 break; 01706 } 01707 01708 OPND_IDX((*result_opnd)) = ATD_CONST_IDX(attr_idx); 01709 OPND_LINE_NUM((*result_opnd)) = line; 01710 OPND_COL_NUM((*result_opnd)) = col; 01711 01712 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) { 01713 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 01714 01715 ADD_TMP_TO_SHARED_LIST(ATD_CONST_IDX(attr_idx)); 01716 01717 if (insert_subs_ok && 01718 ! no_sub_or_deref) { 01719 01720 # if defined(_TARGET_OS_MAX) 01721 if (ATD_ARRAY_IDX(attr_idx) || 01722 ATD_PE_ARRAY_IDX(attr_idx)) 01723 # else 01724 if (ATD_ARRAY_IDX(attr_idx)) 01725 # endif 01726 { 01727 01728 ok &= gen_whole_subscript(result_opnd, exp_desc); 01729 } 01730 else if (exp_desc->type == Character) { 01731 ok &= gen_whole_substring(result_opnd, 0); 01732 } 01733 } 01734 } 01735 else { 01736 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 01737 } 01738 } 01739 else if (ATD_CLASS(attr_idx) == Dummy_Argument && 01740 ATD_SF_DARG(attr_idx)) { 01741 01742 OPND_FLD((*result_opnd)) = (fld_type) ATD_FLD(attr_idx); 01743 OPND_IDX((*result_opnd)) = ATD_SF_ARG_IDX(attr_idx); 01744 OPND_LINE_NUM((*result_opnd)) = line; 01745 OPND_COL_NUM((*result_opnd)) = col; 01746 01747 (*exp_desc) = arg_info_list[ATD_SF_LINK(attr_idx)].ed; 01748 01749 if (OPND_FLD((*result_opnd)) == AT_Tbl_Idx && 01750 AT_OBJ_CLASS(OPND_IDX((*result_opnd))) == Data_Obj && 01751 ATD_IM_A_DOPE(OPND_IDX((*result_opnd))) && 01752 ! no_sub_or_deref) { 01753 01754 /* DO NOT SET IR_RANK(dv_idx) */ 01755 /* IT MUST BE ZERO HERE. */ 01756 01757 NTR_IR_TBL(dv_idx); 01758 IR_OPR(dv_idx) = Dv_Deref_Opr; 01759 IR_LINE_NUM(dv_idx) = OPND_LINE_NUM((*result_opnd)); 01760 IR_COL_NUM(dv_idx) = OPND_COL_NUM((*result_opnd)); 01761 01762 IR_TYPE_IDX(dv_idx) = exp_desc->type_idx; 01763 COPY_OPND(IR_OPND_L(dv_idx), (*result_opnd)); 01764 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 01765 OPND_IDX((*result_opnd)) = dv_idx; 01766 } 01767 01768 if (OPND_FLD((*result_opnd)) == AT_Tbl_Idx || 01769 (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 01770 (IR_OPR(OPND_IDX((*result_opnd))) == Dv_Deref_Opr || 01771 IR_OPR(OPND_IDX((*result_opnd))) == Struct_Opr))) { 01772 01773 if (insert_subs_ok && 01774 ! no_sub_or_deref) { 01775 01776 if (exp_desc->rank) { 01777 ok &= gen_whole_subscript(result_opnd, exp_desc); 01778 } 01779 else if (exp_desc->type == Character) { 01780 ok &= gen_whole_substring(result_opnd, 0); 01781 } 01782 } 01783 } 01784 break; 01785 } 01786 else { /* must be variable */ 01787 01788 if (ATD_LCV_IS_CONST(attr_idx)) { 01789 exp_desc->will_fold_later = TRUE; 01790 } 01791 01792 exp_desc->reference = TRUE; 01793 exp_desc->has_symbolic = ATD_SYMBOLIC_CONSTANT(attr_idx); 01794 01795 if (insert_subs_ok && 01796 ! no_sub_or_deref) { 01797 01798 # if defined(_TARGET_OS_MAX) 01799 if (ATD_ARRAY_IDX(attr_idx) || 01800 ATD_PE_ARRAY_IDX(attr_idx)) 01801 # else 01802 if (ATD_ARRAY_IDX(attr_idx)) 01803 # endif 01804 { 01805 ok &= gen_whole_subscript(result_opnd, exp_desc); 01806 } 01807 else if (exp_desc->type == Character) { 01808 ok &= gen_whole_substring(result_opnd, 0); 01809 } 01810 } 01811 } 01812 01813 01814 if (expr_mode == Specification_Expr) { 01815 01816 /* Only call fnd_semantic_err if there is a problem, to */ 01817 /* keep things running fast. There are some problems that */ 01818 /* fnd_semantic_err won't get. Issue these msgs here. To */ 01819 /* be legal, the data object must be a dummy argument (but */ 01820 /* not INTENT(OUT) or OPTIONAL), in common, a constant, or */ 01821 /* host or use associated. */ 01822 01823 switch (ATD_CLASS(attr_idx)) { 01824 case Dummy_Argument: 01825 01826 if (AT_OPTIONAL(attr_idx) || 01827 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == CRI_Ptr) { 01828 fnd_semantic_err(Obj_Use_Spec_Expr, 01829 line, 01830 col, 01831 attr_idx, 01832 TRUE); 01833 ok = FALSE; 01834 } 01835 else if (ATD_INTENT(attr_idx) == Intent_Out) { 01836 PRINTMSG(line, 519, Error, col, 01837 AT_OBJ_NAME_PTR(attr_idx)); 01838 ok = FALSE; 01839 } 01840 else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 01841 PRINTMSG(line, 1439, Error, col, 01842 AT_OBJ_NAME_PTR(attr_idx)); 01843 ok = FALSE; 01844 } 01845 01846 if (AT_ALT_DARG(attr_idx)) { 01847 01848 /* This darg is not at all entry points. Add to a */ 01849 /* list for this specification expression. This */ 01850 /* only happens if there are alternate entry points */ 01851 /* and bounds expressions. */ 01852 01853 al_list_idx = SCP_TMP_LIST(curr_scp_idx); 01854 01855 while (al_list_idx != NULL_IDX && 01856 attr_idx != AL_ATTR_IDX(al_list_idx)) { 01857 al_list_idx = AL_NEXT_IDX(al_list_idx); 01858 } 01859 01860 if (al_list_idx == NULL_IDX) { /* Not on list - add it*/ 01861 NTR_ATTR_LIST_TBL(al_list_idx); 01862 AL_NEXT_IDX(al_list_idx) =SCP_TMP_LIST(curr_scp_idx); 01863 AL_ATTR_IDX(al_list_idx) = attr_idx; 01864 SCP_TMP_LIST(curr_scp_idx) = al_list_idx; 01865 } 01866 } 01867 01868 break; 01869 01870 case Variable: 01871 case Atd_Unknown: 01872 01873 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == CRI_Ptr) { 01874 fnd_semantic_err(Obj_Use_Spec_Expr, 01875 line, 01876 col, 01877 attr_idx, 01878 TRUE); 01879 ok = FALSE; 01880 } 01881 else if (!ATD_IN_COMMON(attr_idx) && 01882 !AT_USE_ASSOCIATED(attr_idx) && 01883 !host_associated && 01884 !ATD_SYMBOLIC_CONSTANT(attr_idx)) { 01885 01886 if (ATD_EQUIV(attr_idx)) { 01887 ATD_EQUIV_IN_BNDS_EXPR(attr_idx) = TRUE; 01888 } 01889 else { 01890 01891 if (!AT_DCL_ERR(attr_idx)) { 01892 PRINTMSG(line, 521, Error, col, 01893 AT_OBJ_NAME_PTR(attr_idx)); 01894 } 01895 ok = FALSE; 01896 } 01897 } 01898 break; 01899 01900 case Constant: 01901 case Struct_Component: 01902 break; 01903 01904 case Function_Result: 01905 case CRI__Pointee: 01906 fnd_semantic_err(Obj_Use_Spec_Expr, 01907 line, 01908 col, 01909 attr_idx, 01910 TRUE); 01911 ok = FALSE; 01912 break; 01913 } /* End switch */ 01914 } 01915 else if (expr_mode == Initialization_Expr) { 01916 01917 if (ATD_CLASS(attr_idx) != Struct_Component && 01918 ! ATD_LCV_IS_CONST(attr_idx) && 01919 ! ATD_PARENT_OBJECT(attr_idx) && 01920 ATD_CLASS(attr_idx) != Constant) { 01921 01922 if (!fnd_semantic_err(Obj_Use_Init_Expr, 01923 line, 01924 col, 01925 attr_idx, 01926 TRUE)) { 01927 PRINTMSG(line, 868, Error, col, /* Must be a constant */ 01928 AT_OBJ_NAME_PTR(attr_idx)); 01929 AT_DCL_ERR(attr_idx) = TRUE; 01930 } 01931 01932 ok = FALSE; 01933 } 01934 } 01935 break; 01936 01937 case Pgm_Unit: 01938 01939 if (ATP_PROC(attr_idx) == Dummy_Proc && 01940 ATP_DUMMY_PROC_LINK(attr_idx) != NULL_IDX) { 01941 01942 attr_idx = ATP_DUMMY_PROC_LINK(attr_idx); 01943 } 01944 01945 if (pgm_unit_illegal && !in_call_list) { 01946 ok = FALSE; 01947 01948 switch (ATP_PGM_UNIT(attr_idx)) { 01949 case Function : 01950 msg_num = 451; 01951 break; 01952 01953 case Subroutine : 01954 msg_num = 452; 01955 break; 01956 01957 case Program : 01958 msg_num = 453; 01959 break; 01960 01961 case Blockdata : 01962 msg_num = 454; 01963 break; 01964 01965 case Module : 01966 msg_num = 455; 01967 break; 01968 01969 case Pgm_Unknown : 01970 msg_num = 378; 01971 break; 01972 } 01973 PRINTMSG(line, msg_num, Error, col, 01974 AT_OBJ_NAME_PTR(attr_idx)); 01975 } 01976 else if (ATP_PGM_UNIT(attr_idx) == Function) { 01977 01978 exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 01979 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 01980 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 01981 01982 if (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))) { 01983 exp_desc->rank=BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))); 01984 01985 get_shape_from_attr(exp_desc, 01986 ATP_RSLT_IDX(attr_idx), 01987 exp_desc->rank, 01988 line, 01989 col); 01990 } 01991 else { 01992 exp_desc->rank = 0; 01993 } 01994 } 01995 break; 01996 01997 case Label: 01998 if (ATL_CLASS(attr_idx) == Lbl_Construct) { 01999 02000 /* always an error for a construct name here */ 02001 02002 PRINTMSG(line, 1461, Error, col, 02003 AT_OBJ_NAME_PTR(attr_idx)); 02004 ok = FALSE; 02005 } 02006 else if (label_allowed) { 02007 exp_desc->label = TRUE; 02008 } 02009 else { 02010 /* can't have label here */ 02011 PRINTMSG(line, 1462, Error, col, 02012 AT_OBJ_NAME_PTR(attr_idx)); 02013 ok = FALSE; 02014 } 02015 break; 02016 02017 case Namelist_Grp: 02018 if (expr_mode == Specification_Expr) { 02019 fnd_semantic_err(Obj_Use_Spec_Expr, 02020 line, 02021 col, 02022 attr_idx, 02023 TRUE); 02024 ok = FALSE; 02025 } 02026 else if (expr_mode == Initialization_Expr) { 02027 fnd_semantic_err(Obj_Use_Init_Expr, 02028 line, 02029 col, 02030 attr_idx, 02031 TRUE); 02032 ok = FALSE; 02033 } 02034 else if (namelist_illegal) { 02035 PRINTMSG(line, 512, Error, col, 02036 AT_OBJ_NAME_PTR(attr_idx)); 02037 02038 ok = FALSE; 02039 } 02040 break; 02041 02042 02043 case Derived_Type : 02044 02045 if (!AT_DEFINED(attr_idx)) { 02046 02047 /* Will not get duplicate messages, because if AT_DCL_ERR */ 02048 /* is TRUE, it will not get here. */ 02049 02050 issue_undefined_type_msg(attr_idx, line, col); 02051 ok = FALSE; 02052 } 02053 else if (expr_mode == Specification_Expr) { 02054 fnd_semantic_err(Obj_Use_Spec_Expr, 02055 line, 02056 col, 02057 attr_idx, 02058 TRUE); 02059 ok = FALSE; 02060 } 02061 else if (expr_mode == Initialization_Expr) { 02062 fnd_semantic_err(Obj_Use_Init_Expr, 02063 line, 02064 col, 02065 attr_idx, 02066 TRUE); 02067 ok = FALSE; 02068 } 02069 break; 02070 02071 02072 case Interface : 02073 02074 if (pgm_unit_illegal) { 02075 02076 if (in_call_list && 02077 ATI_PROC_IDX(attr_idx) != NULL_IDX) { 02078 02079 /* change to the specific with same name */ 02080 attr_idx = ATI_PROC_IDX(attr_idx); 02081 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 02082 OPND_IDX((*result_opnd)) = attr_idx; 02083 OPND_LINE_NUM((*result_opnd)) = line; 02084 OPND_COL_NUM((*result_opnd)) = col; 02085 02086 AT_REFERENCED(attr_idx) = (expr_mode == Specification_Expr || 02087 expr_mode == Stmt_Func_Expr) ? 02088 Dcl_Bound_Ref : Referenced; 02089 02090 if (ATP_PGM_UNIT(attr_idx) == Function) { 02091 02092 exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 02093 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 02094 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 02095 02096 AT_REFERENCED(ATP_RSLT_IDX(attr_idx)) = 02097 AT_REFERENCED(attr_idx); 02098 02099 if (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))) { 02100 exp_desc->rank = 02101 BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))); 02102 02103 get_shape_from_attr(exp_desc, 02104 ATP_RSLT_IDX(attr_idx), 02105 exp_desc->rank, 02106 line, 02107 col); 02108 } 02109 else { 02110 exp_desc->rank = 0; 02111 } 02112 } 02113 } 02114 else { 02115 /* invalid use of interface */ 02116 if (!AT_DCL_ERR(attr_idx)) { 02117 PRINTMSG(line, 1078, Error, col, 02118 AT_OBJ_NAME_PTR(attr_idx)); 02119 } 02120 ok = FALSE; 02121 } 02122 } 02123 else if (expr_mode == Specification_Expr) { 02124 fnd_semantic_err(Obj_Use_Spec_Expr, 02125 line, 02126 col, 02127 attr_idx, 02128 TRUE); 02129 ok = FALSE; 02130 } 02131 else if (expr_mode == Initialization_Expr) { 02132 fnd_semantic_err(Obj_Use_Init_Expr, 02133 line, 02134 col, 02135 attr_idx, 02136 TRUE); 02137 ok = FALSE; 02138 } 02139 break; 02140 02141 case Stmt_Func : 02142 02143 if (expr_mode == Specification_Expr) { 02144 fnd_semantic_err(Obj_Use_Spec_Expr, 02145 line, 02146 col, 02147 attr_idx, 02148 TRUE); 02149 ok = FALSE; 02150 } 02151 else if (expr_mode == Initialization_Expr) { 02152 fnd_semantic_err(Obj_Use_Init_Expr, 02153 line, 02154 col, 02155 attr_idx, 02156 TRUE); 02157 ok = FALSE; 02158 } 02159 02160 exp_desc->type_idx = ATD_TYPE_IDX(attr_idx); 02161 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 02162 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 02163 02164 break; 02165 02166 } 02167 break; 02168 02169 case IR_Tbl_Idx : 02170 02171 namelist_illegal = TRUE; 02172 label_allowed = FALSE; 02173 02174 ir_idx = OPND_IDX((*result_opnd)); 02175 02176 /* clear rank on the descriptors */ 02177 IR_ARRAY_SYNTAX(ir_idx) = FALSE; 02178 02179 switch (IR_OPR(ir_idx)) { 02180 02181 case Null_Opr : 02182 break; 02183 02184 case Defined_Un_Opr : 02185 02186 ok = defined_un_opr_handler(result_opnd, exp_desc); 02187 break; 02188 02189 case Uplus_Opr : 02190 case Uminus_Opr : 02191 02192 ok = uplus_opr_handler(result_opnd, exp_desc); 02193 break; 02194 02195 case Power_Opr : 02196 02197 ok = power_opr_handler(result_opnd, exp_desc); 02198 break; 02199 02200 case Mult_Opr : 02201 case Div_Opr : 02202 02203 ok = mult_opr_handler(result_opnd, exp_desc); 02204 break; 02205 02206 case Minus_Opr : 02207 02208 ok = minus_opr_handler(result_opnd, exp_desc); 02209 break; 02210 02211 case Plus_Opr : 02212 02213 ok = plus_opr_handler(result_opnd, exp_desc); 02214 break; 02215 02216 case Concat_Opr : 02217 02218 ok = concat_opr_handler(result_opnd, exp_desc); 02219 break; 02220 02221 case Eq_Opr : 02222 case Ne_Opr : 02223 02224 ok = eq_opr_handler(result_opnd, exp_desc); 02225 break; 02226 02227 case Lg_Opr : 02228 02229 ok = lg_opr_handler(result_opnd, exp_desc); 02230 break; 02231 02232 case Lt_Opr : 02233 case Le_Opr : 02234 case Gt_Opr : 02235 case Ge_Opr : 02236 02237 ok = lt_opr_handler(result_opnd, exp_desc); 02238 break; 02239 02240 case Not_Opr : 02241 02242 ok = not_opr_handler(result_opnd, exp_desc); 02243 break; 02244 02245 case And_Opr : 02246 case Or_Opr : 02247 case Eqv_Opr : 02248 case Neqv_Opr : 02249 02250 ok = and_opr_handler(result_opnd, exp_desc); 02251 break; 02252 02253 case Defined_Bin_Opr : 02254 02255 ok = defined_bin_opr_handler(result_opnd, exp_desc); 02256 break; 02257 02258 case Max_Opr : 02259 case Min_Opr : 02260 02261 ok = max_opr_handler(result_opnd, exp_desc); 02262 break; 02263 02264 case Call_Opr : 02265 02266 if (need_pure_function && 02267 AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Pgm_Unit && 02268 !ATP_PURE(IR_IDX_L(ir_idx))) { 02269 /* KAY - insert call to message here */ 02270 ok = FALSE; 02271 break; 02272 } 02273 02274 if (expr_mode == Restricted_Imp_Do_Expr) { 02275 PRINTMSG(line, 706, Error, col); 02276 ok = FALSE; 02277 break; 02278 } 02279 02280 save_in_constructor = in_constructor; 02281 in_constructor = FALSE; 02282 02283 ok = call_list_semantics(result_opnd, 02284 exp_desc, 02285 TRUE); 02286 02287 in_constructor = save_in_constructor; 02288 02289 if (expr_mode == Data_Stmt_Target_Expr && 02290 !exp_desc->constant) { 02291 02292 PRINTMSG(line, 706, Error, col); 02293 ok = FALSE; 02294 } 02295 02296 break; 02297 02298 case Struct_Opr : 02299 02300 ok = struct_opr_handler(result_opnd, exp_desc, rank_in); 02301 break; 02302 02303 case Struct_Construct_Opr : 02304 case Constant_Struct_Construct_Opr : 02305 02306 ok = struct_construct_opr_handler(result_opnd, exp_desc); 02307 break; 02308 02309 case Array_Construct_Opr : 02310 case Constant_Array_Construct_Opr : 02311 02312 ok = array_construct_opr_handler(result_opnd, exp_desc); 02313 break; 02314 02315 case Whole_Subscript_Opr : 02316 case Section_Subscript_Opr : 02317 case Subscript_Opr : 02318 02319 ok = subscript_opr_handler(result_opnd, exp_desc, rank_in); 02320 break; 02321 02322 case Whole_Substring_Opr : 02323 case Substring_Opr : 02324 02325 ok = substring_opr_handler(result_opnd, exp_desc, rank_in); 02326 break; 02327 02328 case Triplet_Opr : 02329 ok = triplet_opr_handler(result_opnd, exp_desc); 02330 break; 02331 02332 case Dealloc_Obj_Opr : 02333 02334 ok = dealloc_obj_opr_handler(result_opnd, exp_desc, rank_in); 02335 break; 02336 02337 case Alloc_Obj_Opr : 02338 02339 ok = alloc_obj_opr_handler(result_opnd, exp_desc, rank_in); 02340 02341 if (IR_FLD_R(ir_idx) != NO_Tbl_Idx){ 02342 IR_OPR(ir_idx) = Subscript_Opr; /*fzhao add Dec*/ 02343 ok = subscript_opr_handler(result_opnd, exp_desc, rank_in); 02344 } 02345 02346 break; 02347 02348 case Cvrt_Opr : 02349 case Cvrt_Unsigned_Opr : 02350 02351 ok = cvrt_opr_handler(result_opnd, exp_desc); 02352 break; 02353 02354 case Paren_Opr : 02355 02356 ok = paren_opr_handler(result_opnd, exp_desc); 02357 break; 02358 02359 case Kwd_Opr : 02360 02361 /* must be error in array spec */ 02362 #if 0 /* FMZ August 2005 */ 02363 PRINTMSG(IR_LINE_NUM(ir_idx), 197, Error, IR_COL_NUM(ir_idx), 02364 ", or )", "="); 02365 ok = FALSE; 02366 #else 02367 ok = TRUE; 02368 #endif 02369 break; 02370 02371 case Stmt_Func_Call_Opr : 02372 02373 ok = stmt_func_call_opr_handler(result_opnd, exp_desc); 02374 break; 02375 02376 case Clen_Opr: 02377 02378 save_insert_subs_ok = insert_subs_ok; 02379 insert_subs_ok = FALSE; 02380 02381 save_in_call_list = in_call_list; 02382 02383 if (IR_FLD_L(ir_idx) == AT_Tbl_Idx && 02384 AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Pgm_Unit) { 02385 in_call_list = TRUE; 02386 } 02387 02388 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 02389 ok = expr_sem(&opnd, exp_desc); 02390 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02391 insert_subs_ok = save_insert_subs_ok; 02392 in_call_list = save_in_call_list; 02393 02394 exp_desc->type = Integer; 02395 exp_desc->linear_type = INTEGER_DEFAULT_TYPE; 02396 exp_desc->type_idx = INTEGER_DEFAULT_TYPE; 02397 02398 fold_clen_opr(result_opnd, exp_desc); 02399 break; 02400 02401 case Percent_Val_Opr : 02402 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 02403 ok = expr_sem(&opnd, exp_desc); 02404 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02405 02406 if (OPND_FLD(opnd) == AT_Tbl_Idx && 02407 AT_OBJ_CLASS(OPND_IDX(opnd)) == Pgm_Unit) { 02408 /* just ignore the %val */ 02409 COPY_OPND((*result_opnd), opnd); 02410 } 02411 else if (exp_desc->rank == 0 && 02412 (exp_desc->type == Integer || 02413 exp_desc->type == Logical || 02414 exp_desc->type == Real)) { 02415 02416 COPY_OPND((*result_opnd), opnd); 02417 exp_desc->percent_val_arg = TRUE; 02418 } 02419 else { 02420 PRINTMSG(IR_LINE_NUM(ir_idx), 1125, Error, 02421 IR_COL_NUM(ir_idx)); 02422 ok = FALSE; 02423 } 02424 break; 02425 02426 /**********************************************************\ 02427 |* These oprs are only seen when we are traversing a tree *| 02428 |* for the second time in special circumstances. *| 02429 \**********************************************************/ 02430 02431 case Dv_Deref_Opr : 02432 02433 save_no_sub_or_deref = no_sub_or_deref; 02434 no_sub_or_deref = TRUE; 02435 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 02436 ok = expr_sem(&opnd, exp_desc); 02437 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02438 no_sub_or_deref = save_no_sub_or_deref; 02439 break; 02440 02441 case Dv_Access_Base_Addr: 02442 case Dv_Access_El_Len: 02443 case Dv_Access_Assoc: 02444 case Dv_Access_Ptr_Alloc: 02445 case Dv_Access_P_Or_A: 02446 case Dv_Access_A_Contig: 02447 case Dv_Access_N_Dim: 02448 case Dv_Access_Typ_Code: 02449 case Dv_Access_Orig_Base: 02450 case Dv_Access_Orig_Size: 02451 case Dv_Access_Low_Bound: 02452 case Dv_Access_Extent: 02453 case Dv_Access_Stride_Mult: 02454 save_no_sub_or_deref = no_sub_or_deref; 02455 no_sub_or_deref = TRUE; 02456 exp_desc_l.rank = 0; 02457 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 02458 ok = expr_sem(&opnd, &exp_desc_l); 02459 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02460 no_sub_or_deref = save_no_sub_or_deref; 02461 02462 exp_desc->type_idx = IR_TYPE_IDX(ir_idx); 02463 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 02464 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 02465 exp_desc->has_symbolic= exp_desc_l.has_symbolic; 02466 break; 02467 02468 default : 02469 save_no_sub_or_deref = no_sub_or_deref; 02470 no_sub_or_deref = TRUE; 02471 exp_desc_l.rank = 0; 02472 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 02473 ok = expr_sem(&opnd, &exp_desc_l); 02474 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02475 02476 no_sub_or_deref = TRUE; 02477 exp_desc_r.rank = 0; 02478 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 02479 ok = expr_sem(&opnd, &exp_desc_r); 02480 COPY_OPND(IR_OPND_R(ir_idx), opnd); 02481 no_sub_or_deref = save_no_sub_or_deref; 02482 02483 exp_desc->type_idx = IR_TYPE_IDX(ir_idx); 02484 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 02485 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 02486 exp_desc->rank = IR_RANK(ir_idx); 02487 break; 02488 } 02489 02490 break; 02491 02492 case IL_Tbl_Idx : 02493 list_idx = OPND_IDX((*result_opnd)); 02494 while (list_idx) { 02495 COPY_OPND(opnd, IL_OPND(list_idx)); 02496 ok = expr_sem(&opnd, &exp_desc_l); 02497 COPY_OPND(IL_OPND(list_idx), opnd); 02498 list_idx = IL_NEXT_LIST_IDX(list_idx); 02499 } 02500 02501 break; 02502 } 02503 02504 02505 TRACE (Func_Exit, "expr_sem", NULL); 02506 02507 return (ok); 02508 02509 } /* expr_sem */ 02510 02511 /******************************************************************************\ 02512 |* *| 02513 |* Description: *| 02514 |* inserts subscript and triplet texts for whole array refs. *| 02515 |* *| 02516 |* Input parameters: *| 02517 |* opnd .. copy of array obj opnd. *| 02518 |* *| 02519 |* Output parameters: *| 02520 |* exp_desc .. expression descriptor for opnd. The rank and shape are *| 02521 |* are filled in here. *| 02522 |* *| 02523 |* Returns: *| 02524 |* TRUE if no errors. *| 02525 |* *| 02526 \******************************************************************************/ 02527 02528 boolean gen_whole_subscript (opnd_type *opnd, expr_arg_type *exp_desc) 02529 02530 { 02531 int attr_idx; 02532 int bd_idx; 02533 int col; 02534 int dv_idx; 02535 opnd_type dv_opnd; 02536 int i; 02537 int line; 02538 int list1_idx = NULL_IDX; 02539 int list2_idx; 02540 expr_arg_type loc_exp_desc; 02541 int minus_idx; 02542 opnd_type opnd2; 02543 int plus_idx; 02544 02545 # if /* defined(_TARGET_OS_MAX) && May*/ defined(COARRAY_FORTRAN) 02546 int save_pe_dv_list_idx = NULL_IDX; 02547 # endif 02548 02549 int sub_idx; 02550 boolean ok = TRUE; 02551 int tlst1_idx; 02552 int tlst2_idx; 02553 int tlst3_idx; 02554 int trip_idx; 02555 enum fld_values ffmm; 02556 02557 02558 TRACE (Func_Entry, "gen_whole_subscript", NULL); 02559 02560 attr_idx = find_base_attr(opnd, &line, &col); 02561 02562 bd_idx = ATD_ARRAY_IDX(attr_idx); 02563 02564 if (bd_idx && 02565 BD_ARRAY_CLASS(bd_idx) == Assumed_Size) { 02566 02567 if (in_call_list) { 02568 /* it's ok, just don't try to gen the whole subscript */ 02569 02570 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 02571 ok = gen_whole_substring(opnd, BD_RANK(bd_idx)); 02572 } 02573 } 02574 else { 02575 /* error .. can't have assumed size here */ 02576 ok = FALSE; 02577 02578 if (SH_STMT_TYPE(curr_stmt_sh_idx) == Assignment_Stmt && 02579 IR_FLD_L(SH_IR_IDX(curr_stmt_sh_idx)) == AT_Tbl_Idx && 02580 IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx)) == attr_idx && 02581 IR_COL_NUM_L(SH_IR_IDX(curr_stmt_sh_idx)) == col && 02582 IR_LINE_NUM_L(SH_IR_IDX(curr_stmt_sh_idx)) == line) { 02583 02584 PRINTMSG(line, 411, Error, col); 02585 } 02586 else { 02587 PRINTMSG(line, 412, Error, col); 02588 } 02589 } 02590 02591 goto EXIT; 02592 } 02593 02594 NTR_IR_TBL(sub_idx); 02595 IR_OPR(sub_idx) = Whole_Subscript_Opr; 02596 02597 # if /* defined(_TARGET_OS_MAX) && May*/ defined(COARRAY_FORTRAN) 02598 if (exp_desc->pe_dim_ref && 02599 OPND_FLD((*opnd)) == IR_Tbl_Idx && 02600 IR_OPR(OPND_IDX((*opnd))) == Subscript_Opr && 02601 IR_LIST_CNT_R(OPND_IDX((*opnd))) == 1 && 02602 IL_PE_SUBSCRIPT(IR_IDX_R(OPND_IDX((*opnd))))) { 02603 02604 /* save the pe subscript */ 02605 save_pe_dv_list_idx = IR_IDX_R(OPND_IDX((*opnd))); 02606 02607 plus_idx = OPND_IDX((*opnd)); 02608 COPY_OPND((*opnd), IR_OPND_L(OPND_IDX((*opnd)))); 02609 FREE_IR_NODE(plus_idx); 02610 } 02611 # endif 02612 02613 if (OPND_FLD((*opnd)) == IR_Tbl_Idx && 02614 IR_OPR(OPND_IDX((*opnd))) == Dv_Deref_Opr) { 02615 02616 COPY_OPND(dv_opnd, IR_OPND_L(OPND_IDX((*opnd)))); 02617 } 02618 else { 02619 COPY_OPND(dv_opnd, (*opnd)); 02620 } 02621 02622 copy_subtree(&dv_opnd, &dv_opnd); 02623 02624 COPY_OPND(IR_OPND_L(sub_idx), (*opnd)); 02625 02626 /* hook Whole_Subscript text onto *opnd */ 02627 02628 OPND_FLD((*opnd)) = IR_Tbl_Idx; 02629 OPND_IDX((*opnd)) = sub_idx; 02630 02631 IR_RANK(sub_idx) = (bd_idx ? BD_RANK(bd_idx) : 0); 02632 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx); 02633 IR_LINE_NUM(sub_idx) = line; 02634 IR_COL_NUM(sub_idx) = col; 02635 02636 exp_desc->rank = IR_RANK(sub_idx); 02637 02638 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 02639 IR_LIST_CNT_R(sub_idx) = IR_RANK(sub_idx); 02640 02641 for (i = 1 ; i <= IR_LIST_CNT_R(sub_idx); i++) { 02642 02643 /* set up exp_desc->shape */ 02644 if (ATD_IM_A_DOPE(attr_idx)) { 02645 OPND_FLD(exp_desc->shape[i-1]) = IR_Tbl_Idx; 02646 NTR_IR_TBL(dv_idx); 02647 IR_OPR(dv_idx) = Dv_Access_Extent; 02648 IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE; 02649 IR_LINE_NUM(dv_idx) = line; 02650 IR_COL_NUM(dv_idx) = col; 02651 IR_DV_DIM(dv_idx) = i; 02652 COPY_OPND(IR_OPND_L(dv_idx), dv_opnd); 02653 OPND_IDX(exp_desc->shape[i-1]) = dv_idx; 02654 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE; 02655 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE; 02656 } 02657 else { 02658 OPND_FLD(exp_desc->shape[i-1]) = BD_XT_FLD(bd_idx, i); 02659 OPND_IDX(exp_desc->shape[i-1]) = BD_XT_IDX(bd_idx, i); 02660 02661 if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx) { 02662 ADD_TMP_TO_SHARED_LIST(OPND_IDX(exp_desc->shape[i-1])); 02663 } 02664 02665 if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx) { 02666 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = TRUE; 02667 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = TRUE; 02668 } 02669 else if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx && 02670 AT_OBJ_CLASS(OPND_IDX(exp_desc->shape[i-1])) == Data_Obj && 02671 ATD_LCV_IS_CONST(OPND_IDX(exp_desc->shape[i-1]))) { 02672 02673 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE; 02674 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = TRUE; 02675 } 02676 else { 02677 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE; 02678 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE; 02679 } 02680 } 02681 02682 if (list1_idx == NULL_IDX) { 02683 NTR_IR_LIST_TBL(list1_idx); 02684 IR_IDX_R(sub_idx) = list1_idx; 02685 } 02686 else { 02687 list2_idx = list1_idx; 02688 NTR_IR_LIST_TBL(list1_idx); 02689 IL_NEXT_LIST_IDX(list2_idx) = list1_idx; 02690 IL_PREV_LIST_IDX(list1_idx) = list2_idx; 02691 } 02692 02693 IL_FLD(list1_idx) = IR_Tbl_Idx; 02694 NTR_IR_TBL(trip_idx); 02695 IR_OPR(trip_idx) = Triplet_Opr; 02696 IR_TYPE_IDX(trip_idx) = CG_INTEGER_DEFAULT_TYPE; 02697 IR_RANK(trip_idx) = 1; 02698 IR_LINE_NUM(trip_idx) = line; 02699 IR_COL_NUM(trip_idx) = col; 02700 IL_IDX(list1_idx) = trip_idx; 02701 02702 NTR_IR_LIST_TBL(tlst1_idx); 02703 NTR_IR_LIST_TBL(tlst2_idx); 02704 NTR_IR_LIST_TBL(tlst3_idx); 02705 IR_FLD_L(trip_idx) = IL_Tbl_Idx; 02706 IR_LIST_CNT_L(trip_idx) = 3; 02707 IR_IDX_L(trip_idx) = tlst1_idx; 02708 02709 IL_NEXT_LIST_IDX(tlst1_idx) = tlst2_idx; 02710 IL_PREV_LIST_IDX(tlst2_idx) = tlst1_idx; 02711 IL_NEXT_LIST_IDX(tlst2_idx) = tlst3_idx; 02712 IL_PREV_LIST_IDX(tlst3_idx) = tlst2_idx; 02713 02714 if (ATD_IM_A_DOPE(attr_idx)) { 02715 02716 /* set up first triplet value */ 02717 02718 gen_dv_access_low_bound(&opnd2, &dv_opnd, i); 02719 02720 COPY_OPND(IL_OPND(tlst1_idx), opnd2); 02721 02722 /* set up upper bound value */ 02723 02724 NTR_IR_TBL(minus_idx); 02725 IR_OPR(minus_idx) = Minus_Opr; 02726 IR_TYPE_IDX(minus_idx) = SA_INTEGER_DEFAULT_TYPE; 02727 IR_LINE_NUM(minus_idx) = line; 02728 IR_COL_NUM(minus_idx) = col; 02729 IR_FLD_R(minus_idx) = CN_Tbl_Idx; 02730 IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX; 02731 IR_LINE_NUM_R(minus_idx) = line; 02732 IR_COL_NUM_R(minus_idx) = col; 02733 02734 NTR_IR_TBL(plus_idx); 02735 IR_OPR(plus_idx) = Plus_Opr; 02736 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE; 02737 IR_LINE_NUM(plus_idx) = line; 02738 IR_COL_NUM(plus_idx) = col; 02739 IR_FLD_L(minus_idx) = IR_Tbl_Idx; 02740 IR_IDX_L(minus_idx) = plus_idx; 02741 02742 gen_dv_access_low_bound(&opnd2, &dv_opnd, i); 02743 02744 COPY_OPND(IR_OPND_R(plus_idx), opnd2); 02745 02746 NTR_IR_TBL(dv_idx); 02747 IR_OPR(dv_idx) = Dv_Access_Extent; 02748 IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE; 02749 IR_LINE_NUM(dv_idx) = line; 02750 IR_COL_NUM(dv_idx) = col; 02751 IR_DV_DIM(dv_idx) = i; 02752 COPY_OPND(IR_OPND_L(dv_idx), dv_opnd); 02753 02754 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 02755 IR_IDX_L(plus_idx) = dv_idx; 02756 02757 IL_FLD(tlst2_idx) = IR_Tbl_Idx; 02758 IL_IDX(tlst2_idx) = minus_idx; 02759 02760 } 02761 else { 02762 IL_FLD(tlst1_idx) = BD_LB_FLD(bd_idx, i); 02763 IL_IDX(tlst1_idx) = BD_LB_IDX(bd_idx, i); 02764 IL_LINE_NUM(tlst1_idx) = line; 02765 IL_COL_NUM(tlst1_idx) = col; 02766 02767 if (IL_FLD(tlst1_idx) == AT_Tbl_Idx) { 02768 ADD_TMP_TO_SHARED_LIST(IL_IDX(tlst1_idx)); 02769 } 02770 02771 ffmm = IL_FLD(tlst1_idx); 02772 02773 if (IL_FLD(tlst1_idx) != CN_Tbl_Idx) { 02774 02775 /* assumes that this is an AT_Tbl_Idx */ 02776 loc_exp_desc.type_idx = ATD_TYPE_IDX(IL_IDX(tlst1_idx)); 02777 loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx); 02778 loc_exp_desc.linear_type = 02779 TYP_LINEAR(loc_exp_desc.type_idx); 02780 } 02781 else { 02782 loc_exp_desc.type_idx = CN_TYPE_IDX(IL_IDX(tlst1_idx)); 02783 loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx); 02784 loc_exp_desc.linear_type = 02785 TYP_LINEAR(loc_exp_desc.type_idx); 02786 } 02787 02788 if (in_io_list) { 02789 02790 /* on mpp, must cast shorts to longs in io lists */ 02791 /* on solaris, must cast Integer_8 to Integer_4 */ 02792 02793 COPY_OPND(opnd2, IL_OPND(tlst1_idx)); 02794 cast_to_cg_default(&opnd2, &loc_exp_desc); 02795 COPY_OPND(IL_OPND(tlst1_idx), opnd2); 02796 } 02797 02798 IL_FLD(tlst2_idx) = BD_UB_FLD(bd_idx, i); 02799 IL_IDX(tlst2_idx) = BD_UB_IDX(bd_idx, i); 02800 IL_LINE_NUM(tlst2_idx) = line; 02801 IL_COL_NUM(tlst2_idx) = col; 02802 02803 if (IL_FLD(tlst2_idx) == AT_Tbl_Idx) { 02804 ADD_TMP_TO_SHARED_LIST(IL_IDX(tlst2_idx)); 02805 } 02806 02807 if (IL_FLD(tlst2_idx) != CN_Tbl_Idx) { 02808 02809 /* assumes that this is an AT_Tbl_Idx */ 02810 loc_exp_desc.type_idx = ATD_TYPE_IDX(IL_IDX(tlst2_idx)); 02811 loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx); 02812 loc_exp_desc.linear_type = 02813 TYP_LINEAR(loc_exp_desc.type_idx); 02814 } 02815 else { 02816 loc_exp_desc.type_idx = CN_TYPE_IDX(IL_IDX(tlst2_idx)); 02817 loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx); 02818 loc_exp_desc.linear_type = 02819 TYP_LINEAR(loc_exp_desc.type_idx); 02820 } 02821 02822 if (in_io_list) { 02823 02824 /* on mpp, must cast shorts to longs in io lists */ 02825 /* on solaris, must cast Integer_8 to Integer_4 */ 02826 02827 COPY_OPND(opnd2, IL_OPND(tlst2_idx)); 02828 cast_to_cg_default(&opnd2, &loc_exp_desc); 02829 COPY_OPND(IL_OPND(tlst2_idx), opnd2); 02830 } 02831 } 02832 02833 IL_FLD(tlst3_idx) = CN_Tbl_Idx; 02834 IL_LINE_NUM(tlst3_idx) = line; 02835 IL_COL_NUM(tlst3_idx) = col; 02836 IL_IDX(tlst3_idx) = CN_INTEGER_ONE_IDX; 02837 } 02838 02839 # if defined(_TARGET_OS_MAX) 02840 02841 # ifdef COARRAY_FORTRAN 02842 if (save_pe_dv_list_idx != NULL_IDX) { 02843 02844 /* add the pe subscript to ir_idx */ 02845 list1_idx = IR_IDX_R(sub_idx); 02846 02847 while (IL_NEXT_LIST_IDX(list1_idx)) { 02848 list1_idx = IL_NEXT_LIST_IDX(list1_idx); 02849 } 02850 02851 IL_NEXT_LIST_IDX(list1_idx) = save_pe_dv_list_idx; 02852 IL_PREV_LIST_IDX(save_pe_dv_list_idx) = list1_idx; 02853 IR_LIST_CNT_R(sub_idx) += 1; 02854 } 02855 else if (ATD_PE_ARRAY_IDX(attr_idx) && 02856 ! ATD_ALLOCATABLE(attr_idx)) { 02857 /* supply mype() as pe dim */ 02858 02859 list1_idx = IR_IDX_R(sub_idx); 02860 02861 if (list1_idx) { 02862 while (IL_NEXT_LIST_IDX(list1_idx) != NULL_IDX) { 02863 list1_idx = IL_NEXT_LIST_IDX(list1_idx); 02864 } 02865 02866 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list1_idx)); 02867 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list1_idx)) = list1_idx; 02868 list1_idx = IL_NEXT_LIST_IDX(list1_idx); 02869 IR_LIST_CNT_R(sub_idx) += 1; 02870 } 02871 else { 02872 NTR_IR_LIST_TBL(list1_idx); 02873 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 02874 IR_LIST_CNT_R(sub_idx) = 1; 02875 IR_IDX_R(sub_idx) = list1_idx; 02876 02877 IR_OPR(sub_idx) = Subscript_Opr; 02878 } 02879 02880 NTR_IR_TBL(plus_idx); 02881 IR_OPR(plus_idx) = My_Pe_Opr; 02882 IR_TYPE_IDX(plus_idx) = INTEGER_DEFAULT_TYPE; 02883 IR_LINE_NUM(plus_idx) = IR_LINE_NUM(sub_idx); 02884 IR_COL_NUM(plus_idx) = IR_COL_NUM(sub_idx); 02885 02886 IL_FLD(list1_idx) = IR_Tbl_Idx; 02887 IL_IDX(list1_idx) = plus_idx; 02888 02889 IL_PE_SUBSCRIPT(list1_idx) = TRUE; 02890 io_item_must_flatten = TRUE; 02891 } 02892 # endif 02893 # endif 02894 02895 if (ok && 02896 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 02897 ok = gen_whole_substring(opnd, IR_RANK(sub_idx)); 02898 } 02899 02900 IR_ARRAY_SYNTAX(sub_idx) = FALSE; 02901 02902 EXIT: 02903 02904 TRACE (Func_Exit, "gen_whole_subscript", NULL); 02905 02906 return(ok); 02907 02908 } /* gen_whole_subscript */ 02909 02910 /******************************************************************************\ 02911 |* *| 02912 |* Description: *| 02913 |* inserts substring texts and bounds for whole character refs. *| 02914 |* *| 02915 |* Input parameters: *| 02916 |* opnd .. copy of array obj opnd. *| 02917 |* rank .. rank of opnd, it is placed on substring opr. *| 02918 |* *| 02919 |* Output parameters: *| 02920 |* NONE *| 02921 |* *| 02922 |* Returns: *| 02923 |* TRUE if no problem *| 02924 |* *| 02925 \******************************************************************************/ 02926 02927 boolean gen_whole_substring (opnd_type *opnd, 02928 int rank) 02929 02930 { 02931 int attr_idx; 02932 int clen_idx; 02933 int col; 02934 int ir_idx; 02935 int line; 02936 int list_idx; 02937 int list1_idx; 02938 int list2_idx; 02939 int shift_idx; 02940 int sub_idx; 02941 boolean ok = TRUE; 02942 02943 02944 TRACE (Func_Entry, "gen_whole_substring", NULL); 02945 02946 /* what do we do with assumed size character? */ 02947 02948 attr_idx = find_base_attr(opnd, &line, &col); 02949 02950 NTR_IR_TBL(sub_idx); 02951 02952 COPY_OPND(IR_OPND_L(sub_idx), (*opnd)); 02953 02954 IR_OPR(sub_idx) = Whole_Substring_Opr; 02955 IR_RANK(sub_idx) = rank; 02956 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx); 02957 IR_LINE_NUM(sub_idx) = line; 02958 IR_COL_NUM(sub_idx) = col; 02959 02960 OPND_FLD((*opnd)) = IR_Tbl_Idx; 02961 OPND_IDX((*opnd)) = sub_idx; 02962 02963 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 02964 IR_LIST_CNT_R(sub_idx) = 2; 02965 02966 NTR_IR_LIST_TBL(list1_idx); 02967 IR_IDX_R(sub_idx) = list1_idx; 02968 IL_FLD(list1_idx) = CN_Tbl_Idx; 02969 IL_IDX(list1_idx) = CN_INTEGER_ONE_IDX; 02970 IL_LINE_NUM(list1_idx) = line; 02971 IL_COL_NUM(list1_idx) = col; 02972 02973 NTR_IR_LIST_TBL(list2_idx); 02974 IL_NEXT_LIST_IDX(list1_idx) = list2_idx; 02975 IL_PREV_LIST_IDX(list2_idx) = list1_idx; 02976 02977 if (ATD_CLASS(attr_idx) == CRI__Pointee && 02978 TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Assumed_Size_Char){ 02979 02980 NTR_IR_TBL(clen_idx); 02981 IR_OPR(clen_idx) = Clen_Opr; 02982 IR_TYPE_IDX(clen_idx) = CG_INTEGER_DEFAULT_TYPE; 02983 IR_LINE_NUM(clen_idx) = line; 02984 IR_COL_NUM(clen_idx) = col; 02985 IR_FLD_L(clen_idx) = AT_Tbl_Idx; 02986 IR_IDX_L(clen_idx) = attr_idx; 02987 IR_LINE_NUM_L(clen_idx) = line; 02988 IR_COL_NUM_L(clen_idx) = col; 02989 IL_FLD(list2_idx) = IR_Tbl_Idx; 02990 IL_IDX(list2_idx) = clen_idx; 02991 } 02992 else if (ATD_CHAR_LEN_IN_DV(attr_idx)) { 02993 NTR_IR_TBL(ir_idx); 02994 IR_OPR(ir_idx) = Dv_Access_El_Len; 02995 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 02996 IR_LINE_NUM(ir_idx) = line; 02997 IR_COL_NUM(ir_idx) = col; 02998 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 02999 IR_IDX_L(ir_idx) = attr_idx; 03000 IR_LINE_NUM_L(ir_idx) = line; 03001 IR_COL_NUM_L(ir_idx) = col; 03002 03003 if (char_len_in_bytes) { 03004 /* Len in dope vector is in bytes for solaris */ 03005 IL_FLD(list2_idx) = IR_Tbl_Idx; 03006 IL_IDX(list2_idx) = ir_idx; 03007 } 03008 else { 03009 NTR_IR_TBL(shift_idx); 03010 IR_OPR(shift_idx) = Shiftr_Opr; 03011 IR_TYPE_IDX(shift_idx) = CG_INTEGER_DEFAULT_TYPE; 03012 IR_LINE_NUM(shift_idx) = line; 03013 IR_COL_NUM(shift_idx) = col; 03014 03015 NTR_IR_LIST_TBL(list_idx); 03016 03017 IR_FLD_L(shift_idx) = IL_Tbl_Idx; 03018 IR_IDX_L(shift_idx) = list_idx; 03019 IR_LIST_CNT_L(shift_idx) = 2; 03020 IL_FLD(list_idx) = IR_Tbl_Idx; 03021 IL_IDX(list_idx) = ir_idx; 03022 03023 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03024 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03025 list_idx = IL_NEXT_LIST_IDX(list_idx); 03026 03027 IL_FLD(list_idx) = CN_Tbl_Idx; 03028 IL_LINE_NUM(list_idx) = line; 03029 IL_COL_NUM(list_idx) = col; 03030 IL_IDX(list_idx) = CN_INTEGER_THREE_IDX; 03031 IL_FLD(list2_idx) = IR_Tbl_Idx; 03032 IL_IDX(list2_idx) = shift_idx; 03033 } 03034 } 03035 else { 03036 IL_IDX(list2_idx) = TYP_IDX(ATD_TYPE_IDX(attr_idx)); 03037 IL_FLD(list2_idx) = TYP_FLD(ATD_TYPE_IDX(attr_idx)); 03038 IL_LINE_NUM(list2_idx) = line; 03039 IL_COL_NUM(list2_idx) = col; 03040 03041 if (IL_FLD(list2_idx) == AT_Tbl_Idx) { 03042 ADD_TMP_TO_SHARED_LIST(IL_IDX(list2_idx)); 03043 } 03044 } 03045 03046 add_substring_length(sub_idx); 03047 03048 IR_ARRAY_SYNTAX(sub_idx) = FALSE; 03049 03050 TRACE (Func_Exit, "gen_whole_substring", NULL); 03051 03052 return(ok); 03053 03054 } /* gen_whole_substring */ 03055 03056 /******************************************************************************\ 03057 |* *| 03058 |* Description: *| 03059 |* This routine accesses the semantic tables for any operator *| 03060 |* to see if the operation (or assignment) is intrinsic. *| 03061 |* *| 03062 |* Input parameters: *| 03063 |* opr - operator_type *| 03064 |* type_idx_l - type of left operand *| 03065 |* rank_l - rank of left operand *| 03066 |* type_idx_r - type of right operand *| 03067 |* rank_r - rank of right operand *| 03068 |* *| 03069 |* Output parameters: *| 03070 |* NONE *| 03071 |* *| 03072 |* Returns: *| 03073 |* TRUE if operation is intrinsic. *| 03074 |* *| 03075 \******************************************************************************/ 03076 03077 boolean operation_is_intrinsic(operator_type opr, 03078 int type_idx_l, 03079 int rank_l, 03080 int type_idx_r, 03081 int rank_r) 03082 03083 { 03084 linear_type_type exp_idx_l; 03085 linear_type_type exp_idx_r; 03086 boolean intrinsic = TRUE; 03087 basic_type_type type_l; 03088 basic_type_type type_r; 03089 03090 03091 TRACE (Func_Entry, "operation_is_intrinsic", NULL); 03092 03093 if (opr == Null_Opr) { 03094 intrinsic = FALSE; 03095 goto EXIT; 03096 } 03097 03098 type_l = TYP_TYPE(type_idx_l); 03099 type_r = TYP_TYPE(type_idx_r); 03100 exp_idx_l = TYP_LINEAR(type_idx_l); 03101 exp_idx_r = TYP_LINEAR(type_idx_r); 03102 03103 if (type_r != Typeless) { 03104 03105 if (opr == Asg_Opr) { 03106 03107 if (rank_l != rank_r && 03108 rank_r != 0) { 03109 /* not intrinsic */ 03110 intrinsic = FALSE; 03111 goto EXIT; 03112 } 03113 } 03114 else { 03115 03116 if (rank_l != rank_r && 03117 rank_l * rank_r != 0) { 03118 /* not intrinsic */ 03119 intrinsic = FALSE; 03120 goto EXIT; 03121 } 03122 } 03123 } 03124 03125 switch (opr) { 03126 case Plus_Opr : 03127 03128 if (type_r == Typeless) { 03129 03130 if (UN_PLUS_TYPE(exp_idx_l) == Err_Res || 03131 UN_PLUS_EXTN(exp_idx_l)) { 03132 intrinsic = FALSE; 03133 } 03134 } 03135 else { 03136 if (BIN_ADD_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03137 BIN_ADD_EXTN(exp_idx_l, exp_idx_r)) { 03138 intrinsic = FALSE; 03139 } 03140 } 03141 break; 03142 03143 case Minus_Opr : 03144 03145 if (type_r == Typeless) { 03146 03147 if (UN_PLUS_TYPE(exp_idx_l) == Err_Res || 03148 UN_PLUS_EXTN(exp_idx_l)) { 03149 intrinsic = FALSE; 03150 } 03151 } 03152 else { 03153 if (BIN_SUB_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03154 BIN_SUB_EXTN(exp_idx_l, exp_idx_r)) { 03155 intrinsic = FALSE; 03156 } 03157 } 03158 break; 03159 03160 case Power_Opr : 03161 03162 if (POWER_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03163 POWER_EXTN(exp_idx_l, exp_idx_r)) { 03164 intrinsic = FALSE; 03165 } 03166 break; 03167 03168 case Div_Opr : 03169 case Mult_Opr : 03170 03171 if (MULT_DIV_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03172 MULT_DIV_EXTN(exp_idx_l, exp_idx_r)) { 03173 intrinsic = FALSE; 03174 } 03175 break; 03176 03177 case Concat_Opr : 03178 03179 if (type_l != Character || type_r != Character) { 03180 intrinsic = FALSE; 03181 } 03182 break; 03183 03184 case Eq_Opr : 03185 case Ge_Opr : 03186 03187 if (EQ_NE_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03188 EQ_NE_EXTN(exp_idx_l, exp_idx_r)) { 03189 intrinsic = FALSE; 03190 } 03191 break; 03192 03193 case Gt_Opr : 03194 case Le_Opr : 03195 case Lt_Opr : 03196 case Ne_Opr : 03197 03198 if (GT_LT_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03199 GT_LT_EXTN(exp_idx_l, exp_idx_r)) { 03200 intrinsic = FALSE; 03201 } 03202 break; 03203 03204 case And_Opr : 03205 case Eqv_Opr : 03206 case Neqv_Opr : 03207 case Or_Opr : 03208 03209 if (AND_OR_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03210 AND_OR_EXTN(exp_idx_l, exp_idx_r)) { 03211 intrinsic = FALSE; 03212 } 03213 break; 03214 03215 case Not_Opr : 03216 03217 if (NOT_TYPE(exp_idx_l) == Err_Res || 03218 NOT_EXTN(exp_idx_l)) { 03219 intrinsic = FALSE; 03220 } 03221 break; 03222 03223 case Asg_Opr : 03224 03225 if (ASG_TYPE(exp_idx_l, exp_idx_r) == Err_Res || 03226 ASG_TYPE(exp_idx_l, exp_idx_r) == Structure_Type || 03227 ASG_EXTN(exp_idx_l, exp_idx_r)) { 03228 intrinsic = FALSE; 03229 } 03230 break; 03231 } 03232 03233 03234 03235 EXIT: 03236 03237 TRACE (Func_Exit, "operation_is_intrinsic", NULL); 03238 03239 return(intrinsic); 03240 03241 } /* operation_is_intrinsic */ 03242 03243 /******************************************************************************\ 03244 |* *| 03245 |* Description: *| 03246 |* This routine takes two constant table indexes and applies the *| 03247 |* relational operator to them and returns the boolean result. *| 03248 |* It uses the fortran folders and assumes that the input indexes are *| 03249 |* constant table indexes. Big trouble could result if they are not. *| 03250 |* It issues internal errors if the operator is not a relational or if *| 03251 |* the types of the operands are invalid. *| 03252 |* *| 03253 |* Input parameters: *| 03254 |* idx_1, idx_2 - the two constant table indexes. *| 03255 |* opr - the operator to use. *| 03256 |* *| 03257 |* Output parameters: *| 03258 |* NONE *| 03259 |* *| 03260 |* Returns: *| 03261 |* The result of the fold. *| 03262 |* *| 03263 \******************************************************************************/ 03264 03265 boolean fold_relationals(int idx_1, 03266 int idx_2, 03267 operator_type opr) 03268 03269 { 03270 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 03271 boolean ok; 03272 int unused; 03273 03274 03275 TRACE (Func_Entry, "fold_relationals", NULL); 03276 03277 switch (opr) { 03278 case Eq_Opr: 03279 case Ne_Opr: 03280 case Lt_Opr: 03281 case Le_Opr: 03282 case Gt_Opr: 03283 case Ge_Opr: 03284 03285 unused = CG_LOGICAL_DEFAULT_TYPE; 03286 03287 ok = folder_driver((char *)&CN_CONST(idx_1), 03288 CN_TYPE_IDX(idx_1), 03289 (char *)&CN_CONST(idx_2), 03290 CN_TYPE_IDX(idx_2), 03291 folded_const, 03292 &unused, 03293 stmt_start_line, 03294 stmt_start_col, 03295 2, 03296 opr); 03297 03298 break; 03299 03300 default : 03301 PRINTMSG(stmt_start_line, 251, Internal, stmt_start_col); 03302 break; 03303 03304 } 03305 03306 03307 TRACE (Func_Exit, "fold_relationals", NULL); 03308 03309 return(THIS_IS_TRUE(folded_const,unused)); 03310 03311 } /* fold_relationals */ 03312 03313 /******************************************************************************\ 03314 |* *| 03315 |* Description: *| 03316 |* Create the expression for the extent of an array section. *| 03317 |* *| 03318 |* Input parameters: *| 03319 |* list_idx - IL_Tbl_Idx, points to start value, linked to end and stride*| 03320 |* *| 03321 |* Output parameters: *| 03322 |* opnd - opnd_type, this is the result expression. *| 03323 |* *| 03324 |* Returns: *| 03325 |* NOTHING *| 03326 |* *| 03327 \******************************************************************************/ 03328 03329 void make_triplet_extent_tree(opnd_type *opnd, 03330 int list_idx) 03331 03332 { 03333 int col; 03334 int div_idx; 03335 expr_arg_type exp_desc; 03336 boolean foldable = TRUE; 03337 int line; 03338 int plus_idx; 03339 int list_idx2; 03340 int max_idx; 03341 expr_mode_type save_expr_mode; 03342 cif_usage_code_type save_xref_state; 03343 int sub_idx; 03344 opnd_type topnd; 03345 boolean unused; 03346 boolean will_fold_later = TRUE; 03347 03348 03349 TRACE (Func_Entry, "make_triplet_extent_tree", NULL); 03350 03351 find_opnd_line_and_column(opnd, &line, &col); 03352 03353 NTR_IR_TBL(plus_idx); 03354 IR_OPR(plus_idx) = Plus_Opr; 03355 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 03356 IR_LINE_NUM(plus_idx) = line; 03357 IR_COL_NUM(plus_idx) = col; 03358 03359 NTR_IR_TBL(div_idx); 03360 IR_OPR(div_idx) = Div_Opr; 03361 IR_TYPE_IDX(div_idx) = CG_INTEGER_DEFAULT_TYPE; 03362 IR_LINE_NUM(div_idx) = line; 03363 IR_COL_NUM(div_idx) = col; 03364 03365 NTR_IR_TBL(sub_idx); 03366 IR_OPR(sub_idx) = Minus_Opr; 03367 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 03368 IR_LINE_NUM(sub_idx) = line; 03369 IR_COL_NUM(sub_idx) = col; 03370 03371 NTR_IR_TBL(max_idx); 03372 IR_OPR(max_idx) = Max_Opr; 03373 IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE; 03374 IR_LINE_NUM(max_idx) = line; 03375 IR_COL_NUM(max_idx) = col; 03376 03377 03378 OPND_FLD((*opnd)) = IR_Tbl_Idx; 03379 OPND_IDX((*opnd)) = max_idx; 03380 03381 NTR_IR_LIST_TBL(list_idx2); 03382 IR_FLD_L(max_idx) = IL_Tbl_Idx; 03383 IR_LIST_CNT_L(max_idx) = 2; 03384 IR_IDX_L(max_idx) = list_idx2; 03385 03386 IL_FLD(list_idx2) = IR_Tbl_Idx; 03387 IL_IDX(list_idx2) = div_idx; 03388 03389 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2)); 03390 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2; 03391 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 03392 03393 IL_FLD(list_idx2) = CN_Tbl_Idx; 03394 IL_IDX(list_idx2) = CN_INTEGER_ZERO_IDX; 03395 IL_LINE_NUM(list_idx2) = line; 03396 IL_COL_NUM(list_idx2) = col; 03397 03398 IR_FLD_L(div_idx) = IR_Tbl_Idx; 03399 IR_IDX_L(div_idx) = plus_idx; 03400 03401 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 03402 IR_IDX_L(plus_idx) = sub_idx; 03403 03404 /* start */ 03405 COPY_OPND(topnd, IL_OPND(list_idx)); 03406 copy_subtree(&topnd, &topnd); 03407 COPY_OPND(IR_OPND_R(sub_idx), topnd); 03408 03409 foldable = foldable && (IL_FLD(list_idx) == CN_Tbl_Idx || 03410 SHAPE_FOLDABLE(IL_OPND(list_idx))); 03411 will_fold_later = will_fold_later && 03412 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)); 03413 03414 list_idx = IL_NEXT_LIST_IDX(list_idx); 03415 03416 /* end */ 03417 COPY_OPND(topnd, IL_OPND(list_idx)); 03418 copy_subtree(&topnd, &topnd); 03419 COPY_OPND(IR_OPND_L(sub_idx), topnd); 03420 03421 foldable = foldable && (IL_FLD(list_idx) == CN_Tbl_Idx || 03422 SHAPE_FOLDABLE(IL_OPND(list_idx))); 03423 will_fold_later = will_fold_later && 03424 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)); 03425 03426 list_idx = IL_NEXT_LIST_IDX(list_idx); 03427 03428 /* stride */ 03429 COPY_OPND(topnd, IL_OPND(list_idx)); 03430 copy_subtree(&topnd, &topnd); 03431 COPY_OPND(IR_OPND_R(div_idx), topnd); 03432 03433 COPY_OPND(topnd, IL_OPND(list_idx)); 03434 copy_subtree(&topnd, &topnd); 03435 COPY_OPND(IR_OPND_R(plus_idx), topnd); 03436 03437 foldable = foldable && (IL_FLD(list_idx) == CN_Tbl_Idx || 03438 SHAPE_FOLDABLE(IL_OPND(list_idx))); 03439 will_fold_later = will_fold_later && 03440 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)); 03441 03442 if (foldable) { 03443 save_xref_state = xref_state; 03444 xref_state = CIF_No_Usage_Rec; 03445 save_expr_mode = expr_mode; 03446 expr_mode = Regular_Expr; 03447 03448 exp_desc.rank = 0; 03449 unused = expr_semantics(opnd, &exp_desc); 03450 xref_state = save_xref_state; 03451 expr_mode = save_expr_mode; 03452 03453 SHAPE_FOLDABLE((*opnd)) = exp_desc.foldable; 03454 SHAPE_WILL_FOLD_LATER((*opnd)) = exp_desc.will_fold_later; 03455 } 03456 else { 03457 SHAPE_FOLDABLE((*opnd)) = foldable; 03458 SHAPE_WILL_FOLD_LATER((*opnd)) = will_fold_later; 03459 } 03460 03461 03462 TRACE (Func_Exit, "make_triplet_extent_tree", NULL); 03463 03464 return; 03465 03466 } /* make_triplet_extent_tree */ 03467 03468 /******************************************************************************\ 03469 |* *| 03470 |* Description: *| 03471 |* This routine provides an interface into the assignment semantics *| 03472 |* table. It is provided for parameter and data stmt semantic checking. *| 03473 |* The "right hand side" is assumed to be a constant. Rank is not checked*| 03474 |* If the types and aux types combination is allowed TRUE is returned, *| 03475 |* else FALSE. *| 03476 |* *| 03477 |* Input parameters: *| 03478 |* l_type type index of left hand side. *| 03479 |* r_type type index of right hand side. *| 03480 |* line, col line and col to use for messages. *| 03481 |* if line == -1, don't issue message. *| 03482 |* *| 03483 |* Output parameters: *| 03484 |* NONE *| 03485 |* *| 03486 |* Returns: *| 03487 |* TRUE if assignment is allowed, FALSE otherwise. *| 03488 |* *| 03489 \******************************************************************************/ 03490 03491 boolean check_asg_semantics(int l_new_type_idx, 03492 int r_new_type_idx, 03493 int line, 03494 int col) 03495 03496 { 03497 boolean correct = TRUE; 03498 linear_type_type exp_idx_l; 03499 linear_type_type exp_idx_r; 03500 03501 03502 TRACE (Func_Entry, "check_asg_semantics", NULL); 03503 03504 exp_idx_l = TYP_LINEAR(l_new_type_idx); 03505 exp_idx_r = TYP_LINEAR(r_new_type_idx); 03506 03507 if (TYP_TYPE(r_new_type_idx) == Character && 03508 compare_cn_and_value(TYP_IDX(r_new_type_idx), 03509 MAX_CHARS_IN_TYPELESS, 03510 Le_Opr)) { 03511 exp_idx_r = Short_Char_Const; 03512 } 03513 03514 if (ASG_TYPE(exp_idx_l, exp_idx_r) == Err_Res) { 03515 correct = FALSE; 03516 } 03517 else if (ASG_TYPE(exp_idx_l, exp_idx_r) == Structure_Type && 03518 !compare_derived_types(l_new_type_idx, r_new_type_idx)) { 03519 correct = FALSE; 03520 } 03521 03522 if (correct && 03523 ASG_EXTN(exp_idx_l, exp_idx_r) && 03524 TYP_TYPE(r_new_type_idx) == Character && 03525 line != -1) { 03526 03527 PRINTMSG(line, 161, Ansi, col); 03528 } 03529 03530 TRACE (Func_Exit, "check_asg_semantics", NULL); 03531 03532 return(correct); 03533 03534 } /* check_asg_semantics */ 03535 03536 /******************************************************************************\ 03537 |* *| 03538 |* Description: *| 03539 |* Creates a whole dope vector copy for pointer assignment from a pointer*| 03540 |* *| 03541 |* Input parameters: *| 03542 |* l_opnd - left hand side of ptr assignment. *| 03543 |* r_opnd - right hand side of ptr assignment. *| 03544 |* *| 03545 |* Output parameters: *| 03546 |* NONE *| 03547 |* *| 03548 |* Returns: *| 03549 |* NOTHING *| 03550 |* *| 03551 \******************************************************************************/ 03552 03553 void ptr_assign_from_ptr(opnd_type *l_opnd, 03554 opnd_type *r_opnd) 03555 03556 { 03557 int column; 03558 int dv_idx; 03559 int line; 03560 sh_position_type location; 03561 opnd_type opnd; 03562 03563 03564 TRACE (Func_Entry, "ptr_assign_from_ptr", NULL); 03565 03566 location = (SH_LABELED(curr_stmt_sh_idx)) ? After : Before; 03567 03568 03569 /**********************************\ 03570 |* VECTOR COPY WHOLE DOPE VECTOR. *| 03571 \**********************************/ 03572 03573 NTR_IR_TBL(dv_idx); 03574 03575 IR_OPR(dv_idx) = Dv_Whole_Copy_Opr; 03576 IR_TYPE_IDX(dv_idx) = TYPELESS_DEFAULT_TYPE; 03577 IR_LINE_NUM(dv_idx) = stmt_start_line; 03578 IR_COL_NUM(dv_idx) = stmt_start_col; 03579 03580 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 03581 03582 COPY_OPND(opnd, (*r_opnd)); 03583 03584 if (OPND_FLD(opnd) == IR_Tbl_Idx) { 03585 03586 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 03587 if (IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) { 03588 break; 03589 } 03590 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 03591 } 03592 03593 if (OPND_FLD(opnd) != IR_Tbl_Idx || 03594 IR_OPR(OPND_IDX(opnd)) != Dv_Deref_Opr) { 03595 find_opnd_line_and_column(&opnd, &line, &column); 03596 PRINTMSG(line, 976, Internal, column); 03597 } 03598 else { 03599 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 03600 } 03601 } 03602 else { 03603 find_opnd_line_and_column(&opnd, &line, &column); 03604 PRINTMSG(line, 977, Internal, column); 03605 } 03606 03607 COPY_OPND(IR_OPND_R(dv_idx), opnd); 03608 03609 gen_sh(location, Assignment_Stmt, stmt_start_line, 03610 stmt_start_col, FALSE, FALSE, TRUE); 03611 03612 if (location == Before) { 03613 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 03614 } 03615 else { 03616 SH_IR_IDX(curr_stmt_sh_idx) = dv_idx; 03617 } 03618 03619 03620 /*************************************\ 03621 |* SET FLAGS BACK TO ORIGINAL VALUES *| 03622 \*************************************/ 03623 03624 NTR_IR_TBL(dv_idx); 03625 IR_OPR(dv_idx) = Dv_Set_P_Or_A; 03626 IR_TYPE_IDX(dv_idx) = TYPELESS_DEFAULT_TYPE; 03627 IR_LINE_NUM(dv_idx) = stmt_start_line; 03628 IR_COL_NUM(dv_idx) = stmt_start_col; 03629 03630 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 03631 03632 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 03633 IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX; 03634 IR_LINE_NUM_R(dv_idx) = stmt_start_line; 03635 IR_COL_NUM_R(dv_idx) = stmt_start_col; 03636 03637 gen_sh(location, Assignment_Stmt, stmt_start_line, 03638 stmt_start_col, FALSE, FALSE, TRUE); 03639 03640 if (location == Before) { 03641 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 03642 } 03643 else { 03644 SH_IR_IDX(curr_stmt_sh_idx) = dv_idx; 03645 } 03646 03647 TRACE (Func_Exit, "ptr_assign_from_ptr", NULL); 03648 03649 return; 03650 03651 } /* ptr_assign_from_ptr */ 03652 03653 /******************************************************************************\ 03654 |* *| 03655 |* Description: *| 03656 |* Create the length (max(0,length)) operand for substring oprs. *| 03657 |* *| 03658 |* Input parameters: *| 03659 |* sub_idx - IR_Tbl_Idx for substring opr. *| 03660 |* *| 03661 |* Output parameters: *| 03662 |* NONE *| 03663 |* *| 03664 |* Returns: *| 03665 |* NOTHING *| 03666 |* *| 03667 \******************************************************************************/ 03668 03669 void add_substring_length(int sub_idx) 03670 03671 { 03672 int col; 03673 int end_idx; 03674 expr_arg_type exp_desc; 03675 boolean foldit; 03676 int line; 03677 int list_idx; 03678 int list2_idx; 03679 int max_idx; 03680 int minus_idx; 03681 boolean ok; 03682 opnd_type opnd; 03683 int plus_idx; 03684 expr_mode_type save_expr_mode; 03685 cif_usage_code_type save_xref_state; 03686 int start_idx; 03687 03688 03689 TRACE (Func_Entry, "add_substring_length", NULL); 03690 03691 start_idx = IR_IDX_R(sub_idx); 03692 end_idx = IL_NEXT_LIST_IDX(start_idx); 03693 03694 if (IL_FLD(start_idx) == NO_Tbl_Idx || 03695 IL_FLD(end_idx) == NO_Tbl_Idx) { 03696 03697 goto EXIT; 03698 } 03699 03700 foldit = (IL_FLD(start_idx) == CN_Tbl_Idx) && 03701 (IL_FLD(end_idx) == CN_Tbl_Idx); 03702 03703 line = IR_LINE_NUM(sub_idx); 03704 col = IR_COL_NUM(sub_idx); 03705 03706 save_expr_mode = expr_mode; 03707 03708 NTR_IR_LIST_TBL(list_idx); 03709 IL_PREV_LIST_IDX(list_idx) = end_idx; 03710 IL_NEXT_LIST_IDX(end_idx) = list_idx; 03711 IR_LIST_CNT_R(sub_idx)++; 03712 03713 /*do not generate MAX---FMZ Sept 2005*/ 03714 #if !defined(SOURCE_TO_SOURCE) 03715 NTR_IR_TBL(max_idx); 03716 IR_OPR(max_idx) = Max_Opr; 03717 IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE; 03718 IR_LINE_NUM(max_idx) = line; 03719 IR_COL_NUM(max_idx) = col; 03720 03721 IL_FLD(list_idx) = IR_Tbl_Idx; 03722 IL_IDX(list_idx) = max_idx; 03723 03724 NTR_IR_LIST_TBL(list2_idx); 03725 IR_FLD_L(max_idx) = IL_Tbl_Idx; 03726 IR_LIST_CNT_L(max_idx) = 2; 03727 IR_IDX_L(max_idx) = list2_idx; 03728 03729 IL_FLD(list2_idx) = CN_Tbl_Idx; 03730 IL_IDX(list2_idx) = CN_INTEGER_ZERO_IDX; 03731 IL_LINE_NUM(list2_idx) = line; 03732 IL_COL_NUM(list2_idx) = col; 03733 03734 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 03735 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx; 03736 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 03737 #endif 03738 03739 NTR_IR_TBL(plus_idx); 03740 IR_OPR(plus_idx) = Plus_Opr; 03741 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 03742 IR_LINE_NUM(plus_idx) = line; 03743 IR_COL_NUM(plus_idx) = col; 03744 03745 #if !defined(SOURCE_TO_SOURCE) 03746 IL_FLD(list2_idx) = IR_Tbl_Idx; 03747 IL_IDX(list2_idx) = plus_idx; 03748 #else 03749 IL_FLD(list_idx) = IR_Tbl_Idx; 03750 IL_IDX(list_idx) = plus_idx; 03751 #endif 03752 03753 NTR_IR_TBL(minus_idx); 03754 IR_OPR(minus_idx) = Minus_Opr; 03755 IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE; 03756 IR_LINE_NUM(minus_idx) = line; 03757 IR_COL_NUM(minus_idx) = col; 03758 03759 IR_FLD_R(plus_idx) = IR_Tbl_Idx; 03760 IR_IDX_R(plus_idx) = minus_idx; 03761 03762 COPY_OPND(opnd, IL_OPND(start_idx)); 03763 copy_subtree(&opnd, &opnd); 03764 COPY_OPND(IR_OPND_R(minus_idx), opnd); 03765 03766 COPY_OPND(opnd, IL_OPND(end_idx)); 03767 copy_subtree(&opnd, &opnd); 03768 COPY_OPND(IR_OPND_L(plus_idx), opnd); 03769 03770 IR_FLD_L(minus_idx) = CN_Tbl_Idx; 03771 IR_IDX_L(minus_idx) = CN_INTEGER_ONE_IDX; 03772 IR_LINE_NUM_L(minus_idx) = line; 03773 IR_COL_NUM_L(minus_idx) = col; 03774 03775 if (foldit) { 03776 expr_mode = Regular_Expr; 03777 save_xref_state = xref_state; 03778 xref_state = CIF_No_Usage_Rec; 03779 COPY_OPND(opnd, IL_OPND(list_idx)); 03780 exp_desc.rank = 0; 03781 ok = expr_semantics(&opnd, &exp_desc); 03782 COPY_OPND(IL_OPND(list_idx), opnd); 03783 03784 expr_mode = save_expr_mode; 03785 xref_state = save_xref_state; 03786 } 03787 03788 EXIT: 03789 03790 TRACE (Func_Exit, "add_substring_length", NULL); 03791 03792 return; 03793 03794 } /* add_substring_length */ 03795 03796 /******************************************************************************\ 03797 |* *| 03798 |* Description: *| 03799 |* Do semantic checks for array constructor implied do's *| 03800 |* *| 03801 |* Input parameters: *| 03802 |* top_opnd - opnd pointing to IL_Tbl_Idx. *| 03803 |* *| 03804 |* Output parameters: *| 03805 |* exp_desc - exp_desc for array constructor. *| 03806 |* *| 03807 |* Returns: *| 03808 |* TRUE if no errors. *| 03809 |* *| 03810 \******************************************************************************/ 03811 03812 static boolean array_construct_semantics(opnd_type *top_opnd, 03813 expr_arg_type *exp_desc) 03814 03815 { 03816 int column; 03817 boolean constant_trip = TRUE; 03818 int do_var_idx; 03819 boolean do_var_ok; 03820 boolean first_item = TRUE; 03821 int line; 03822 expr_arg_type loc_exp_desc; 03823 opnd_type initial_opnd; 03824 int list_idx; 03825 int list2_idx; 03826 int new_do_var_idx; 03827 opnd_type opnd; 03828 boolean ok = TRUE; 03829 expr_mode_type save_expr_mode; 03830 boolean save_in_implied_do; 03831 cif_usage_code_type save_xref_state; 03832 long_type the_constant[MAX_WORDS_FOR_NUMERIC]; 03833 int type_idx; 03834 03835 03836 TRACE (Func_Entry, "array_construct_semantics", NULL); 03837 03838 if (OPND_FLD((*top_opnd)) == NO_Tbl_Idx) { 03839 goto EXIT; 03840 } 03841 if (OPND_FLD((*top_opnd)) == IL_Tbl_Idx) { 03842 list_idx = OPND_IDX((*top_opnd)); 03843 } 03844 else { 03845 find_opnd_line_and_column(top_opnd, &line, &column); 03846 PRINTMSG(line, 978, Internal, column); 03847 } 03848 03849 while (list_idx != NULL_IDX) { 03850 03851 IL_HAS_FUNCTIONS(list_idx) = FALSE; 03852 03853 constant_trip = TRUE; 03854 03855 if (IL_FLD(list_idx) == IR_Tbl_Idx && 03856 IR_OPR(IL_IDX(list_idx)) == Implied_Do_Opr) { 03857 03858 list2_idx = IL_NEXT_LIST_IDX(IR_IDX_R(IL_IDX(list_idx))); 03859 03860 /* skip do variable processing until the control values are done. */ 03861 03862 /***********************\ 03863 |* do do initial value *| 03864 \***********************/ 03865 03866 COPY_OPND(initial_opnd, IL_OPND(list2_idx)); 03867 loc_exp_desc.rank = 0; 03868 number_of_functions = 0; 03869 save_xref_state = xref_state; 03870 xref_state = CIF_Symbol_Reference; 03871 ok = expr_sem(&initial_opnd, &loc_exp_desc) && ok; 03872 COPY_OPND(IL_OPND(list2_idx), initial_opnd); 03873 xref_state = save_xref_state; 03874 03875 IL_ARG_DESC_VARIANT(list2_idx) = TRUE; 03876 03877 /* save exp_desc */ 03878 arg_info_list_base = arg_info_list_top; 03879 arg_info_list_top = arg_info_list_base + 1; 03880 03881 if (arg_info_list_top >= arg_info_list_size) { 03882 enlarge_info_list_table(); 03883 } 03884 03885 IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top; 03886 arg_info_list[arg_info_list_top] = init_arg_info; 03887 arg_info_list[arg_info_list_top].ed = loc_exp_desc; 03888 03889 constant_trip = loc_exp_desc.foldable || 03890 loc_exp_desc.will_fold_later; 03891 03892 if (number_of_functions > 0) { 03893 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 03894 IL_HAS_FUNCTIONS(list_idx) = TRUE; 03895 } 03896 else { 03897 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 03898 } 03899 03900 if (loc_exp_desc.rank != 0) { 03901 find_opnd_line_and_column(&initial_opnd, &line, &column); 03902 PRINTMSG(line, 476, Error, column); 03903 ok = FALSE; 03904 } 03905 03906 if (loc_exp_desc.linear_type == Long_Typeless) { 03907 find_opnd_line_and_column(&initial_opnd, &line, &column); 03908 PRINTMSG(line, 1133, Error, column); 03909 ok = FALSE; 03910 } 03911 else if (loc_exp_desc.type != Integer && 03912 loc_exp_desc.type != Typeless) { 03913 find_opnd_line_and_column(&initial_opnd, &line, &column); 03914 PRINTMSG(line, 962, Error, column); 03915 ok = FALSE; 03916 } 03917 else if (loc_exp_desc.linear_type == Short_Typeless_Const) { 03918 find_opnd_line_and_column(&initial_opnd, &line, &column); 03919 IL_IDX(list2_idx) = cast_typeless_constant(IL_IDX(list2_idx), 03920 INTEGER_DEFAULT_TYPE, 03921 line, 03922 column); 03923 loc_exp_desc.type_idx = INTEGER_DEFAULT_TYPE; 03924 loc_exp_desc.type = Integer; 03925 loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE; 03926 COPY_OPND(initial_opnd, IL_OPND(list2_idx)); 03927 } 03928 03929 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 03930 03931 /************************\ 03932 |* do do terminal value *| 03933 \************************/ 03934 03935 COPY_OPND(opnd, IL_OPND(list2_idx)); 03936 loc_exp_desc.rank = 0; 03937 number_of_functions = 0; 03938 save_xref_state = xref_state; 03939 xref_state = CIF_Symbol_Reference; 03940 ok = expr_sem(&opnd, &loc_exp_desc) && ok; 03941 COPY_OPND(IL_OPND(list2_idx), opnd); 03942 xref_state = save_xref_state; 03943 03944 IL_ARG_DESC_VARIANT(list2_idx) = TRUE; 03945 03946 /* save exp_desc */ 03947 arg_info_list_base = arg_info_list_top; 03948 arg_info_list_top = arg_info_list_base + 1; 03949 03950 if (arg_info_list_top >= arg_info_list_size) { 03951 enlarge_info_list_table(); 03952 } 03953 03954 IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top; 03955 arg_info_list[arg_info_list_top] = init_arg_info; 03956 arg_info_list[arg_info_list_top].ed = loc_exp_desc; 03957 03958 constant_trip &= loc_exp_desc.foldable || 03959 loc_exp_desc.will_fold_later; 03960 03961 if (number_of_functions > 0) { 03962 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 03963 IL_HAS_FUNCTIONS(list_idx) = TRUE; 03964 } 03965 else { 03966 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 03967 } 03968 03969 if (loc_exp_desc.rank != 0) { 03970 find_opnd_line_and_column(&opnd, &line, &column); 03971 PRINTMSG(line, 476, Error, column); 03972 ok = FALSE; 03973 } 03974 03975 if (loc_exp_desc.linear_type == Long_Typeless) { 03976 find_opnd_line_and_column(&opnd, &line, &column); 03977 PRINTMSG(line, 1133, Error, column); 03978 ok = FALSE; 03979 } 03980 else if (loc_exp_desc.type != Integer && 03981 loc_exp_desc.type != Typeless) { 03982 03983 find_opnd_line_and_column(&opnd, &line, &column); 03984 PRINTMSG(line, 962, Error, column); 03985 ok = FALSE; 03986 } 03987 else if (loc_exp_desc.linear_type == Short_Typeless_Const) { 03988 find_opnd_line_and_column(&opnd, &line, &column); 03989 IL_IDX(list2_idx) = cast_typeless_constant(IL_IDX(list2_idx), 03990 INTEGER_DEFAULT_TYPE, 03991 line, 03992 column); 03993 loc_exp_desc.type_idx = INTEGER_DEFAULT_TYPE; 03994 loc_exp_desc.type = Integer; 03995 loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE; 03996 } 03997 03998 03999 /********************************\ 04000 |* do do stride if there is one *| 04001 \********************************/ 04002 04003 if (IL_NEXT_LIST_IDX(list2_idx) != NULL_IDX) { 04004 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 04005 COPY_OPND(opnd, IL_OPND(list2_idx)); 04006 loc_exp_desc.rank = 0; 04007 number_of_functions = 0; 04008 save_xref_state = xref_state; 04009 xref_state = CIF_Symbol_Reference; 04010 ok = expr_sem(&opnd, &loc_exp_desc) && ok; 04011 COPY_OPND(IL_OPND(list2_idx), opnd); 04012 xref_state = save_xref_state; 04013 04014 find_opnd_line_and_column(&opnd, &line, &column); 04015 04016 IL_ARG_DESC_VARIANT(list2_idx) = TRUE; 04017 04018 /* save exp_desc */ 04019 arg_info_list_base = arg_info_list_top; 04020 arg_info_list_top = arg_info_list_base + 1; 04021 04022 if (arg_info_list_top >= arg_info_list_size) { 04023 enlarge_info_list_table(); 04024 } 04025 04026 IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top; 04027 arg_info_list[arg_info_list_top] = init_arg_info; 04028 arg_info_list[arg_info_list_top].ed = loc_exp_desc; 04029 04030 constant_trip &= loc_exp_desc.foldable || 04031 loc_exp_desc.will_fold_later; 04032 04033 if (number_of_functions > 0) { 04034 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 04035 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04036 } 04037 else { 04038 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 04039 } 04040 04041 if (loc_exp_desc.rank != 0) { 04042 PRINTMSG(line, 476, Error, column); 04043 ok = FALSE; 04044 } 04045 04046 if (loc_exp_desc.linear_type == Long_Typeless) { 04047 PRINTMSG(line, 1133, Error, column); 04048 ok = FALSE; 04049 } 04050 else if (loc_exp_desc.type != Integer && 04051 loc_exp_desc.type != Typeless) { 04052 04053 PRINTMSG(line, 962, Error, column); 04054 ok = FALSE; 04055 } 04056 else if (loc_exp_desc.linear_type == Short_Typeless_Const) { 04057 IL_IDX(list2_idx) = cast_typeless_constant(IL_IDX(list2_idx), 04058 INTEGER_DEFAULT_TYPE, 04059 line, 04060 column); 04061 loc_exp_desc.type_idx = INTEGER_DEFAULT_TYPE; 04062 loc_exp_desc.type = Integer; 04063 loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE; 04064 } 04065 04066 if (ok && 04067 OPND_FLD(opnd) == CN_Tbl_Idx) { 04068 04069 type_idx = CG_LOGICAL_DEFAULT_TYPE; 04070 04071 ok &= folder_driver((char *)&CN_CONST(OPND_IDX(opnd)), 04072 loc_exp_desc.type_idx, 04073 (char *)&CN_CONST(CN_INTEGER_ZERO_IDX), 04074 CG_INTEGER_DEFAULT_TYPE, 04075 the_constant, 04076 &type_idx, 04077 line, 04078 column, 04079 2, 04080 Eq_Opr); 04081 04082 if (THIS_IS_TRUE(the_constant, type_idx)) { 04083 PRINTMSG(line, 1084, Error, column); 04084 ok = FALSE; 04085 } 04086 } 04087 } 04088 else { 04089 /* fill in default stride here */ 04090 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 04091 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 04092 IR_LIST_CNT_R(IL_IDX(list_idx))++; 04093 IL_FLD(list2_idx) = CN_Tbl_Idx; 04094 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX; 04095 IL_LINE_NUM(list2_idx) = stmt_start_line; 04096 IL_COL_NUM(list2_idx) = stmt_start_col; 04097 IL_ARG_DESC_VARIANT(list2_idx) = TRUE; 04098 04099 /* save exp_desc */ 04100 arg_info_list_base = arg_info_list_top; 04101 arg_info_list_top = arg_info_list_base + 1; 04102 04103 if (arg_info_list_top >= arg_info_list_size) { 04104 enlarge_info_list_table(); 04105 } 04106 04107 IL_ARG_DESC_IDX(list2_idx) = arg_info_list_top; 04108 arg_info_list[arg_info_list_top] = init_arg_info; 04109 arg_info_list[arg_info_list_top].ed.constant = TRUE; 04110 arg_info_list[arg_info_list_top].ed.foldable = TRUE; 04111 arg_info_list[arg_info_list_top].ed.type = Integer; 04112 arg_info_list[arg_info_list_top].ed.type_idx = 04113 CG_INTEGER_DEFAULT_TYPE; 04114 arg_info_list[arg_info_list_top].ed.linear_type = 04115 CG_INTEGER_DEFAULT_TYPE; 04116 } 04117 04118 /**************************\ 04119 |* do do control variable *| 04120 \**************************/ 04121 04122 list2_idx = IR_IDX_R(IL_IDX(list_idx)); 04123 04124 do_var_ok = TRUE; 04125 COPY_OPND(opnd, IL_OPND(list2_idx)); 04126 loc_exp_desc.rank = 0; 04127 number_of_functions = 0; 04128 save_xref_state = xref_state; 04129 xref_state = CIF_No_Usage_Rec; 04130 save_in_implied_do = in_implied_do; 04131 in_implied_do = FALSE; 04132 save_expr_mode = expr_mode; 04133 expr_mode = Regular_Expr; 04134 do_var_ok = expr_sem(&opnd, &loc_exp_desc); 04135 COPY_OPND(IL_OPND(list2_idx), opnd); 04136 expr_mode = save_expr_mode; 04137 in_implied_do = save_in_implied_do; 04138 xref_state = save_xref_state; 04139 04140 if (number_of_functions > 0) { 04141 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 04142 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04143 } 04144 else { 04145 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 04146 } 04147 04148 /* BHJ JLS LRR ... need interpretation for this one. imp do var must be */ 04149 /* "named" scalar variable, not sub-object. */ 04150 if (!loc_exp_desc.reference) { 04151 find_opnd_line_and_column(&opnd, &line, &column); 04152 PRINTMSG(line, 481, Error, column); 04153 do_var_ok = FALSE; 04154 } 04155 else { 04156 04157 if (loc_exp_desc.type != Integer) { 04158 find_opnd_line_and_column(&opnd, &line, &column); 04159 PRINTMSG(line, 675, Error, column); 04160 do_var_ok = FALSE; 04161 } 04162 04163 if (OPND_FLD(opnd) == IR_Tbl_Idx && 04164 IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) { 04165 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 04166 } 04167 04168 if (OPND_FLD(opnd) == IR_Tbl_Idx && 04169 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) { 04170 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 04171 } 04172 04173 if (do_var_ok && 04174 OPND_FLD(opnd) != AT_Tbl_Idx) { 04175 find_opnd_line_and_column(&opnd, &line, &column); 04176 PRINTMSG(line, 530, Error, column); 04177 do_var_ok = FALSE; 04178 } 04179 else { 04180 do_var_idx = OPND_IDX(opnd); 04181 } 04182 04183 if (do_var_ok && 04184 loc_exp_desc.rank) { 04185 find_opnd_line_and_column(&opnd, &line, &column); 04186 PRINTMSG(line, 837, Ansi, column); 04187 } 04188 04189 } 04190 04191 if (do_var_ok) { 04192 04193 if (AT_ATTR_LINK(do_var_idx)) { 04194 find_opnd_line_and_column(&opnd, &line, &column); 04195 PRINTMSG(line, 533, Error, column, 04196 AT_OBJ_NAME_PTR(do_var_idx)); 04197 do_var_ok = FALSE; 04198 } 04199 else { 04200 find_opnd_line_and_column(&opnd, &line, &column); 04201 new_do_var_idx = gen_compiler_tmp(line, column, Priv, TRUE); 04202 AT_SEMANTICS_DONE(new_do_var_idx)= TRUE; 04203 ATD_TYPE_IDX(new_do_var_idx) = ATD_TYPE_IDX(do_var_idx); 04204 ATD_STOR_BLK_IDX(new_do_var_idx) = 04205 SCP_SB_STACK_IDX(curr_scp_idx); 04206 04207 /* change name to original name */ 04208 AT_NAME_IDX(new_do_var_idx) = AT_NAME_IDX(do_var_idx); 04209 AT_NAME_LEN(new_do_var_idx) = AT_NAME_LEN(do_var_idx); 04210 04211 ATD_TMP_IDX(new_do_var_idx) = constructor_level; 04212 AT_ATTR_LINK(do_var_idx) = new_do_var_idx; 04213 AT_IGNORE_ATTR_LINK(do_var_idx) = TRUE; 04214 04215 ATD_IMP_DO_LCV(new_do_var_idx) = TRUE; 04216 ATD_LCV_IS_CONST(new_do_var_idx) = constant_trip; 04217 ATD_TMP_NEEDS_CIF(new_do_var_idx) = TRUE; 04218 04219 IL_FLD(list2_idx) = AT_Tbl_Idx; 04220 IL_IDX(list2_idx) = new_do_var_idx; 04221 IL_LINE_NUM(list2_idx) = line; 04222 IL_COL_NUM(list2_idx) = column; 04223 04224 /* issue a usage rec if needed */ 04225 if ((cif_flags & XREF_RECS) != 0) { 04226 cif_usage_rec(new_do_var_idx, AT_Tbl_Idx, line, column, 04227 CIF_Symbol_Modification); 04228 } 04229 04230 } 04231 } 04232 04233 ok = ok && do_var_ok; 04234 04235 /***********************\ 04236 |* do list of io items *| 04237 \***********************/ 04238 04239 in_implied_do = TRUE; 04240 COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx))); 04241 number_of_functions = 0; 04242 ok = array_construct_semantics(&opnd, &loc_exp_desc) && ok; 04243 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), opnd); 04244 04245 if (number_of_functions > 0) { 04246 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04247 } 04248 04249 IR_TYPE_IDX(IL_IDX(list_idx)) = loc_exp_desc.type_idx; 04250 04251 if (do_var_ok) { 04252 /* clear the AT_ATTR_LINK field of the old do var attr */ 04253 AT_ATTR_LINK(do_var_idx) = NULL_IDX; 04254 AT_IGNORE_ATTR_LINK(do_var_idx) = FALSE; 04255 04256 /* clear the ATD_TMP_IDX on new_do_var_idx. */ 04257 /* it held the constructor_level. */ 04258 ATD_TMP_IDX(new_do_var_idx) = NULL_IDX; 04259 04260 /* now set the initial opnd on the tmp_idx field */ 04261 ATD_FLD(new_do_var_idx) = OPND_FLD(initial_opnd); 04262 ATD_TMP_IDX(new_do_var_idx) = OPND_IDX(initial_opnd); 04263 } 04264 04265 in_implied_do = save_in_implied_do; 04266 } 04267 else { 04268 04269 loc_exp_desc.rank = 0; 04270 COPY_OPND(opnd, IL_OPND(list_idx)); 04271 number_of_functions = 0; 04272 04273 save_xref_state = xref_state; 04274 xref_state = CIF_Symbol_Reference; 04275 04276 ok = expr_sem(&opnd, &loc_exp_desc) && ok; 04277 04278 xref_state = save_xref_state; 04279 04280 if (loc_exp_desc.linear_type == Short_Typeless_Const) { 04281 find_opnd_line_and_column((opnd_type *) &opnd, &line, &column); 04282 OPND_IDX(opnd) = cast_typeless_constant(OPND_IDX(opnd), 04283 INTEGER_DEFAULT_TYPE, 04284 line, 04285 column); 04286 04287 loc_exp_desc.type_idx = INTEGER_DEFAULT_TYPE; 04288 loc_exp_desc.type = Integer; 04289 loc_exp_desc.linear_type = INTEGER_DEFAULT_TYPE; 04290 } 04291 04292 COPY_OPND(IL_OPND(list_idx), opnd); 04293 04294 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 04295 04296 /* save exp_desc */ 04297 arg_info_list_base = arg_info_list_top; 04298 arg_info_list_top = arg_info_list_base + 1; 04299 04300 if (arg_info_list_top >= arg_info_list_size) { 04301 enlarge_info_list_table(); 04302 } 04303 04304 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top; 04305 arg_info_list[arg_info_list_top] = init_arg_info; 04306 arg_info_list[arg_info_list_top].ed = loc_exp_desc; 04307 04308 if (number_of_functions > 0) { 04309 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04310 } 04311 04312 } 04313 04314 if (first_item) { 04315 if (loc_exp_desc.linear_type == Typeless_4 || 04316 loc_exp_desc.linear_type == Typeless_8) { 04317 exp_desc->type_idx = INTEGER_DEFAULT_TYPE; 04318 exp_desc->type = Integer; 04319 exp_desc->linear_type = INTEGER_DEFAULT_TYPE; 04320 } 04321 else { 04322 exp_desc->type = loc_exp_desc.type; 04323 exp_desc->type_idx = loc_exp_desc.type_idx; 04324 exp_desc->linear_type = loc_exp_desc.linear_type; 04325 } 04326 04327 COPY_OPND((exp_desc->char_len), (loc_exp_desc.char_len)); 04328 exp_desc->constant = loc_exp_desc.constant; 04329 exp_desc->foldable = loc_exp_desc.foldable && constant_trip; 04330 exp_desc->will_fold_later = (loc_exp_desc.will_fold_later || 04331 loc_exp_desc.foldable) && constant_trip; 04332 exp_desc->has_symbolic = loc_exp_desc.has_symbolic; 04333 first_item = FALSE; 04334 } 04335 else { 04336 04337 if ((loc_exp_desc.linear_type == Typeless_4 || 04338 loc_exp_desc.linear_type == Typeless_8) && 04339 exp_desc->linear_type == INTEGER_DEFAULT_TYPE) { 04340 04341 /* intentionally blank */ 04342 } 04343 else if (exp_desc->type != loc_exp_desc.type) { 04344 04345 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 04346 &line, &column); 04347 PRINTMSG(line, 829, Error, column); 04348 ok = FALSE; 04349 } 04350 else if (exp_desc->type == Structure && 04351 !compare_derived_types(exp_desc->type_idx, 04352 loc_exp_desc.type_idx)) { 04353 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 04354 &line, &column); 04355 PRINTMSG(line, 829, Error, column); 04356 ok = FALSE; 04357 } 04358 else if (exp_desc->type == Character) { 04359 04360 if (loc_exp_desc.char_len.fld == CN_Tbl_Idx) { 04361 04362 if (exp_desc->char_len.fld == CN_Tbl_Idx) { 04363 04364 if (fold_relationals(loc_exp_desc.char_len.idx, 04365 exp_desc->char_len.idx, 04366 Ne_Opr)) { 04367 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 04368 &line, &column); 04369 PRINTMSG(line, 838, Error, column); 04370 ok = FALSE; 04371 } 04372 # if 0 04373 /* if we ever extend the above constraint, */ 04374 /* then include this code. */ 04375 04376 if (fold_relationals(loc_exp_desc.char_len.idx, 04377 exp_desc->char_len.idx, 04378 Gt_Opr)) { 04379 04380 COPY_OPND((exp_desc->char_len), (loc_exp_desc.char_len)); 04381 } 04382 # endif 04383 } 04384 else { 04385 /* replace the char_len with the simpler length */ 04386 COPY_OPND((exp_desc->char_len), (loc_exp_desc.char_len)); 04387 } 04388 } 04389 } 04390 else if (exp_desc->linear_type != loc_exp_desc.linear_type) { 04391 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 04392 &line, &column); 04393 PRINTMSG(line, 829, Error, column); 04394 ok = FALSE; 04395 } 04396 04397 exp_desc->has_symbolic |= loc_exp_desc.has_symbolic; 04398 exp_desc->constant &= loc_exp_desc.constant; 04399 exp_desc->foldable &= loc_exp_desc.foldable && constant_trip; 04400 exp_desc->will_fold_later &= (loc_exp_desc.will_fold_later || 04401 loc_exp_desc.foldable) && 04402 constant_trip; 04403 } 04404 04405 list_idx = IL_NEXT_LIST_IDX(list_idx); 04406 } 04407 04408 04409 EXIT: 04410 04411 TRACE (Func_Exit, "array_construct_semantics", NULL); 04412 04413 return(ok); 04414 04415 } /* array_construct_semantics */ 04416 04417 /******************************************************************************\ 04418 |* *| 04419 |* Description: *| 04420 |* Do semantic checks on the stmt function definition. *| 04421 |* *| 04422 |* Input parameters: *| 04423 |* stmt_func_idx - attr idx for stmt function. *| 04424 |* *| 04425 |* Output parameters: *| 04426 |* NONE *| 04427 |* *| 04428 |* Returns: *| 04429 |* TRUE if no errors. *| 04430 |* *| 04431 \******************************************************************************/ 04432 04433 boolean stmt_func_semantics(int stmt_func_idx) 04434 04435 { 04436 expr_arg_type exp_desc; 04437 int i; 04438 linear_type_type linear_type; 04439 boolean ok = TRUE; 04440 opnd_type opnd; 04441 expr_mode_type save_expr_mode; 04442 boolean save_no_func_expansion; 04443 boolean save_parallel_region; 04444 cif_usage_code_type save_xref_state; 04445 int sn_idx; 04446 04447 04448 TRACE (Func_Entry, "stmt_func_semantics", NULL); 04449 04450 ATS_SF_SEMANTICS_DONE(stmt_func_idx) = TRUE; 04451 04452 /* clear the ATD_SF_DARG flag */ 04453 04454 sn_idx = ATP_FIRST_IDX(stmt_func_idx); 04455 04456 for (i = 0; i < ATP_NUM_DARGS(stmt_func_idx); i++) { 04457 ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = FALSE; 04458 sn_idx++; 04459 } 04460 04461 OPND_FLD(opnd) = (fld_type) ATS_SF_FLD(stmt_func_idx); 04462 OPND_IDX(opnd) = ATS_SF_IDX(stmt_func_idx); 04463 copy_subtree(&opnd, &opnd); 04464 04465 ATS_SF_ACTIVE(stmt_func_idx) = TRUE; 04466 04467 save_parallel_region = cdir_switches.parallel_region; 04468 cdir_switches.parallel_region = FALSE; 04469 save_no_func_expansion = no_func_expansion; 04470 no_func_expansion = TRUE; 04471 save_xref_state = xref_state; 04472 xref_state = CIF_Symbol_Reference; 04473 save_expr_mode = expr_mode; 04474 expr_mode = Stmt_Func_Expr; 04475 04476 ok &= expr_semantics(&opnd, &exp_desc); 04477 04478 expr_mode = save_expr_mode; 04479 xref_state = save_xref_state; 04480 no_func_expansion = save_no_func_expansion; 04481 cdir_switches.parallel_region = save_parallel_region; 04482 ATS_SF_ACTIVE(stmt_func_idx) = FALSE; 04483 04484 /* set the ATD_SF_DARG flag */ 04485 04486 sn_idx = ATP_FIRST_IDX(stmt_func_idx); 04487 04488 for (i = 0; i < ATP_NUM_DARGS(stmt_func_idx); i++) { 04489 ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = TRUE; 04490 sn_idx++; 04491 } 04492 04493 04494 if (exp_desc.rank != 0) { 04495 04496 /* stmt func must be rank zero */ 04497 04498 PRINTMSG(AT_DEF_LINE(stmt_func_idx), 755, Error, 04499 AT_DEF_COLUMN(stmt_func_idx), 04500 AT_OBJ_NAME_PTR(stmt_func_idx)); 04501 ok = FALSE; 04502 AT_DCL_ERR(stmt_func_idx) = TRUE; 04503 } 04504 04505 linear_type = TYP_LINEAR(ATD_TYPE_IDX(stmt_func_idx)); 04506 04507 if (ASG_TYPE(linear_type, exp_desc.linear_type) == Err_Res) { 04508 PRINTMSG(AT_DEF_LINE(stmt_func_idx), 756, Error, 04509 AT_DEF_COLUMN(stmt_func_idx), 04510 AT_OBJ_NAME_PTR(stmt_func_idx)); 04511 ok = FALSE; 04512 AT_DCL_ERR(stmt_func_idx) = TRUE; 04513 } 04514 else if (ASG_TYPE(linear_type, exp_desc.linear_type) == Structure_Type) { 04515 04516 if (!compare_derived_types(ATD_TYPE_IDX(stmt_func_idx), 04517 exp_desc.type_idx)) { 04518 PRINTMSG(AT_DEF_LINE(stmt_func_idx), 756, Error, 04519 AT_DEF_COLUMN(stmt_func_idx), 04520 AT_OBJ_NAME_PTR(stmt_func_idx)); 04521 ok = FALSE; 04522 AT_DCL_ERR(stmt_func_idx) = TRUE; 04523 } 04524 } 04525 04526 TRACE (Func_Exit, "stmt_func_semantics", NULL); 04527 04528 return(ok); 04529 04530 } /* stmt_func_semantics */ 04531 04532 /******************************************************************************\ 04533 |* *| 04534 |* Description: *| 04535 |* Do conformance checks for array syntax operators. Also determine *| 04536 |* "shape" opnd to pass on for the operation based on analysis of *| 04537 |* the right and left shape. *| 04538 |* *| 04539 |* Input parameters: *| 04540 |* exp_desc_l - expression descriptor for left operand. *| 04541 |* exp_desc_r - expression descriptor for right operand. *| 04542 |* line, col - line and column to use for messages. *| 04543 |* *| 04544 |* Output parameters: *| 04545 |* exp_desc - fills in the result shape in this descriptor. *| 04546 |* *| 04547 |* Returns: *| 04548 |* TRUE if no errors. *| 04549 |* *| 04550 \******************************************************************************/ 04551 04552 static boolean bin_array_syntax_check(expr_arg_type *exp_desc_l, 04553 expr_arg_type *exp_desc_r, 04554 expr_arg_type *exp_desc, 04555 int line, 04556 int col) 04557 04558 { 04559 int i; 04560 boolean ok = TRUE; 04561 04562 TRACE (Func_Entry, "bin_array_syntax_check", NULL); 04563 04564 if (exp_desc_r->rank == exp_desc_l->rank) { 04565 /* conformance check here */ 04566 04567 exp_desc->rank = exp_desc_r->rank; 04568 04569 for (i = 0; i < exp_desc_r->rank; i++) { 04570 04571 if (OPND_FLD(exp_desc_l->shape[i]) == CN_Tbl_Idx && 04572 OPND_FLD(exp_desc_r->shape[i]) == CN_Tbl_Idx) { 04573 04574 if (fold_relationals(OPND_IDX(exp_desc_l->shape[i]), 04575 OPND_IDX(exp_desc_r->shape[i]), 04576 Ne_Opr)) { 04577 04578 /* non conforming array syntax */ 04579 PRINTMSG(line, 252, Error, col); 04580 ok = FALSE; 04581 exp_desc->rank = exp_desc_r->rank; 04582 COPY_SHAPE(exp_desc->shape,exp_desc_r->shape, 04583 exp_desc_r->rank); 04584 break; 04585 } 04586 else { 04587 COPY_OPND(exp_desc->shape[i], exp_desc_l->shape[i]); 04588 } 04589 } 04590 else if (SHAPE_FOLDABLE(exp_desc_l->shape[i])) { 04591 COPY_OPND(exp_desc->shape[i], exp_desc_l->shape[i]); 04592 } 04593 else if (SHAPE_FOLDABLE(exp_desc_r->shape[i])) { 04594 COPY_OPND(exp_desc->shape[i], exp_desc_r->shape[i]); 04595 } 04596 else if (SHAPE_WILL_FOLD_LATER(exp_desc_l->shape[i])) { 04597 COPY_OPND(exp_desc->shape[i], exp_desc_l->shape[i]); 04598 } 04599 else { 04600 COPY_OPND(exp_desc->shape[i], exp_desc_r->shape[i]); 04601 } 04602 } 04603 } 04604 else if (exp_desc_r->rank > exp_desc_l->rank) { 04605 exp_desc->rank = exp_desc_r->rank; 04606 COPY_SHAPE(exp_desc->shape,exp_desc_r->shape, 04607 exp_desc_r->rank); 04608 } 04609 else { 04610 exp_desc->rank = exp_desc_l->rank; 04611 COPY_SHAPE(exp_desc->shape,exp_desc_l->shape, 04612 exp_desc_l->rank); 04613 } 04614 04615 04616 TRACE (Func_Exit, "bin_array_syntax_check", NULL); 04617 04618 return(ok); 04619 04620 } /* bin_array_syntax_check */ 04621 04622 /******************************************************************************\ 04623 |* *| 04624 |* Description: *| 04625 |* Looks for real division and replaces the div_opr with *| 04626 |* Real_Div_To_Int_Opr if on_off_flags.round_integer_divide is TRUE. *| 04627 |* This routine is used when the real division is changed to integer *| 04628 |* later (ie. in an assignment). *| 04629 |* *| 04630 |* Input parameters: *| 04631 |* opnd - top of tree. *| 04632 |* *| 04633 |* Output parameters: *| 04634 |* opnd - the modified tree. *| 04635 |* *| 04636 |* Returns: *| 04637 |* NOTHING *| 04638 |* *| 04639 \******************************************************************************/ 04640 04641 void look_for_real_div(opnd_type *opnd) 04642 04643 { 04644 int list_idx; 04645 opnd_type lopnd; 04646 04647 TRACE (Func_Entry, "look_for_real_div", NULL); 04648 04649 switch (OPND_FLD((*opnd))) { 04650 case IR_Tbl_Idx: 04651 04652 if (IR_OPR(OPND_IDX((*opnd))) == Div_Opr && 04653 TYP_TYPE(IR_TYPE_IDX(OPND_IDX((*opnd)))) == Real) { 04654 04655 if (on_off_flags.round_integer_divide) { 04656 IR_OPR(OPND_IDX((*opnd))) = Real_Div_To_Int_Opr; 04657 } 04658 else { 04659 PRINTMSG(IR_LINE_NUM(OPND_IDX((*opnd))), 938, Caution, 04660 IR_COL_NUM(OPND_IDX((*opnd)))); 04661 } 04662 } 04663 04664 COPY_OPND(lopnd, IR_OPND_L(OPND_IDX((*opnd)))); 04665 look_for_real_div(&lopnd); 04666 COPY_OPND(IR_OPND_L(OPND_IDX((*opnd))), lopnd); 04667 04668 COPY_OPND(lopnd, IR_OPND_R(OPND_IDX((*opnd)))); 04669 look_for_real_div(&lopnd); 04670 COPY_OPND(IR_OPND_R(OPND_IDX((*opnd))), lopnd); 04671 04672 break; 04673 04674 case IL_Tbl_Idx: 04675 04676 list_idx = OPND_IDX((*opnd)); 04677 04678 while (list_idx) { 04679 COPY_OPND(lopnd, IL_OPND(list_idx)); 04680 look_for_real_div(&lopnd); 04681 COPY_OPND(IL_OPND(list_idx), lopnd); 04682 list_idx = IL_NEXT_LIST_IDX(list_idx); 04683 } 04684 break; 04685 } 04686 04687 TRACE (Func_Exit, "look_for_real_div", NULL); 04688 04689 return; 04690 04691 } /* look_for_real_div */ 04692 04693 /******************************************************************************\ 04694 |* *| 04695 |* Description: *| 04696 |* Creates a logical array tmp thats necessary for zero length character *| 04697 |* logical operations. (.eq. ....) We must fold these expressions. *| 04698 |* *| 04699 |* Input parameters: *| 04700 |* top_opnd - the logical constant to put in array. (scalar) *| 04701 |* *| 04702 |* Output parameters: *| 04703 |* top_opnd - the array ref result. *| 04704 |* *| 04705 |* Returns: *| 04706 |* NOTHING *| 04707 |* *| 04708 \******************************************************************************/ 04709 04710 static void make_logical_array_tmp(opnd_type *top_opnd, 04711 expr_arg_type *exp_desc) 04712 04713 { 04714 int col; 04715 boolean constant_shape = TRUE; 04716 int i; 04717 opnd_type l_opnd; 04718 int line; 04719 expr_arg_type loc_exp_desc; 04720 boolean ok; 04721 opnd_type r_opnd; 04722 boolean save_check_type_conversion; 04723 int save_target_array_idx; 04724 opnd_type save_init_target_opnd; 04725 int save_target_type_idx; 04726 int unused; 04727 04728 TRACE (Func_Entry, "make_logical_array_tmp", NULL); 04729 04730 find_opnd_line_and_column(top_opnd, &line, &col); 04731 04732 for (i = 0; i < exp_desc->rank; i++) { 04733 04734 if (! SHAPE_FOLDABLE(exp_desc->shape[i])) { 04735 constant_shape = FALSE; 04736 break; 04737 } 04738 } 04739 04740 if (constant_shape) { 04741 save_check_type_conversion = check_type_conversion; 04742 save_target_array_idx = target_array_idx; 04743 save_target_type_idx = target_type_idx; 04744 COPY_OPND(save_init_target_opnd, init_target_opnd); 04745 04746 target_array_idx = create_bd_ntry_for_const(exp_desc, line, col); 04747 04748 check_type_conversion = TRUE; 04749 target_type_idx = exp_desc->type_idx; 04750 init_target_opnd = null_opnd; 04751 04752 loc_exp_desc.type = exp_desc->type; 04753 loc_exp_desc.linear_type = exp_desc->linear_type; 04754 loc_exp_desc.type_idx = exp_desc->type_idx; 04755 04756 ok = fold_aggragate_expression(top_opnd, 04757 &loc_exp_desc, 04758 FALSE); 04759 04760 check_type_conversion = save_check_type_conversion; 04761 COPY_OPND(init_target_opnd, save_init_target_opnd); 04762 target_type_idx = save_target_type_idx; 04763 target_array_idx = save_target_array_idx; 04764 04765 exp_desc->tmp_reference = TRUE; 04766 exp_desc->foldable = TRUE; 04767 } 04768 else { 04769 04770 COPY_OPND(r_opnd, (*top_opnd)); 04771 unused = create_tmp_asg(&r_opnd, 04772 exp_desc, 04773 &l_opnd, 04774 Intent_In, 04775 FALSE, 04776 FALSE); 04777 COPY_OPND((*top_opnd), l_opnd); 04778 } 04779 04780 TRACE (Func_Exit, "make_logical_array_tmp", NULL); 04781 04782 return; 04783 04784 } /* make_logical_array_tmp */ 04785 04786 /******************************************************************************\ 04787 |* *| 04788 |* Description: *| 04789 |* In strange variable function result size calculation, a character *| 04790 |* substring reference may involve nested substrings. This routine *| 04791 |* folds them into one substring. It is not intended for any other *| 04792 |* situation. *| 04793 |* *| 04794 |* Input parameters: *| 04795 |* ir_idx - IR_Tbl_Idx to the upper Substring_Opr *| 04796 |* *| 04797 |* Output parameters: *| 04798 |* NONE *| 04799 |* *| 04800 |* Returns: *| 04801 |* NOTHING *| 04802 |* *| 04803 \******************************************************************************/ 04804 04805 static void fold_nested_substrings(int ir_idx) 04806 04807 { 04808 int col; 04809 opnd_type end_opnd; 04810 expr_arg_type exp_desc; 04811 int line; 04812 int list_idx; 04813 int minus_idx; 04814 boolean ok; 04815 opnd_type opnd; 04816 int plus_idx; 04817 expr_mode_type save_expr_mode; 04818 cif_usage_code_type save_xref_state; 04819 opnd_type start_opnd; 04820 04821 04822 TRACE (Func_Entry, "fold_nested_substrings", NULL); 04823 04824 if (IR_OPR(IR_IDX_L(ir_idx)) == Whole_Substring_Opr) { 04825 /* just get rid of the substring opr */ 04826 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx))); 04827 goto EXIT; 04828 } 04829 04830 list_idx = IR_IDX_R(IR_IDX_L(ir_idx)); 04831 COPY_OPND(start_opnd, IL_OPND(list_idx)); 04832 04833 list_idx = IL_NEXT_LIST_IDX(list_idx); 04834 04835 COPY_OPND(end_opnd, IL_OPND(list_idx)); /*BRIANJ - end_opnd is not used */ 04836 04837 /* do the start expression */ 04838 04839 list_idx = IR_IDX_R(ir_idx); 04840 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), &line, &col); 04841 04842 NTR_IR_TBL(plus_idx); 04843 IR_OPR(plus_idx) = Plus_Opr; 04844 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 04845 IR_LINE_NUM(plus_idx) = line; 04846 IR_COL_NUM(plus_idx) = col; 04847 04848 COPY_OPND(IR_OPND_L(plus_idx), start_opnd); 04849 COPY_OPND(IR_OPND_R(plus_idx), IL_OPND(list_idx)); 04850 04851 NTR_IR_TBL(minus_idx); 04852 IR_OPR(minus_idx) = Minus_Opr; 04853 IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE; 04854 IR_LINE_NUM(minus_idx) = line; 04855 IR_COL_NUM(minus_idx) = col; 04856 04857 IR_FLD_L(minus_idx) = IR_Tbl_Idx; 04858 IR_IDX_L(minus_idx) = plus_idx; 04859 IR_FLD_R(minus_idx) = CN_Tbl_Idx; 04860 IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX; 04861 IR_LINE_NUM_R(minus_idx) = line; 04862 IR_COL_NUM_R(minus_idx) = col; 04863 04864 OPND_FLD(opnd) = IR_Tbl_Idx; 04865 OPND_IDX(opnd) = minus_idx; 04866 04867 /* fold */ 04868 save_xref_state = xref_state; 04869 xref_state = CIF_No_Usage_Rec; 04870 save_expr_mode = expr_mode; 04871 expr_mode = Regular_Expr; 04872 exp_desc.rank = 0; 04873 ok = expr_semantics(&opnd, &exp_desc); 04874 xref_state = save_xref_state; 04875 expr_mode = save_expr_mode; 04876 04877 04878 COPY_OPND(IL_OPND(list_idx), opnd); 04879 04880 04881 /* now do the end expression */ 04882 04883 list_idx = IL_NEXT_LIST_IDX(list_idx); 04884 04885 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), &line, &col); 04886 04887 NTR_IR_TBL(plus_idx); 04888 IR_OPR(plus_idx) = Plus_Opr; 04889 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 04890 IR_LINE_NUM(plus_idx) = line; 04891 IR_COL_NUM(plus_idx) = col; 04892 04893 COPY_OPND(IR_OPND_L(plus_idx), start_opnd); 04894 COPY_OPND(IR_OPND_R(plus_idx), IL_OPND(list_idx)); 04895 04896 NTR_IR_TBL(minus_idx); 04897 IR_OPR(minus_idx) = Minus_Opr; 04898 IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE; 04899 IR_LINE_NUM(minus_idx) = line; 04900 IR_COL_NUM(minus_idx) = col; 04901 04902 IR_FLD_L(minus_idx) = IR_Tbl_Idx; 04903 IR_IDX_L(minus_idx) = plus_idx; 04904 IR_FLD_R(minus_idx) = CN_Tbl_Idx; 04905 IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX; 04906 IR_LINE_NUM_R(minus_idx) = line; 04907 IR_COL_NUM_R(minus_idx) = col; 04908 04909 OPND_FLD(opnd) = IR_Tbl_Idx; 04910 OPND_IDX(opnd) = minus_idx; 04911 04912 /* fold */ 04913 save_xref_state = xref_state; 04914 xref_state = CIF_No_Usage_Rec; 04915 save_expr_mode = expr_mode; 04916 expr_mode = Regular_Expr; 04917 exp_desc.rank = 0; 04918 ok = expr_semantics(&opnd, &exp_desc); 04919 xref_state = save_xref_state; 04920 expr_mode = save_expr_mode; 04921 04922 COPY_OPND(IL_OPND(list_idx), opnd); 04923 04924 /* the length remains unchanged */ 04925 04926 /* now get rid of lower substring */ 04927 04928 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx))); 04929 04930 EXIT: 04931 04932 TRACE (Func_Exit, "fold_nested_substrings", NULL); 04933 04934 return; 04935 04936 } /* fold_nested_substrings */ 04937 04938 /******************************************************************************\ 04939 |* *| 04940 |* Description: *| 04941 |* semantic handler for the Uplus_Opr and Uminus_Opr. *| 04942 |* *| 04943 |* Input parameters: *| 04944 |* NONE *| 04945 |* *| 04946 |* Output parameters: *| 04947 |* NONE *| 04948 |* *| 04949 |* Returns: *| 04950 |* NOTHING *| 04951 |* *| 04952 \******************************************************************************/ 04953 04954 static boolean uplus_opr_handler(opnd_type *result_opnd, 04955 expr_arg_type *exp_desc) 04956 04957 { 04958 int col; 04959 expr_arg_type exp_desc_l; 04960 expr_arg_type exp_desc_r; 04961 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 04962 int ir_idx; 04963 int line; 04964 boolean ok = TRUE; 04965 opnd_type opnd; 04966 int opnd_col; 04967 int opnd_line; 04968 boolean save_in_call_list; 04969 int type_idx; 04970 04971 04972 TRACE (Func_Entry, "uplus_opr_handler" , NULL); 04973 04974 ir_idx = OPND_IDX((*result_opnd)); 04975 line = IR_LINE_NUM(ir_idx); 04976 col = IR_COL_NUM(ir_idx); 04977 save_in_call_list = in_call_list; 04978 in_call_list = FALSE; 04979 04980 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 04981 exp_desc_l.rank = 0; 04982 ok = expr_sem(&opnd, &exp_desc_l); 04983 COPY_OPND(IR_OPND_L(ir_idx), opnd); 04984 04985 if (!ok) { 04986 goto EXIT; 04987 } 04988 04989 exp_desc->has_constructor = exp_desc_l.has_constructor; 04990 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 04991 04992 exp_desc->linear_type = UN_PLUS_TYPE(exp_desc_l.linear_type); 04993 04994 if (exp_desc->linear_type != Err_Res) { 04995 04996 if (UN_PLUS_EXTN(exp_desc_l.linear_type)) { 04997 /* check for defined operator */ 04998 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 04999 FALSE, 05000 &ok, 05001 &exp_desc_l, &exp_desc_r)) { 05002 05003 (*exp_desc) = exp_desc_l; 05004 05005 goto EXIT; 05006 } 05007 else if (exp_desc_l.type == Character || 05008 exp_desc_l.linear_type == Short_Typeless_Const) { 05009 find_opnd_line_and_column((opnd_type *) 05010 &IR_OPND_L(ir_idx), 05011 &opnd_line, 05012 &opnd_col); 05013 if (exp_desc_l.type == Character) { 05014 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 05015 } 05016 05017 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 05018 exp_desc->linear_type, 05019 opnd_line, 05020 opnd_col); 05021 05022 exp_desc_l.type_idx = exp_desc->linear_type; 05023 exp_desc_l.type = TYP_TYPE(exp_desc->linear_type); 05024 exp_desc_l.linear_type = exp_desc->linear_type; 05025 exp_desc->linear_type = UN_PLUS_TYPE(exp_desc_l.linear_type); 05026 } 05027 05028 } 05029 05030 exp_desc->type_idx = exp_desc->linear_type; 05031 exp_desc->type = TYP_TYPE(exp_desc->linear_type); 05032 exp_desc->rank = exp_desc_l.rank; 05033 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 05034 exp_desc->constant = exp_desc_l.constant; 05035 exp_desc->foldable = exp_desc_l.foldable; 05036 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 05037 05038 if (exp_desc->linear_type == Integer_8) { 05039 /* check whether it should be 'default' typed */ 05040 05041 if (exp_desc_l.linear_type == Integer_8 && 05042 TYP_DESC(exp_desc_l.type_idx) != Default_Typed) { 05043 exp_desc->type_idx = exp_desc_l.type_idx; 05044 } 05045 } 05046 05047 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape,exp_desc_l.rank); 05048 05049 if (IR_OPR(ir_idx) == Uplus_Opr) { 05050 COPY_OPND((*result_opnd), IR_OPND_L(ir_idx)); 05051 } 05052 else if (opt_flags.ieeeconform && 05053 ! comp_gen_expr && 05054 (exp_desc_l.type == Real || 05055 exp_desc_l.type == Complex)) { 05056 05057 /* don't fold real arithmatic under ieeeconform */ 05058 05059 exp_desc->foldable = FALSE; 05060 exp_desc->will_fold_later = FALSE; 05061 } 05062 else if (exp_desc_l.rank == 0 && 05063 exp_desc_l.foldable && 05064 IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 05065 05066 type_idx = exp_desc->type_idx; 05067 05068 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 05069 exp_desc_l.type_idx, 05070 NULL, 05071 NULL_IDX, 05072 folded_const, 05073 &type_idx, 05074 line, 05075 col, 05076 1, 05077 IR_OPR(ir_idx))) { 05078 05079 exp_desc->type_idx = type_idx; 05080 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05081 05082 if (CN_BOZ_CONSTANT(IR_IDX_L(ir_idx))) { 05083 OPND_IDX((*result_opnd)) = 05084 ntr_boz_const_tbl(type_idx, folded_const); 05085 } 05086 else { 05087 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 05088 FALSE, 05089 folded_const); 05090 } 05091 05092 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 05093 OPND_LINE_NUM((*result_opnd)) = line; 05094 OPND_COL_NUM((*result_opnd)) = col; 05095 } 05096 else { 05097 ok = FALSE; 05098 } 05099 } 05100 } 05101 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 05102 (exp_desc->linear_type == Err_Res), 05103 &ok, 05104 &exp_desc_l, &exp_desc_r)) { 05105 05106 (*exp_desc) = exp_desc_l; 05107 05108 goto EXIT; 05109 } 05110 else { 05111 ok = FALSE; 05112 } 05113 05114 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 05115 IR_RANK(ir_idx) = exp_desc->rank; 05116 05117 if (IR_RANK(ir_idx)) { 05118 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 05119 } 05120 05121 EXIT: 05122 05123 TRACE (Func_Exit, "uplus_opr_handler", NULL); 05124 05125 return(ok); 05126 05127 } /* uplus_opr_handler */ 05128 05129 /******************************************************************************\ 05130 |* *| 05131 |* Description: *| 05132 |* semantic handler for the Power_Opr. *| 05133 |* *| 05134 |* Input parameters: *| 05135 |* NONE *| 05136 |* *| 05137 |* Output parameters: *| 05138 |* NONE *| 05139 |* *| 05140 |* Returns: *| 05141 |* NOTHING *| 05142 |* *| 05143 \******************************************************************************/ 05144 05145 static boolean power_opr_handler(opnd_type *result_opnd, 05146 expr_arg_type *exp_desc) 05147 05148 { 05149 int col; 05150 expr_arg_type exp_desc_l; 05151 expr_arg_type exp_desc_r; 05152 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 05153 int ir_idx; 05154 int line; 05155 boolean ok = TRUE; 05156 opnd_type opnd; 05157 int opnd_col; 05158 int opnd_line; 05159 boolean save_in_call_list; 05160 int type_idx; 05161 05162 05163 TRACE (Func_Entry, "power_opr_handler" , NULL); 05164 05165 ir_idx = OPND_IDX((*result_opnd)); 05166 line = IR_LINE_NUM(ir_idx); 05167 col = IR_COL_NUM(ir_idx); 05168 save_in_call_list = in_call_list; 05169 in_call_list = FALSE; 05170 05171 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 05172 exp_desc_l.rank = 0; 05173 ok = expr_sem(&opnd, &exp_desc_l); 05174 COPY_OPND(IR_OPND_L(ir_idx), opnd); 05175 05176 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 05177 exp_desc_r.rank = 0; 05178 ok &= expr_sem(&opnd, &exp_desc_r); 05179 COPY_OPND(IR_OPND_R(ir_idx), opnd); 05180 05181 if (!ok) { 05182 goto EXIT; 05183 } 05184 05185 exp_desc->has_constructor = exp_desc_l.has_constructor || 05186 exp_desc_r.has_constructor; 05187 05188 exp_desc->linear_type = POWER_TYPE(exp_desc_l.linear_type, 05189 exp_desc_r.linear_type); 05190 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 05191 05192 if (exp_desc->linear_type != Err_Res && 05193 (exp_desc_l.rank == exp_desc_r.rank || 05194 exp_desc_l.rank * exp_desc_r.rank == 0)) { 05195 05196 if (POWER_EXTN(exp_desc_l.linear_type, 05197 exp_desc_r.linear_type)) { 05198 /* check for defined operator */ 05199 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 05200 FALSE, 05201 &ok, 05202 &exp_desc_l, &exp_desc_r)) { 05203 05204 (*exp_desc) = exp_desc_l; 05205 05206 goto EXIT; 05207 } 05208 else { 05209 if (exp_desc_l.type == Character || 05210 exp_desc_l.linear_type == Short_Typeless_Const) { 05211 05212 find_opnd_line_and_column((opnd_type *) 05213 &IR_OPND_L(ir_idx), 05214 &opnd_line, 05215 &opnd_col); 05216 05217 if (exp_desc_l.type == Character) { 05218 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 05219 } 05220 05221 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 05222 exp_desc->linear_type, 05223 opnd_line, 05224 opnd_col); 05225 05226 exp_desc_l.type_idx = exp_desc->linear_type; 05227 exp_desc_l.type = TYP_TYPE(exp_desc->linear_type); 05228 exp_desc_l.linear_type = exp_desc->linear_type; 05229 } 05230 05231 if (exp_desc_r.type == Character || 05232 exp_desc_r.linear_type == Short_Typeless_Const) { 05233 05234 find_opnd_line_and_column((opnd_type *) 05235 &IR_OPND_R(ir_idx), 05236 &opnd_line, 05237 &opnd_col); 05238 05239 if (exp_desc_r.type == Character) { 05240 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 05241 } 05242 05243 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 05244 exp_desc->linear_type, 05245 opnd_line, 05246 opnd_col); 05247 05248 exp_desc_r.type_idx = exp_desc->linear_type; 05249 exp_desc_r.type = TYP_TYPE(exp_desc->linear_type); 05250 exp_desc_r.linear_type = exp_desc->linear_type; 05251 } 05252 05253 /* reset the linear type to reflect any changes above */ 05254 exp_desc->linear_type = POWER_TYPE(exp_desc_l.linear_type, 05255 exp_desc_r.linear_type); 05256 05257 } 05258 } 05259 05260 exp_desc->type_idx = exp_desc->linear_type; 05261 exp_desc->type = TYP_TYPE(exp_desc->linear_type); 05262 05263 if (exp_desc->linear_type == Integer_8) { 05264 /* check whether it should be 'default' typed */ 05265 05266 if (exp_desc_l.linear_type == Integer_8 && 05267 TYP_DESC(exp_desc_l.type_idx) != Default_Typed) { 05268 exp_desc->type_idx = exp_desc_l.type_idx; 05269 } 05270 else if (exp_desc_r.linear_type == Integer_8 && 05271 TYP_DESC(exp_desc_r.type_idx) != Default_Typed) { 05272 exp_desc->type_idx = exp_desc_r.type_idx; 05273 } 05274 } 05275 05276 /* can't have negative real raised to real power */ 05277 05278 if (exp_desc_l.foldable && 05279 exp_desc_l.type == Real && 05280 exp_desc_r.type == Real && 05281 IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 05282 05283 if (fold_relationals(IR_IDX_L(ir_idx), 05284 CN_INTEGER_ZERO_IDX, 05285 Lt_Opr)) { 05286 05287 PRINTMSG(line, 538, Error, col); 05288 ok = FALSE; 05289 } 05290 } 05291 05292 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 05293 exp_desc, line, col)) { 05294 ok = FALSE; 05295 } 05296 05297 exp_desc->constant = exp_desc_l.constant && 05298 exp_desc_r.constant; 05299 exp_desc->foldable = exp_desc_l.foldable && 05300 exp_desc_r.foldable; 05301 05302 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 05303 exp_desc_r.will_fold_later) | 05304 (exp_desc_l.will_fold_later & 05305 exp_desc_r.foldable) | 05306 (exp_desc_l.foldable & 05307 exp_desc_r.will_fold_later); 05308 05309 05310 if (opt_flags.ieeeconform && 05311 ! comp_gen_expr && 05312 (exp_desc_l.type == Real || 05313 exp_desc_l.type == Complex || 05314 exp_desc_r.type == Real || 05315 exp_desc_r.type == Complex)) { 05316 05317 /* don't fold real arithmatic under ieeeconform */ 05318 05319 exp_desc->foldable = FALSE; 05320 exp_desc->will_fold_later = FALSE; 05321 } 05322 else if (exp_desc->rank != 0) { 05323 /* don't do any folding yet */ 05324 } 05325 else if (exp_desc->foldable && 05326 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 05327 IR_FLD_R(ir_idx) == CN_Tbl_Idx && 05328 ok) { 05329 05330 if (expr_mode == Initialization_Expr && 05331 exp_desc_r.type != Integer) { 05332 05333 /* must have integer exponent for init expr */ 05334 05335 PRINTMSG(IR_LINE_NUM_R(ir_idx), 206, Error, 05336 IR_COL_NUM_R(ir_idx)); 05337 ok = FALSE; 05338 } 05339 05340 05341 type_idx = exp_desc->type_idx; 05342 05343 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 05344 exp_desc_l.type_idx, 05345 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 05346 exp_desc_r.type_idx, 05347 folded_const, 05348 &type_idx, 05349 line, 05350 col, 05351 2, IR_OPR(ir_idx))) { 05352 05353 exp_desc->type_idx = type_idx; 05354 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05355 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 05356 FALSE, 05357 folded_const); 05358 05359 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 05360 OPND_LINE_NUM((*result_opnd)) = line; 05361 OPND_COL_NUM((*result_opnd)) = col; 05362 } 05363 else { 05364 ok = FALSE; 05365 } 05366 } 05367 } 05368 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 05369 (exp_desc->linear_type == Err_Res), 05370 &ok, 05371 &exp_desc_l, &exp_desc_r)) { 05372 05373 (*exp_desc) = exp_desc_l; 05374 05375 goto EXIT; 05376 } 05377 else { 05378 ok = FALSE; 05379 } 05380 05381 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 05382 IR_OPR(OPND_IDX((*result_opnd))) == Power_Opr) { 05383 05384 /* exponentiation must be pulled off io lists */ 05385 io_item_must_flatten = TRUE; 05386 05387 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 05388 IR_RANK(ir_idx) = exp_desc->rank; 05389 05390 if (IR_RANK(ir_idx)) { 05391 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 05392 } 05393 } 05394 05395 EXIT: 05396 05397 TRACE (Func_Exit, "power_opr_handler", NULL); 05398 05399 return(ok); 05400 05401 } /* power_opr_handler */ 05402 05403 /******************************************************************************\ 05404 |* *| 05405 |* Description: *| 05406 |* semantic handler for the Mult_Opr and Div_Opr. *| 05407 |* *| 05408 |* Input parameters: *| 05409 |* NONE *| 05410 |* *| 05411 |* Output parameters: *| 05412 |* NONE *| 05413 |* *| 05414 |* Returns: *| 05415 |* NOTHING *| 05416 |* *| 05417 \******************************************************************************/ 05418 05419 static boolean mult_opr_handler(opnd_type *result_opnd, 05420 expr_arg_type *exp_desc) 05421 05422 { 05423 int col; 05424 expr_arg_type exp_desc_l; 05425 expr_arg_type exp_desc_r; 05426 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 05427 int ir_idx; 05428 int line; 05429 boolean ok = TRUE; 05430 opnd_type opnd; 05431 int opnd_col; 05432 int opnd_line; 05433 boolean save_in_call_list; 05434 int type_idx; 05435 05436 05437 TRACE (Func_Entry, "mult_opr_handler" , NULL); 05438 05439 ir_idx = OPND_IDX((*result_opnd)); 05440 line = IR_LINE_NUM(ir_idx); 05441 col = IR_COL_NUM(ir_idx); 05442 save_in_call_list = in_call_list; 05443 in_call_list = FALSE; 05444 05445 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 05446 exp_desc_l.rank = 0; 05447 ok = expr_sem(&opnd, &exp_desc_l); 05448 COPY_OPND(IR_OPND_L(ir_idx), opnd); 05449 05450 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 05451 exp_desc_r.rank = 0; 05452 ok &= expr_sem(&opnd, &exp_desc_r); 05453 COPY_OPND(IR_OPND_R(ir_idx), opnd); 05454 05455 if (!ok) { 05456 goto EXIT; 05457 } 05458 05459 exp_desc->has_constructor = exp_desc_l.has_constructor || 05460 exp_desc_r.has_constructor; 05461 05462 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 05463 05464 exp_desc->linear_type = MULT_DIV_TYPE(exp_desc_l.linear_type, 05465 exp_desc_r.linear_type); 05466 05467 if (exp_desc->linear_type != Err_Res && 05468 (exp_desc_l.rank == exp_desc_r.rank || 05469 exp_desc_l.rank * exp_desc_r.rank == 0)) { 05470 05471 if (MULT_DIV_EXTN(exp_desc_l.linear_type, 05472 exp_desc_r.linear_type)) { 05473 /* check for defined operator */ 05474 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 05475 FALSE, 05476 &ok, 05477 &exp_desc_l, &exp_desc_r)) { 05478 05479 (*exp_desc) = exp_desc_l; 05480 05481 goto EXIT; 05482 } 05483 else { /* aggragate constant problem here BHJ */ 05484 05485 if (exp_desc_l.type == Character || 05486 exp_desc_l.linear_type == Short_Typeless_Const) { 05487 05488 find_opnd_line_and_column((opnd_type *) 05489 &IR_OPND_L(ir_idx), 05490 &opnd_line, 05491 &opnd_col); 05492 05493 if (exp_desc_l.type == Character) { 05494 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 05495 } 05496 05497 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 05498 exp_desc->linear_type, 05499 opnd_line, 05500 opnd_col); 05501 05502 exp_desc_l.type_idx = exp_desc->linear_type; 05503 exp_desc_l.type = TYP_TYPE(exp_desc->linear_type); 05504 exp_desc_l.linear_type = exp_desc->linear_type; 05505 } 05506 05507 if (exp_desc_r.type == Character || 05508 exp_desc_r.linear_type == Short_Typeless_Const) { 05509 05510 find_opnd_line_and_column((opnd_type *) 05511 &IR_OPND_R(ir_idx), 05512 &opnd_line, 05513 &opnd_col); 05514 05515 if (exp_desc_r.type == Character) { 05516 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 05517 } 05518 05519 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 05520 exp_desc->linear_type, 05521 opnd_line, 05522 opnd_col); 05523 05524 exp_desc_r.type_idx = exp_desc->linear_type; 05525 exp_desc_r.type = TYP_TYPE(exp_desc->linear_type); 05526 exp_desc_r.linear_type = exp_desc->linear_type; 05527 } 05528 05529 /* reset the linear type to reflect any changes above */ 05530 exp_desc->linear_type = MULT_DIV_TYPE(exp_desc_l.linear_type, 05531 exp_desc_r.linear_type); 05532 } 05533 } 05534 05535 exp_desc->type_idx = exp_desc->linear_type; 05536 exp_desc->type = TYP_TYPE(exp_desc->linear_type); 05537 05538 if (exp_desc->linear_type == Integer_8) { 05539 /* check whether it should be 'default' typed */ 05540 05541 if (exp_desc_l.linear_type == Integer_8 && 05542 TYP_DESC(exp_desc_l.type_idx) != Default_Typed) { 05543 exp_desc->type_idx = exp_desc_l.type_idx; 05544 } 05545 else if (exp_desc_r.linear_type == Integer_8 && 05546 TYP_DESC(exp_desc_r.type_idx) != Default_Typed) { 05547 exp_desc->type_idx = exp_desc_r.type_idx; 05548 } 05549 } 05550 05551 05552 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 05553 exp_desc, line, col)) { 05554 ok = FALSE; 05555 } 05556 05557 exp_desc->constant = exp_desc_l.constant && 05558 exp_desc_r.constant; 05559 exp_desc->foldable = exp_desc_l.foldable && 05560 exp_desc_r.foldable; 05561 05562 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 05563 exp_desc_r.will_fold_later) | 05564 (exp_desc_l.will_fold_later & 05565 exp_desc_r.foldable) | 05566 (exp_desc_l.foldable & 05567 exp_desc_r.will_fold_later); 05568 05569 05570 if ((! target_ieee || 05571 exp_desc->type == Integer) && 05572 exp_desc_r.rank == 0 && 05573 IR_OPR(ir_idx) == Div_Opr && 05574 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 05575 05576 if (fold_relationals(IR_IDX_R(ir_idx), 05577 CN_INTEGER_ZERO_IDX, 05578 Eq_Opr)) { 05579 05580 /* division by zero */ 05581 05582 if (comp_gen_expr) { 05583 PRINTMSG(IR_LINE_NUM_R(ir_idx), 721, Error, 05584 IR_COL_NUM_R(ir_idx)); 05585 ok = FALSE; 05586 } 05587 else { 05588 PRINTMSG(IR_LINE_NUM_R(ir_idx), 1649, Warning, 05589 IR_COL_NUM_R(ir_idx)); 05590 exp_desc->foldable = FALSE; 05591 exp_desc->will_fold_later = FALSE; 05592 } 05593 } 05594 } 05595 05596 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 05597 IR_OPR(OPND_IDX((*result_opnd))) == Div_Opr && 05598 exp_desc->type == Real && 05599 on_off_flags.round_integer_divide) { 05600 05601 IR_OPR(OPND_IDX((*result_opnd))) = Real_Div_To_Int_Opr; 05602 } 05603 05604 if (! ok) { 05605 /* intentionally blank */ 05606 } 05607 else if (opt_flags.ieeeconform && 05608 ! comp_gen_expr && 05609 (exp_desc_l.type == Real || 05610 exp_desc_l.type == Complex || 05611 exp_desc_r.type == Real || 05612 exp_desc_r.type == Complex)) { 05613 05614 /* don't fold real arithmatic under ieeeconform */ 05615 05616 exp_desc->foldable = FALSE; 05617 exp_desc->will_fold_later = FALSE; 05618 } 05619 else if (exp_desc->rank != 0) { 05620 /* don't do any folding yet */ 05621 } 05622 else if (exp_desc->foldable && 05623 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 05624 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 05625 05626 type_idx = exp_desc->type_idx; 05627 05628 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 05629 exp_desc_l.type_idx, 05630 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 05631 exp_desc_r.type_idx, 05632 folded_const, 05633 &type_idx, 05634 line, 05635 col, 05636 2, 05637 IR_OPR(ir_idx))) { 05638 05639 exp_desc->type_idx = type_idx; 05640 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05641 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 05642 FALSE, 05643 folded_const); 05644 05645 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 05646 OPND_LINE_NUM((*result_opnd)) = line; 05647 OPND_COL_NUM((*result_opnd)) = col; 05648 } 05649 else { 05650 ok = FALSE; 05651 } 05652 } 05653 else if (exp_desc_l.foldable && 05654 IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 05655 05656 if (exp_desc_l.type == Integer && 05657 exp_desc_l.type_idx == exp_desc_r.type_idx) { 05658 05659 if (compare_cn_and_value(IR_IDX_L(ir_idx), 0, Eq_Opr)) { 05660 /* fold 0 * i or 0 / i => 0 */ 05661 COPY_OPND((*result_opnd), IR_OPND_L(ir_idx)); 05662 exp_desc->constant = TRUE; 05663 exp_desc->foldable = TRUE; 05664 } 05665 else if (compare_cn_and_value(IR_IDX_L(ir_idx), 1, Eq_Opr) && 05666 IR_OPR(ir_idx) == Mult_Opr) { 05667 /* fold 1 * i => i */ 05668 COPY_OPND((*result_opnd), IR_OPND_R(ir_idx)); 05669 } 05670 } 05671 } 05672 else if (exp_desc_r.foldable && 05673 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 05674 05675 if (exp_desc_l.type == Integer && 05676 exp_desc_l.type_idx == exp_desc_r.type_idx) { 05677 05678 if (compare_cn_and_value(IR_IDX_R(ir_idx), 1, Eq_Opr)) { 05679 /* fold i * 1 or i / 1 => i */ 05680 COPY_OPND((*result_opnd), IR_OPND_L(ir_idx)); 05681 } 05682 else if (compare_cn_and_value(IR_IDX_R(ir_idx), 0, Eq_Opr) && 05683 IR_OPR(ir_idx) == Mult_Opr) { 05684 /* fold i * 0 => 0 */ 05685 COPY_OPND((*result_opnd), IR_OPND_R(ir_idx)); 05686 exp_desc->constant = TRUE; 05687 exp_desc->foldable = TRUE; 05688 } 05689 } 05690 } 05691 } 05692 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 05693 (exp_desc->linear_type == Err_Res), 05694 &ok, 05695 &exp_desc_l, &exp_desc_r)) { 05696 05697 (*exp_desc) = exp_desc_l; 05698 05699 goto EXIT; 05700 } 05701 else { 05702 ok = FALSE; 05703 } 05704 05705 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 05706 IR_RANK(ir_idx) = exp_desc->rank; 05707 05708 if (IR_RANK(ir_idx)) { 05709 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 05710 } 05711 05712 EXIT: 05713 05714 TRACE (Func_Exit, "mult_opr_handler", NULL); 05715 05716 return(ok); 05717 05718 } /* mult_opr_handler */ 05719 05720 /******************************************************************************\ 05721 |* *| 05722 |* Description: *| 05723 |* semantic handler for the Minus_Opr. *| 05724 |* *| 05725 |* Input parameters: *| 05726 |* NONE *| 05727 |* *| 05728 |* Output parameters: *| 05729 |* NONE *| 05730 |* *| 05731 |* Returns: *| 05732 |* NOTHING *| 05733 |* *| 05734 \******************************************************************************/ 05735 05736 static boolean minus_opr_handler(opnd_type *result_opnd, 05737 expr_arg_type *exp_desc) 05738 05739 { 05740 int col; 05741 expr_arg_type exp_desc_l; 05742 expr_arg_type exp_desc_r; 05743 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 05744 int ir_idx; 05745 int line; 05746 boolean ok = TRUE; 05747 opnd_type opnd; 05748 int opnd_col; 05749 int opnd_line; 05750 boolean save_in_call_list; 05751 int type_idx; 05752 05753 05754 TRACE (Func_Entry, "minus_opr_handler" , NULL); 05755 05756 ir_idx = OPND_IDX((*result_opnd)); 05757 line = IR_LINE_NUM(ir_idx); 05758 col = IR_COL_NUM(ir_idx); 05759 save_in_call_list = in_call_list; 05760 in_call_list = FALSE; 05761 05762 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 05763 exp_desc_l.rank = 0; 05764 ok = expr_sem(&opnd, &exp_desc_l); 05765 COPY_OPND(IR_OPND_L(ir_idx), opnd); 05766 05767 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 05768 exp_desc_r.rank = 0; 05769 ok &= expr_sem(&opnd, &exp_desc_r); 05770 COPY_OPND(IR_OPND_R(ir_idx), opnd); 05771 05772 if (!ok) { 05773 goto EXIT; 05774 } 05775 05776 exp_desc->has_constructor = exp_desc_l.has_constructor || 05777 exp_desc_r.has_constructor; 05778 05779 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 05780 05781 exp_desc->linear_type = BIN_SUB_TYPE(exp_desc_l.linear_type, 05782 exp_desc_r.linear_type); 05783 05784 if (exp_desc->linear_type != Err_Res && 05785 (exp_desc_l.rank == exp_desc_r.rank || 05786 exp_desc_l.rank * exp_desc_r.rank == 0)) { 05787 05788 if (BIN_SUB_EXTN(exp_desc_l.linear_type, 05789 exp_desc_r.linear_type)) { 05790 /* check for defined operator */ 05791 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 05792 FALSE, 05793 &ok, 05794 &exp_desc_l, &exp_desc_r)) { 05795 05796 (*exp_desc) = exp_desc_l; 05797 05798 goto EXIT; 05799 } 05800 else { 05801 if (exp_desc_l.type == Character || 05802 exp_desc_l.linear_type == Short_Typeless_Const) { 05803 05804 find_opnd_line_and_column((opnd_type *) 05805 &IR_OPND_L(ir_idx), 05806 &opnd_line, 05807 &opnd_col); 05808 05809 if (exp_desc_l.type == Character) { 05810 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 05811 } 05812 05813 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 05814 exp_desc->linear_type, 05815 opnd_line, 05816 opnd_col); 05817 05818 exp_desc_l.type_idx = exp_desc->linear_type; 05819 exp_desc_l.type = TYP_TYPE(exp_desc->linear_type); 05820 exp_desc_l.linear_type = exp_desc->linear_type; 05821 } 05822 05823 if (exp_desc_r.type == Character || 05824 exp_desc_r.linear_type == Short_Typeless_Const) { 05825 05826 find_opnd_line_and_column((opnd_type *) 05827 &IR_OPND_R(ir_idx), 05828 &opnd_line, 05829 &opnd_col); 05830 05831 if (exp_desc_r.type == Character) { 05832 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 05833 } 05834 05835 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 05836 exp_desc->linear_type, 05837 opnd_line, 05838 opnd_col); 05839 05840 exp_desc_r.type_idx = exp_desc->linear_type; 05841 exp_desc_r.type = TYP_TYPE(exp_desc->linear_type); 05842 exp_desc_r.linear_type = exp_desc->linear_type; 05843 } 05844 05845 /* reset the linear type to reflect any changes above */ 05846 exp_desc->linear_type = BIN_SUB_TYPE(exp_desc_l.linear_type, 05847 exp_desc_r.linear_type); 05848 } 05849 } 05850 05851 exp_desc->type_idx = exp_desc->linear_type; 05852 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 05853 05854 if (exp_desc->linear_type == Integer_8) { 05855 /* check whether it should be 'default' typed */ 05856 05857 if (exp_desc_l.linear_type == Integer_8 && 05858 TYP_DESC(exp_desc_l.type_idx) != Default_Typed) { 05859 exp_desc->type_idx = exp_desc_l.type_idx; 05860 } 05861 else if (exp_desc_r.linear_type == Integer_8 && 05862 TYP_DESC(exp_desc_r.type_idx) != Default_Typed) { 05863 exp_desc->type_idx = exp_desc_r.type_idx; 05864 } 05865 } 05866 05867 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 05868 exp_desc, line, col)) { 05869 ok = FALSE; 05870 } 05871 05872 exp_desc->constant = exp_desc_l.constant && 05873 exp_desc_r.constant; 05874 exp_desc->foldable = exp_desc_l.foldable && 05875 exp_desc_r.foldable; 05876 05877 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 05878 exp_desc_r.will_fold_later) | 05879 (exp_desc_l.will_fold_later & 05880 exp_desc_r.foldable) | 05881 (exp_desc_l.foldable & 05882 exp_desc_r.will_fold_later); 05883 05884 if (opt_flags.ieeeconform && 05885 ! comp_gen_expr && 05886 (exp_desc_l.type == Real || 05887 exp_desc_l.type == Complex || 05888 exp_desc_r.type == Real || 05889 exp_desc_r.type == Complex)) { 05890 05891 /* don't fold real arithmatic under ieeeconform */ 05892 05893 exp_desc->foldable = FALSE; 05894 exp_desc->will_fold_later = FALSE; 05895 } 05896 else if (exp_desc->rank != 0) { 05897 /* don't do any folding yet */ 05898 } 05899 else if (exp_desc->foldable && 05900 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 05901 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 05902 05903 type_idx = exp_desc->type_idx; 05904 05905 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 05906 exp_desc_l.type_idx, 05907 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 05908 exp_desc_r.type_idx, 05909 folded_const, 05910 &type_idx, 05911 line, 05912 col, 05913 2, 05914 IR_OPR(ir_idx))) { 05915 05916 exp_desc->type_idx = type_idx; 05917 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05918 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 05919 FALSE, 05920 folded_const); 05921 05922 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 05923 OPND_LINE_NUM((*result_opnd)) = line; 05924 OPND_COL_NUM((*result_opnd)) = col; 05925 } 05926 else { 05927 ok = FALSE; 05928 } 05929 } 05930 else if (exp_desc_r.foldable && 05931 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 05932 05933 if (exp_desc_l.type == Integer && 05934 exp_desc_l.type_idx == exp_desc_r.type_idx) { 05935 05936 if (compare_cn_and_value(IR_IDX_R(ir_idx), 0, Eq_Opr)) { 05937 /* fold i + 0 or i - 0 => i */ 05938 COPY_OPND((*result_opnd), IR_OPND_L(ir_idx)); 05939 } 05940 } 05941 } 05942 } 05943 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 05944 (exp_desc->linear_type == Err_Res), 05945 &ok, 05946 &exp_desc_l, &exp_desc_r)) { 05947 05948 (*exp_desc) = exp_desc_l; 05949 05950 goto EXIT; 05951 } 05952 else { 05953 ok = FALSE; 05954 } 05955 05956 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 05957 IR_RANK(ir_idx) = exp_desc->rank; 05958 05959 if (IR_RANK(ir_idx)) { 05960 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 05961 } 05962 05963 EXIT: 05964 05965 TRACE (Func_Exit, "minus_opr_handler", NULL); 05966 05967 return(ok); 05968 05969 } /* minus_opr_handler */ 05970 05971 /******************************************************************************\ 05972 |* *| 05973 |* Description: *| 05974 |* semantic handler for the Plus_Opr. *| 05975 |* *| 05976 |* Input parameters: *| 05977 |* NONE *| 05978 |* *| 05979 |* Output parameters: *| 05980 |* NONE *| 05981 |* *| 05982 |* Returns: *| 05983 |* NOTHING *| 05984 |* *| 05985 \******************************************************************************/ 05986 05987 static boolean plus_opr_handler(opnd_type *result_opnd, 05988 expr_arg_type *exp_desc) 05989 05990 { 05991 int col; 05992 expr_arg_type exp_desc_l; 05993 expr_arg_type exp_desc_r; 05994 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 05995 int ir_idx; 05996 int line; 05997 boolean ok = TRUE; 05998 opnd_type opnd; 05999 int opnd_col; 06000 int opnd_line; 06001 boolean save_in_call_list; 06002 int type_idx; 06003 06004 06005 TRACE (Func_Entry, "plus_opr_handler" , NULL); 06006 06007 ir_idx = OPND_IDX((*result_opnd)); 06008 line = IR_LINE_NUM(ir_idx); 06009 col = IR_COL_NUM(ir_idx); 06010 save_in_call_list = in_call_list; 06011 in_call_list = FALSE; 06012 06013 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 06014 exp_desc_l.rank = 0; 06015 ok = expr_sem(&opnd, &exp_desc_l); 06016 COPY_OPND(IR_OPND_L(ir_idx), opnd); 06017 06018 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 06019 exp_desc_r.rank = 0; 06020 ok &= expr_sem(&opnd, &exp_desc_r); 06021 COPY_OPND(IR_OPND_R(ir_idx), opnd); 06022 06023 if (!ok) { 06024 goto EXIT; 06025 } 06026 06027 exp_desc->has_constructor = exp_desc_l.has_constructor || 06028 exp_desc_r.has_constructor; 06029 06030 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 06031 06032 exp_desc->linear_type = BIN_ADD_TYPE(exp_desc_l.linear_type, 06033 exp_desc_r.linear_type); 06034 if (exp_desc->linear_type != Err_Res && 06035 (exp_desc_l.rank == exp_desc_r.rank || 06036 exp_desc_l.rank * exp_desc_r.rank == 0)) { 06037 06038 if (BIN_ADD_EXTN(exp_desc_l.linear_type, 06039 exp_desc_r.linear_type)) { 06040 /* check for defined operator */ 06041 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 06042 FALSE, 06043 &ok, 06044 &exp_desc_l, &exp_desc_r)) { 06045 06046 (*exp_desc) = exp_desc_l; 06047 06048 goto EXIT; 06049 } 06050 else { 06051 if (exp_desc_l.type == Character || 06052 exp_desc_l.linear_type == Short_Typeless_Const) { 06053 06054 find_opnd_line_and_column((opnd_type *) 06055 &IR_OPND_L(ir_idx), 06056 &opnd_line, 06057 &opnd_col); 06058 06059 if (exp_desc_l.type == Character) { 06060 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 06061 } 06062 06063 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 06064 exp_desc->linear_type, 06065 opnd_line, 06066 opnd_col); 06067 06068 exp_desc_l.type_idx = exp_desc->linear_type; 06069 exp_desc_l.type = TYP_TYPE(exp_desc->linear_type); 06070 exp_desc_l.linear_type = exp_desc->linear_type; 06071 } 06072 06073 if (exp_desc_r.type == Character || 06074 exp_desc_r.linear_type == Short_Typeless_Const) { 06075 06076 find_opnd_line_and_column((opnd_type *) 06077 &IR_OPND_R(ir_idx), 06078 &opnd_line, 06079 &opnd_col); 06080 06081 if (exp_desc_r.type == Character) { 06082 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 06083 } 06084 06085 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 06086 exp_desc->linear_type, 06087 opnd_line, 06088 opnd_col); 06089 06090 exp_desc_r.type_idx = exp_desc->linear_type; 06091 exp_desc_r.type = TYP_TYPE(exp_desc->linear_type); 06092 exp_desc_r.linear_type = exp_desc->linear_type; 06093 } 06094 06095 /* reset the linear type to reflect any changes above */ 06096 exp_desc->linear_type = BIN_ADD_TYPE(exp_desc_l.linear_type, 06097 exp_desc_r.linear_type); 06098 } 06099 } 06100 06101 exp_desc->type_idx = exp_desc->linear_type; 06102 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 06103 06104 if (exp_desc->linear_type == Integer_8) { 06105 /* check whether it should be 'default' typed */ 06106 06107 if (exp_desc_l.linear_type == Integer_8 && 06108 TYP_DESC(exp_desc_l.type_idx) != Default_Typed) { 06109 exp_desc->type_idx = exp_desc_l.type_idx; 06110 } 06111 else if (exp_desc_r.linear_type == Integer_8 && 06112 TYP_DESC(exp_desc_r.type_idx) != Default_Typed) { 06113 exp_desc->type_idx = exp_desc_r.type_idx; 06114 } 06115 } 06116 06117 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 06118 exp_desc, line, col)) { 06119 ok = FALSE; 06120 } 06121 06122 exp_desc->constant = exp_desc_l.constant && 06123 exp_desc_r.constant; 06124 exp_desc->foldable = exp_desc_l.foldable && 06125 exp_desc_r.foldable; 06126 06127 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 06128 exp_desc_r.will_fold_later) | 06129 (exp_desc_l.will_fold_later & 06130 exp_desc_r.foldable) | 06131 (exp_desc_l.foldable & 06132 exp_desc_r.will_fold_later); 06133 06134 if (opt_flags.ieeeconform && 06135 ! comp_gen_expr && 06136 (exp_desc_l.type == Real || 06137 exp_desc_l.type == Complex || 06138 exp_desc_r.type == Real || 06139 exp_desc_r.type == Complex)) { 06140 06141 /* don't fold real arithmatic under ieeeconform */ 06142 06143 exp_desc->foldable = FALSE; 06144 exp_desc->will_fold_later = FALSE; 06145 } 06146 else if (exp_desc->rank != 0) { 06147 /* don't do any folding yet */ 06148 } 06149 else if (exp_desc->foldable && 06150 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 06151 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 06152 06153 06154 type_idx = exp_desc->type_idx; 06155 06156 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 06157 exp_desc_l.type_idx, 06158 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 06159 exp_desc_r.type_idx, 06160 folded_const, 06161 &type_idx, 06162 line, 06163 col, 06164 2, 06165 IR_OPR(ir_idx))) { 06166 06167 exp_desc->type_idx = type_idx; 06168 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 06169 OPND_IDX((*result_opnd)) = ntr_const_tbl( 06170 exp_desc->type_idx, 06171 FALSE, 06172 folded_const); 06173 06174 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 06175 OPND_LINE_NUM((*result_opnd)) = line; 06176 OPND_COL_NUM((*result_opnd)) = col; 06177 } 06178 else { 06179 ok = FALSE; 06180 } 06181 } 06182 else if (exp_desc_l.foldable && 06183 IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 06184 06185 if (exp_desc_l.type == Integer && 06186 exp_desc_l.type_idx == exp_desc_r.type_idx) { 06187 06188 if (compare_cn_and_value(IR_IDX_L(ir_idx), 0, Eq_Opr)) { 06189 /* fold 0 + i => i */ 06190 COPY_OPND((*result_opnd), IR_OPND_R(ir_idx)); 06191 } 06192 } 06193 } 06194 else if (exp_desc_r.foldable && 06195 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 06196 06197 if (exp_desc_l.type == Integer && 06198 exp_desc_l.type_idx == exp_desc_r.type_idx) { 06199 06200 if (compare_cn_and_value(IR_IDX_R(ir_idx), 0, Eq_Opr)) { 06201 /* fold i + 0 or i - 0 => i */ 06202 COPY_OPND((*result_opnd), IR_OPND_L(ir_idx)); 06203 } 06204 } 06205 } 06206 } 06207 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 06208 (exp_desc->linear_type == Err_Res), 06209 &ok, 06210 &exp_desc_l, &exp_desc_r)) { 06211 06212 (*exp_desc) = exp_desc_l; 06213 06214 goto EXIT; 06215 } 06216 else { 06217 ok = FALSE; 06218 } 06219 06220 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 06221 IR_RANK(ir_idx) = exp_desc->rank; 06222 06223 if (IR_RANK(ir_idx)) { 06224 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 06225 } 06226 06227 EXIT: 06228 06229 TRACE (Func_Exit, "plus_opr_handler", NULL); 06230 06231 return(ok); 06232 06233 } /* plus_opr_handler */ 06234 06235 /******************************************************************************\ 06236 |* *| 06237 |* Description: *| 06238 |* semantic handler for the Concat_Opr. *| 06239 |* *| 06240 |* Input parameters: *| 06241 |* NONE *| 06242 |* *| 06243 |* Output parameters: *| 06244 |* NONE *| 06245 |* *| 06246 |* Returns: *| 06247 |* NOTHING *| 06248 |* *| 06249 \******************************************************************************/ 06250 06251 static boolean concat_opr_handler(opnd_type *result_opnd, 06252 expr_arg_type *exp_desc) 06253 06254 { 06255 char *char_ptr1; 06256 char *char_ptr2; 06257 int col; 06258 expr_arg_type exp_desc_l; 06259 expr_arg_type exp_desc_r; 06260 long i; 06261 int ir_idx; 06262 long_type length[MAX_WORDS_FOR_INTEGER]; 06263 int line; 06264 int list_idx; 06265 int k; 06266 boolean ok = TRUE; 06267 opnd_type opnd; 06268 int plus_idx; 06269 boolean save_in_call_list; 06270 int type_idx; 06271 06272 06273 TRACE (Func_Entry, "concat_opr_handler" , NULL); 06274 06275 ir_idx = OPND_IDX((*result_opnd)); 06276 line = IR_LINE_NUM(ir_idx); 06277 col = IR_COL_NUM(ir_idx); 06278 save_in_call_list = in_call_list; 06279 in_call_list = FALSE; 06280 06281 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 06282 exp_desc_l.rank = 0; 06283 ok = expr_sem(&opnd, &exp_desc_l); 06284 COPY_OPND(IR_OPND_L(ir_idx), opnd); 06285 06286 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 06287 exp_desc_r.rank = 0; 06288 ok &= expr_sem(&opnd, &exp_desc_r); 06289 COPY_OPND(IR_OPND_R(ir_idx), opnd); 06290 06291 exp_desc->has_constructor = exp_desc_l.has_constructor || 06292 exp_desc_r.has_constructor; 06293 06294 if (! ok) { 06295 goto EXIT; 06296 } 06297 06298 if (exp_desc_l.type == Character && 06299 exp_desc_r.type == Character && 06300 (exp_desc_r.rank == exp_desc_l.rank || 06301 exp_desc_r.rank * exp_desc_l.rank == 0)) { 06302 06303 exp_desc->type = Character; 06304 06305 /* aux_type is not calculated unless it's for a fold */ 06306 06307 exp_desc->type_idx = exp_desc_l.type_idx; 06308 06309 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 06310 exp_desc, line, col)) { 06311 ok = FALSE; 06312 } 06313 06314 exp_desc->constant = exp_desc_l.constant && 06315 exp_desc_r.constant; 06316 exp_desc->foldable = exp_desc_l.foldable && 06317 exp_desc_r.foldable; 06318 06319 exp_desc->has_symbolic = exp_desc_l.has_symbolic || 06320 exp_desc_r.has_symbolic; 06321 06322 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 06323 exp_desc_r.will_fold_later) | 06324 (exp_desc_l.will_fold_later & 06325 exp_desc_r.foldable) | 06326 (exp_desc_l.foldable & 06327 exp_desc_r.will_fold_later); 06328 06329 if (exp_desc->foldable && 06330 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 06331 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 06332 06333 /* fold the concat in line */ 06334 06335 type_idx = CG_INTEGER_DEFAULT_TYPE; 06336 06337 if (folder_driver((char *) &CN_CONST(TYP_IDX(exp_desc_r.type_idx)), 06338 CN_TYPE_IDX(TYP_IDX(exp_desc_r.type_idx)), 06339 (char *) &CN_CONST(TYP_IDX(exp_desc_l.type_idx)), 06340 CN_TYPE_IDX(TYP_IDX(exp_desc_l.type_idx)), 06341 length, 06342 &type_idx, 06343 line, 06344 col, 06345 2, 06346 Plus_Opr)) { 06347 } 06348 06349 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 06350 06351 TYP_TYPE(TYP_WORK_IDX) = Character; 06352 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 06353 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 06354 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 06355 TYP_IDX(TYP_WORK_IDX) = ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE, 06356 FALSE, 06357 length); 06358 exp_desc->type_idx = ntr_type_tbl(); 06359 exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx); 06360 exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx); 06361 OPND_LINE_NUM(exp_desc->char_len) = line; 06362 OPND_COL_NUM(exp_desc->char_len) = col; 06363 06364 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 06365 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 06366 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 06367 06368 /* Set up the new const table entry. Pass ntr_const_tbl */ 06369 /* a null pointer so the caller can move the constant. */ 06370 06371 OPND_IDX((*result_opnd))= ntr_const_tbl(exp_desc->type_idx, 06372 TRUE, 06373 NULL); 06374 06375 /* BRIANJ - String manipulation */ 06376 06377 /* copy the first string in */ 06378 06379 char_ptr1 = (char *)&CN_CONST(OPND_IDX((*result_opnd))); 06380 char_ptr2 = (char *)&CN_CONST(IR_IDX_L(ir_idx)); 06381 k = 0; 06382 06383 for (i=0; i < CN_INT_TO_C(TYP_IDX(exp_desc_l.type_idx)); i++){ 06384 char_ptr1[k] = char_ptr2[i]; 06385 k++; 06386 } 06387 06388 /* copy the second string in */ 06389 06390 char_ptr2 = (char *)&CN_CONST(IR_IDX_R(ir_idx)); 06391 06392 for (i=0; i < CN_INT_TO_C(TYP_IDX(exp_desc_r.type_idx)); i++){ 06393 char_ptr1[k] = char_ptr2[i]; 06394 k++; 06395 } 06396 06397 /* fill in the rest of a word with blanks */ 06398 06399 while (k % TARGET_CHARS_PER_WORD != 0) { 06400 char_ptr1[k] = ' '; 06401 k++; 06402 } 06403 } 06404 else { 06405 06406 io_item_must_flatten = TRUE; 06407 06408 NTR_IR_TBL(plus_idx); 06409 IR_OPR(plus_idx) = Plus_Opr; 06410 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 06411 IR_LINE_NUM(plus_idx) = line; 06412 IR_COL_NUM(plus_idx) = col; 06413 COPY_OPND(IR_OPND_L(plus_idx), exp_desc_l.char_len); 06414 COPY_OPND(IR_OPND_R(plus_idx), exp_desc_r.char_len); 06415 06416 exp_desc->char_len.fld = IR_Tbl_Idx; 06417 exp_desc->char_len.idx = plus_idx; 06418 06419 if (exp_desc_l.char_len.fld == CN_Tbl_Idx && 06420 exp_desc_r.char_len.fld == CN_Tbl_Idx) { 06421 06422 COPY_OPND(opnd, exp_desc->char_len); 06423 exp_desc_l.rank = 0; 06424 ok = expr_semantics(&opnd, &exp_desc_l); 06425 COPY_OPND(exp_desc->char_len, opnd); 06426 } 06427 06428 /* switch to n-ary concat */ 06429 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx && 06430 IR_OPR(IR_IDX_L(ir_idx)) == Concat_Opr) { 06431 06432 COPY_OPND(IR_OPND_L(ir_idx), 06433 IR_OPND_L(IR_IDX_L(ir_idx))); 06434 06435 list_idx = IR_IDX_L(ir_idx); 06436 while (IL_NEXT_LIST_IDX(list_idx)) { 06437 list_idx = IL_NEXT_LIST_IDX(list_idx); 06438 } 06439 06440 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06441 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06442 list_idx = IL_NEXT_LIST_IDX(list_idx); 06443 COPY_OPND(IL_OPND(list_idx), IR_OPND_R(ir_idx)); 06444 IR_LIST_CNT_L(ir_idx)++; 06445 IR_FLD_R(ir_idx) = NO_Tbl_Idx; 06446 IR_IDX_R(ir_idx) = NULL_IDX; 06447 } 06448 else { 06449 NTR_IR_LIST_TBL(list_idx); 06450 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(ir_idx)); 06451 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 06452 IR_IDX_L(ir_idx) = list_idx; 06453 IR_LIST_CNT_L(ir_idx) = 2; 06454 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06455 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06456 list_idx = IL_NEXT_LIST_IDX(list_idx); 06457 COPY_OPND(IL_OPND(list_idx), IR_OPND_R(ir_idx)); 06458 IR_FLD_R(ir_idx) = NO_Tbl_Idx; 06459 IR_IDX_R(ir_idx) = NULL_IDX; 06460 } 06461 } 06462 06463 if (exp_desc->foldable && 06464 compare_cn_and_value(TYP_IDX(exp_desc->type_idx), 06465 MAX_CHARS_IN_TYPELESS, 06466 Le_Opr)) { 06467 exp_desc->linear_type = Short_Char_Const; 06468 } 06469 else { 06470 /* assume one byte character for now */ 06471 exp_desc->linear_type = Character_1; 06472 } 06473 06474 type_tbl[TYP_WORK_IDX] = type_tbl[exp_desc->type_idx]; 06475 TYP_LINEAR(TYP_WORK_IDX) = exp_desc->linear_type; 06476 exp_desc->type_idx = ntr_type_tbl(); 06477 06478 } 06479 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 06480 (exp_desc_l.type != Character || 06481 exp_desc_r.type != Character), 06482 &ok, 06483 &exp_desc_l, &exp_desc_r)) { 06484 06485 (*exp_desc) = exp_desc_l; 06486 06487 goto EXIT; 06488 } 06489 else { 06490 ok = FALSE; 06491 } 06492 06493 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 06494 IR_RANK(ir_idx) = exp_desc->rank; 06495 06496 if (IR_RANK(ir_idx)) { 06497 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 06498 } 06499 06500 06501 EXIT: 06502 06503 TRACE (Func_Exit, "concat_opr_handler", NULL); 06504 06505 return(ok); 06506 06507 } /* concat_opr_handler */ 06508 06509 /******************************************************************************\ 06510 |* *| 06511 |* Description: *| 06512 |* semantic handler for the Eq_Opr and Ne_Opr. *| 06513 |* *| 06514 |* Input parameters: *| 06515 |* NONE *| 06516 |* *| 06517 |* Output parameters: *| 06518 |* NONE *| 06519 |* *| 06520 |* Returns: *| 06521 |* NOTHING *| 06522 |* *| 06523 \******************************************************************************/ 06524 06525 static boolean eq_opr_handler(opnd_type *result_opnd, 06526 expr_arg_type *exp_desc) 06527 06528 { 06529 int col; 06530 expr_arg_type exp_desc_l; 06531 expr_arg_type exp_desc_r; 06532 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 06533 int ir_idx; 06534 int line; 06535 boolean ok = TRUE; 06536 opnd_type opnd; 06537 int opnd_col; 06538 int opnd_line; 06539 boolean save_in_call_list; 06540 int type_idx; 06541 06542 06543 TRACE (Func_Entry, "eq_opr_handler" , NULL); 06544 06545 ir_idx = OPND_IDX((*result_opnd)); 06546 line = IR_LINE_NUM(ir_idx); 06547 col = IR_COL_NUM(ir_idx); 06548 save_in_call_list = in_call_list; 06549 in_call_list = FALSE; 06550 06551 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 06552 exp_desc_l.rank = 0; 06553 ok = expr_sem(&opnd, &exp_desc_l); 06554 COPY_OPND(IR_OPND_L(ir_idx), opnd); 06555 06556 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 06557 exp_desc_r.rank = 0; 06558 ok &= expr_sem(&opnd, &exp_desc_r); 06559 COPY_OPND(IR_OPND_R(ir_idx), opnd); 06560 06561 if (!ok) { 06562 goto EXIT; 06563 } 06564 06565 exp_desc->has_constructor = exp_desc_l.has_constructor || 06566 exp_desc_r.has_constructor; 06567 06568 exp_desc->has_symbolic = exp_desc_l.has_symbolic || 06569 exp_desc_r.has_symbolic; 06570 06571 exp_desc->linear_type = EQ_NE_TYPE(exp_desc_l.linear_type, 06572 exp_desc_r.linear_type); 06573 06574 if (exp_desc->linear_type != Err_Res && 06575 (exp_desc_l.rank == exp_desc_r.rank || 06576 exp_desc_l.rank * exp_desc_r.rank == 0)) { 06577 06578 if (EQ_NE_EXTN(exp_desc_l.linear_type, 06579 exp_desc_r.linear_type)) { 06580 /* check for defined operator */ 06581 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 06582 FALSE, 06583 &ok, 06584 &exp_desc_l, &exp_desc_r)) { 06585 06586 (*exp_desc) = exp_desc_l; 06587 06588 goto EXIT; 06589 } 06590 else { 06591 if (exp_desc_l.type == Character || 06592 exp_desc_l.linear_type == Short_Typeless_Const) { 06593 06594 find_opnd_line_and_column((opnd_type *) 06595 &IR_OPND_L(ir_idx), 06596 &opnd_line, 06597 &opnd_col); 06598 06599 if (exp_desc_l.type == Character) { 06600 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 06601 } 06602 06603 type_idx = exp_desc_r.type_idx; 06604 06605 if (exp_desc_r.type == Character || 06606 exp_desc_r.type == Typeless) { 06607 type_idx = INTEGER_DEFAULT_TYPE; 06608 } 06609 06610 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 06611 type_idx, 06612 opnd_line, 06613 opnd_col); 06614 06615 exp_desc_l.type_idx = type_idx; 06616 exp_desc_l.type = TYP_TYPE(type_idx); 06617 exp_desc_l.linear_type = TYP_LINEAR(type_idx); 06618 } 06619 06620 if (exp_desc_r.type == Character || 06621 exp_desc_r.linear_type == Short_Typeless_Const) { 06622 06623 find_opnd_line_and_column((opnd_type *) 06624 &IR_OPND_R(ir_idx), 06625 &opnd_line, 06626 &opnd_col); 06627 06628 if (exp_desc_r.type == Character) { 06629 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 06630 } 06631 06632 type_idx = exp_desc_l.type_idx; 06633 06634 if (exp_desc_l.type == Character || 06635 exp_desc_l.type == Typeless) { 06636 type_idx = INTEGER_DEFAULT_TYPE; 06637 } 06638 06639 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 06640 type_idx, 06641 opnd_line, 06642 opnd_col); 06643 06644 exp_desc_r.type_idx = type_idx; 06645 exp_desc_r.type = TYP_TYPE(type_idx); 06646 exp_desc_r.linear_type = TYP_LINEAR(type_idx); 06647 } 06648 06649 /* reset the linear type to reflect any changes above */ 06650 exp_desc->linear_type = EQ_NE_TYPE(exp_desc_l.linear_type, 06651 exp_desc_r.linear_type); 06652 } 06653 } 06654 06655 exp_desc->type_idx = exp_desc->linear_type; 06656 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 06657 06658 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 06659 exp_desc, line, col)) { 06660 ok = FALSE; 06661 } 06662 06663 exp_desc->constant = exp_desc_l.constant && 06664 exp_desc_r.constant; 06665 exp_desc->foldable = exp_desc_l.foldable && 06666 exp_desc_r.foldable; 06667 06668 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 06669 exp_desc_r.will_fold_later) | 06670 (exp_desc_l.will_fold_later & 06671 exp_desc_r.foldable) | 06672 (exp_desc_l.foldable & 06673 exp_desc_r.will_fold_later); 06674 06675 if (opt_flags.ieeeconform && 06676 ! comp_gen_expr && 06677 (exp_desc_l.type == Real || 06678 exp_desc_l.type == Complex || 06679 exp_desc_r.type == Real || 06680 exp_desc_r.type == Complex)) { 06681 06682 /* don't fold real arithmatic under ieeeconform */ 06683 06684 exp_desc->foldable = FALSE; 06685 exp_desc->will_fold_later = FALSE; 06686 } 06687 else if (exp_desc->foldable && 06688 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 06689 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 06690 06691 type_idx = exp_desc->type_idx; 06692 06693 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 06694 exp_desc_l.type_idx, 06695 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 06696 exp_desc_r.type_idx, 06697 folded_const, 06698 &type_idx, 06699 line, 06700 col, 06701 2, 06702 IR_OPR(ir_idx))) { 06703 06704 exp_desc->type_idx = type_idx; 06705 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 06706 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 06707 FALSE, 06708 folded_const); 06709 06710 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 06711 OPND_LINE_NUM((*result_opnd)) = line; 06712 OPND_COL_NUM((*result_opnd)) = col; 06713 } 06714 else { 06715 ok = FALSE; 06716 } 06717 } 06718 else if (exp_desc_l.type == Character && 06719 exp_desc_r.type == Character && 06720 exp_desc_l.char_len.fld == CN_Tbl_Idx && 06721 CN_INT_TO_C(exp_desc_l.char_len.idx) == 0 && 06722 exp_desc_r.char_len.fld == CN_Tbl_Idx && 06723 CN_INT_TO_C(exp_desc_r.char_len.idx) == 0) { 06724 06725 /* left and right are zero length char */ 06726 06727 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 06728 OPND_IDX((*result_opnd)) = set_up_logical_constant(folded_const, 06729 exp_desc->type_idx, 06730 (IR_OPR(ir_idx) == Eq_Opr) ? TRUE_VALUE : 06731 FALSE_VALUE, 06732 TRUE); 06733 06734 06735 06736 OPND_LINE_NUM((*result_opnd)) = line; 06737 OPND_COL_NUM((*result_opnd)) = col; 06738 06739 if (exp_desc->rank) { 06740 make_logical_array_tmp(result_opnd, 06741 exp_desc); 06742 } 06743 } 06744 } 06745 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 06746 (exp_desc->linear_type == Err_Res), 06747 &ok, 06748 &exp_desc_l, &exp_desc_r)) { 06749 06750 (*exp_desc) = exp_desc_l; 06751 06752 goto EXIT; 06753 } 06754 else { 06755 ok = FALSE; 06756 } 06757 06758 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 06759 IR_RANK(ir_idx) = exp_desc->rank; 06760 06761 if (IR_RANK(ir_idx)) { 06762 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 06763 } 06764 06765 EXIT: 06766 06767 TRACE (Func_Exit, "eq_opr_handler", NULL); 06768 06769 return(ok); 06770 06771 } /* eq_opr_handler */ 06772 06773 /******************************************************************************\ 06774 |* *| 06775 |* Description: *| 06776 |* semantic handler for the Lg_Opr. *| 06777 |* *| 06778 |* Input parameters: *| 06779 |* NONE *| 06780 |* *| 06781 |* Output parameters: *| 06782 |* NONE *| 06783 |* *| 06784 |* Returns: *| 06785 |* NOTHING *| 06786 |* *| 06787 \******************************************************************************/ 06788 06789 static boolean lg_opr_handler(opnd_type *result_opnd, 06790 expr_arg_type *exp_desc) 06791 06792 { 06793 int col; 06794 expr_arg_type exp_desc_l; 06795 expr_arg_type exp_desc_r; 06796 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 06797 int ir_idx; 06798 int line; 06799 boolean ok = TRUE; 06800 opnd_type opnd; 06801 int opnd_col; 06802 int opnd_line; 06803 boolean save_in_call_list; 06804 int type_idx; 06805 06806 06807 TRACE (Func_Entry, "lg_opr_handler" , NULL); 06808 06809 ir_idx = OPND_IDX((*result_opnd)); 06810 line = IR_LINE_NUM(ir_idx); 06811 col = IR_COL_NUM(ir_idx); 06812 save_in_call_list = in_call_list; 06813 in_call_list = FALSE; 06814 06815 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 06816 exp_desc_l.rank = 0; 06817 ok = expr_sem(&opnd, &exp_desc_l); 06818 COPY_OPND(IR_OPND_L(ir_idx), opnd); 06819 06820 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 06821 exp_desc_r.rank = 0; 06822 ok &= expr_sem(&opnd, &exp_desc_r); 06823 COPY_OPND(IR_OPND_R(ir_idx), opnd); 06824 06825 if (!ok) { 06826 goto EXIT; 06827 } 06828 06829 exp_desc->has_constructor = exp_desc_l.has_constructor || 06830 exp_desc_r.has_constructor; 06831 06832 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 06833 06834 exp_desc->linear_type = LG_TYPE(exp_desc_l.linear_type, 06835 exp_desc_r.linear_type); 06836 06837 if (exp_desc->linear_type != Err_Res && 06838 (exp_desc_l.rank == exp_desc_r.rank || 06839 exp_desc_l.rank * exp_desc_r.rank == 0)) { 06840 06841 if (LG_EXTN(exp_desc_l.linear_type, 06842 exp_desc_r.linear_type)) { 06843 /* check for defined operator */ 06844 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 06845 FALSE, 06846 &ok, 06847 &exp_desc_l, &exp_desc_r)) { 06848 06849 (*exp_desc) = exp_desc_l; 06850 06851 goto EXIT; 06852 } 06853 else { 06854 if (exp_desc_l.type == Character || 06855 exp_desc_l.linear_type == Short_Typeless_Const) { 06856 06857 find_opnd_line_and_column((opnd_type *) 06858 &IR_OPND_L(ir_idx), 06859 &opnd_line, 06860 &opnd_col); 06861 06862 if (exp_desc_l.type == Character) { 06863 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 06864 } 06865 06866 type_idx = exp_desc_r.type_idx; 06867 06868 if (exp_desc_r.type == Character || 06869 exp_desc_r.type == Typeless) { 06870 type_idx = INTEGER_DEFAULT_TYPE; 06871 } 06872 06873 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 06874 type_idx, 06875 opnd_line, 06876 opnd_col); 06877 06878 exp_desc_l.type_idx = type_idx; 06879 exp_desc_l.type = TYP_TYPE(type_idx); 06880 exp_desc_l.linear_type = TYP_LINEAR(type_idx); 06881 } 06882 06883 if (exp_desc_r.type == Character || 06884 exp_desc_r.linear_type == Short_Typeless_Const) { 06885 06886 find_opnd_line_and_column((opnd_type *) 06887 &IR_OPND_R(ir_idx), 06888 &opnd_line, 06889 &opnd_col); 06890 06891 if (exp_desc_r.type == Character) { 06892 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 06893 } 06894 06895 type_idx = exp_desc_l.type_idx; 06896 06897 if (exp_desc_l.type == Character || 06898 exp_desc_l.type == Typeless) { 06899 type_idx = INTEGER_DEFAULT_TYPE; 06900 } 06901 06902 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 06903 type_idx, 06904 opnd_line, 06905 opnd_col); 06906 06907 exp_desc_r.type_idx = type_idx; 06908 exp_desc_r.type = TYP_TYPE(type_idx); 06909 exp_desc_r.linear_type = TYP_LINEAR(type_idx); 06910 } 06911 06912 /* reset the linear type to reflect any changes above */ 06913 exp_desc->linear_type = LG_TYPE(exp_desc_l.linear_type, 06914 exp_desc_r.linear_type); 06915 } 06916 } 06917 06918 exp_desc->type_idx = exp_desc->linear_type; 06919 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 06920 06921 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 06922 exp_desc, line, col)) { 06923 ok = FALSE; 06924 } 06925 06926 exp_desc->constant = exp_desc_l.constant && 06927 exp_desc_r.constant; 06928 exp_desc->foldable = exp_desc_l.foldable && 06929 exp_desc_r.foldable; 06930 06931 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 06932 exp_desc_r.will_fold_later) | 06933 (exp_desc_l.will_fold_later & 06934 exp_desc_r.foldable) | 06935 (exp_desc_l.foldable & 06936 exp_desc_r.will_fold_later); 06937 06938 06939 if (! target_ieee) { 06940 /* change to .NE. on non ieee machines */ 06941 IR_OPR(ir_idx) = Ne_Opr; 06942 } 06943 else { 06944 /* for now, do not try to fold these */ 06945 06946 exp_desc->foldable = FALSE; 06947 exp_desc->will_fold_later = FALSE; 06948 } 06949 06950 if (opt_flags.ieeeconform && 06951 ! comp_gen_expr && 06952 (exp_desc_l.type == Real || 06953 exp_desc_l.type == Complex || 06954 exp_desc_r.type == Real || 06955 exp_desc_r.type == Complex)) { 06956 06957 /* don't fold real arithmatic under ieeeconform */ 06958 06959 exp_desc->foldable = FALSE; 06960 exp_desc->will_fold_later = FALSE; 06961 } 06962 else if (exp_desc->foldable && 06963 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 06964 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 06965 06966 type_idx = exp_desc->type_idx; 06967 06968 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 06969 exp_desc_l.type_idx, 06970 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 06971 exp_desc_r.type_idx, 06972 folded_const, 06973 &type_idx, 06974 line, 06975 col, 06976 2, 06977 IR_OPR(ir_idx))) { 06978 06979 exp_desc->type_idx = type_idx; 06980 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 06981 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 06982 FALSE, 06983 folded_const); 06984 06985 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 06986 OPND_LINE_NUM((*result_opnd)) = line; 06987 OPND_COL_NUM((*result_opnd)) = col; 06988 } 06989 else { 06990 ok = FALSE; 06991 } 06992 } 06993 } 06994 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 06995 (exp_desc->linear_type == Err_Res), 06996 &ok, 06997 &exp_desc_l, &exp_desc_r)) { 06998 06999 (*exp_desc) = exp_desc_l; 07000 07001 goto EXIT; 07002 } 07003 else { 07004 ok = FALSE; 07005 } 07006 07007 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 07008 IR_RANK(ir_idx) = exp_desc->rank; 07009 07010 if (IR_RANK(ir_idx)) { 07011 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 07012 } 07013 07014 EXIT: 07015 07016 TRACE (Func_Exit, "lg_opr_handler", NULL); 07017 07018 return(ok); 07019 07020 } /* lg_opr_handler */ 07021 07022 /******************************************************************************\ 07023 |* *| 07024 |* Description: *| 07025 |* semantic handler for the Lt_Opr, Le_Opr, Gt_Opr, and Ge_Opr. *| 07026 |* *| 07027 |* Input parameters: *| 07028 |* NONE *| 07029 |* *| 07030 |* Output parameters: *| 07031 |* NONE *| 07032 |* *| 07033 |* Returns: *| 07034 |* NOTHING *| 07035 |* *| 07036 \******************************************************************************/ 07037 07038 static boolean lt_opr_handler(opnd_type *result_opnd, 07039 expr_arg_type *exp_desc) 07040 07041 { 07042 int col; 07043 expr_arg_type exp_desc_l; 07044 expr_arg_type exp_desc_r; 07045 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 07046 int ir_idx; 07047 int line; 07048 boolean ok = TRUE; 07049 opnd_type opnd; 07050 int opnd_col; 07051 int opnd_line; 07052 boolean save_in_call_list; 07053 int type_idx; 07054 07055 07056 TRACE (Func_Entry, "lt_opr_handler" , NULL); 07057 07058 ir_idx = OPND_IDX((*result_opnd)); 07059 line = IR_LINE_NUM(ir_idx); 07060 col = IR_COL_NUM(ir_idx); 07061 save_in_call_list = in_call_list; 07062 in_call_list = FALSE; 07063 07064 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 07065 exp_desc_l.rank = 0; 07066 ok = expr_sem(&opnd, &exp_desc_l); 07067 COPY_OPND(IR_OPND_L(ir_idx), opnd); 07068 07069 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 07070 exp_desc_r.rank = 0; 07071 ok &= expr_sem(&opnd, &exp_desc_r); 07072 COPY_OPND(IR_OPND_R(ir_idx), opnd); 07073 07074 if (!ok) { 07075 goto EXIT; 07076 } 07077 07078 exp_desc->has_constructor = exp_desc_l.has_constructor || 07079 exp_desc_r.has_constructor; 07080 07081 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 07082 07083 exp_desc->linear_type = GT_LT_TYPE(exp_desc_l.linear_type, 07084 exp_desc_r.linear_type); 07085 07086 if (exp_desc->linear_type != Err_Res && 07087 (exp_desc_l.rank == exp_desc_r.rank || 07088 exp_desc_l.rank * exp_desc_r.rank == 0)) { 07089 07090 if (GT_LT_EXTN(exp_desc_l.linear_type, 07091 exp_desc_r.linear_type)) { 07092 /* check for defined operator */ 07093 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 07094 FALSE, 07095 &ok, 07096 &exp_desc_l, &exp_desc_r)) { 07097 07098 (*exp_desc) = exp_desc_l; 07099 07100 goto EXIT; 07101 } 07102 else { 07103 if (exp_desc_l.type == Character || 07104 exp_desc_l.linear_type == Short_Typeless_Const) { 07105 07106 find_opnd_line_and_column((opnd_type *) 07107 &IR_OPND_L(ir_idx), 07108 &opnd_line, 07109 &opnd_col); 07110 07111 if (exp_desc_l.type == Character) { 07112 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 07113 } 07114 07115 type_idx = exp_desc_r.type_idx; 07116 07117 if (exp_desc_r.type == Character || 07118 exp_desc_r.type == Typeless) { 07119 type_idx = INTEGER_DEFAULT_TYPE; 07120 } 07121 07122 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 07123 type_idx, 07124 opnd_line, 07125 opnd_col); 07126 07127 exp_desc_l.type_idx = type_idx; 07128 exp_desc_l.type = TYP_TYPE(type_idx); 07129 exp_desc_l.linear_type = TYP_LINEAR(type_idx); 07130 } 07131 07132 if (exp_desc_r.type == Character || 07133 exp_desc_r.linear_type == Short_Typeless_Const) { 07134 07135 find_opnd_line_and_column((opnd_type *) 07136 &IR_OPND_R(ir_idx), 07137 &opnd_line, 07138 &opnd_col); 07139 07140 if (exp_desc_r.type == Character) { 07141 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 07142 } 07143 07144 type_idx = exp_desc_l.type_idx; 07145 07146 if (exp_desc_l.type == Character || 07147 exp_desc_l.type == Typeless) { 07148 type_idx = INTEGER_DEFAULT_TYPE; 07149 } 07150 07151 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 07152 type_idx, 07153 opnd_line, 07154 opnd_col); 07155 07156 exp_desc_r.type_idx = type_idx; 07157 exp_desc_r.type = TYP_TYPE(type_idx); 07158 exp_desc_r.linear_type = TYP_LINEAR(type_idx); 07159 } 07160 07161 /* reset the linear type to reflect any changes above */ 07162 exp_desc->linear_type = GT_LT_TYPE(exp_desc_l.linear_type, 07163 exp_desc_r.linear_type); 07164 } 07165 } 07166 07167 exp_desc->type_idx = exp_desc->linear_type; 07168 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 07169 07170 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 07171 exp_desc, line, col)) { 07172 ok = FALSE; 07173 } 07174 07175 exp_desc->constant = exp_desc_l.constant && 07176 exp_desc_r.constant; 07177 exp_desc->foldable = exp_desc_l.foldable && 07178 exp_desc_r.foldable; 07179 07180 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 07181 exp_desc_r.will_fold_later) | 07182 (exp_desc_l.will_fold_later & 07183 exp_desc_r.foldable) | 07184 (exp_desc_l.foldable & 07185 exp_desc_r.will_fold_later); 07186 07187 if (opt_flags.ieeeconform && 07188 ! comp_gen_expr && 07189 (exp_desc_l.type == Real || 07190 exp_desc_l.type == Complex || 07191 exp_desc_r.type == Real || 07192 exp_desc_r.type == Complex)) { 07193 07194 /* don't fold real arithmatic under ieeeconform */ 07195 07196 exp_desc->foldable = FALSE; 07197 exp_desc->will_fold_later = FALSE; 07198 } 07199 else if (exp_desc->foldable && 07200 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 07201 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 07202 07203 type_idx = exp_desc->type_idx; 07204 07205 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 07206 exp_desc_l.type_idx, 07207 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 07208 exp_desc_r.type_idx, 07209 folded_const, 07210 &type_idx, 07211 line, 07212 col, 07213 2, 07214 IR_OPR(ir_idx))) { 07215 07216 exp_desc->type_idx = type_idx; 07217 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07218 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 07219 FALSE, 07220 folded_const); 07221 07222 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 07223 OPND_LINE_NUM((*result_opnd)) = line; 07224 OPND_COL_NUM((*result_opnd)) = col; 07225 } 07226 else { 07227 ok = FALSE; 07228 } 07229 } 07230 else if (exp_desc_l.type == Character && 07231 exp_desc_r.type == Character && 07232 exp_desc_l.char_len.fld == CN_Tbl_Idx && 07233 CN_INT_TO_C(exp_desc_l.char_len.idx) == 0 && 07234 exp_desc_r.char_len.fld == CN_Tbl_Idx && 07235 CN_INT_TO_C(exp_desc_r.char_len.idx) == 0) { 07236 07237 /* left and right are zero length char */ 07238 07239 if (IR_OPR(ir_idx) == Ge_Opr || IR_OPR(ir_idx) == Le_Opr) { 07240 07241 /* result is TRUE */ 07242 07243 OPND_IDX((*result_opnd)) = set_up_logical_constant(folded_const, 07244 exp_desc->type_idx, 07245 TRUE_VALUE, 07246 TRUE); 07247 } 07248 else { /* result is FALSE */ 07249 OPND_IDX((*result_opnd)) = set_up_logical_constant(folded_const, 07250 exp_desc->type_idx, 07251 FALSE_VALUE, 07252 TRUE); 07253 } 07254 07255 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07256 OPND_LINE_NUM((*result_opnd)) = line; 07257 OPND_COL_NUM((*result_opnd)) = col; 07258 07259 if (exp_desc->rank) { 07260 make_logical_array_tmp(result_opnd, 07261 exp_desc); 07262 } 07263 } 07264 } 07265 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 07266 (exp_desc->linear_type == Err_Res), 07267 &ok, 07268 &exp_desc_l, &exp_desc_r)) { 07269 07270 (*exp_desc) = exp_desc_l; 07271 07272 goto EXIT; 07273 } 07274 else { 07275 ok = FALSE; 07276 } 07277 07278 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 07279 IR_RANK(ir_idx) = exp_desc->rank; 07280 07281 if (IR_RANK(ir_idx)) { 07282 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 07283 } 07284 07285 EXIT: 07286 07287 TRACE (Func_Exit, "lt_opr_handler", NULL); 07288 07289 return(ok); 07290 07291 } /* lt_opr_handler */ 07292 07293 /******************************************************************************\ 07294 |* *| 07295 |* Description: *| 07296 |* semantic handler for the Not_Opr. *| 07297 |* *| 07298 |* Input parameters: *| 07299 |* NONE *| 07300 |* *| 07301 |* Output parameters: *| 07302 |* NONE *| 07303 |* *| 07304 |* Returns: *| 07305 |* NOTHING *| 07306 |* *| 07307 \******************************************************************************/ 07308 07309 static boolean not_opr_handler(opnd_type *result_opnd, 07310 expr_arg_type *exp_desc) 07311 07312 { 07313 int col; 07314 expr_arg_type exp_desc_l; 07315 expr_arg_type exp_desc_r; 07316 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 07317 int ir_idx; 07318 int line; 07319 boolean ok = TRUE; 07320 opnd_type opnd; 07321 int opnd_col; 07322 int opnd_line; 07323 boolean save_in_call_list; 07324 int type_idx; 07325 07326 07327 TRACE (Func_Entry, "not_opr_handler" , NULL); 07328 07329 ir_idx = OPND_IDX((*result_opnd)); 07330 line = IR_LINE_NUM(ir_idx); 07331 col = IR_COL_NUM(ir_idx); 07332 save_in_call_list = in_call_list; 07333 in_call_list = FALSE; 07334 07335 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 07336 exp_desc_l.rank = 0; 07337 ok = expr_sem(&opnd, &exp_desc_l); 07338 COPY_OPND(IR_OPND_L(ir_idx), opnd); 07339 07340 if (!ok) { 07341 goto EXIT; 07342 } 07343 07344 exp_desc->has_constructor = exp_desc_l.has_constructor; 07345 07346 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 07347 07348 exp_desc->linear_type = NOT_TYPE(exp_desc_l.linear_type); 07349 07350 if (exp_desc->linear_type != Err_Res) { 07351 07352 if (NOT_EXTN(exp_desc_l.linear_type)) { 07353 /* check for defined operator */ 07354 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 07355 FALSE, 07356 &ok, 07357 &exp_desc_l, &exp_desc_r)) { 07358 07359 (*exp_desc) = exp_desc_l; 07360 07361 goto EXIT; 07362 } 07363 else { 07364 /* change opr to bnot */ 07365 IR_OPR(ir_idx) = Bnot_Opr; 07366 PRINTMSG(IR_LINE_NUM(ir_idx), 395, Ansi, 07367 IR_COL_NUM(ir_idx)); 07368 07369 if (exp_desc_l.type == Character || 07370 exp_desc_l.linear_type == Short_Typeless_Const) { 07371 07372 find_opnd_line_and_column((opnd_type *) 07373 &IR_OPND_L(ir_idx), 07374 &opnd_line, 07375 &opnd_col); 07376 07377 if (exp_desc_l.type == Character) { 07378 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 07379 } 07380 07381 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 07382 exp_desc->linear_type, 07383 opnd_line, 07384 opnd_col); 07385 07386 exp_desc_l.type_idx = exp_desc->linear_type; 07387 exp_desc_l.type = TYP_TYPE(exp_desc->linear_type); 07388 exp_desc_l.linear_type = exp_desc->linear_type; 07389 07390 /* reset the linear type to reflect any change from above */ 07391 exp_desc->linear_type = NOT_TYPE(exp_desc_l.linear_type); 07392 } 07393 } 07394 } 07395 07396 exp_desc->type_idx = exp_desc->linear_type; 07397 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 07398 exp_desc->rank = exp_desc_l.rank; 07399 exp_desc->constant = exp_desc_l.constant; 07400 exp_desc->foldable = exp_desc_l.foldable; 07401 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 07402 07403 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape,exp_desc_l.rank); 07404 07405 if (opt_flags.ieeeconform && 07406 ! comp_gen_expr && 07407 (exp_desc_l.type == Real || 07408 exp_desc_l.type == Complex)) { 07409 07410 /* don't fold real arithmatic under ieeeconform */ 07411 07412 exp_desc->foldable = FALSE; 07413 exp_desc->will_fold_later = FALSE; 07414 } 07415 else if (exp_desc_l.foldable && 07416 IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 07417 07418 type_idx = exp_desc->type_idx; 07419 07420 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 07421 exp_desc_l.type_idx, 07422 NULL, 07423 NULL_IDX, 07424 folded_const, 07425 &type_idx, 07426 line, 07427 col, 07428 1, 07429 IR_OPR(ir_idx))) { 07430 07431 exp_desc->type_idx = type_idx; 07432 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07433 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 07434 FALSE, 07435 folded_const); 07436 07437 OPND_LINE_NUM((*result_opnd)) = line; 07438 OPND_COL_NUM((*result_opnd)) = col; 07439 } 07440 else { 07441 ok = FALSE; 07442 } 07443 } 07444 } 07445 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 07446 (exp_desc->linear_type == Err_Res), 07447 &ok, 07448 &exp_desc_l, &exp_desc_r)) { 07449 07450 (*exp_desc) = exp_desc_l; 07451 07452 goto EXIT; 07453 } 07454 else { 07455 ok = FALSE; 07456 } 07457 07458 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 07459 IR_RANK(ir_idx) = exp_desc->rank; 07460 07461 if (IR_RANK(ir_idx)) { 07462 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 07463 } 07464 07465 EXIT: 07466 07467 TRACE (Func_Exit, "not_opr_handler", NULL); 07468 07469 return(ok); 07470 07471 } /* not_opr_handler */ 07472 07473 /******************************************************************************\ 07474 |* *| 07475 |* Description: *| 07476 |* semantic handler for the And_Opr, Or_Opr, Eqv_Opr, Neqv_Opr. *| 07477 |* *| 07478 |* Input parameters: *| 07479 |* NONE *| 07480 |* *| 07481 |* Output parameters: *| 07482 |* NONE *| 07483 |* *| 07484 |* Returns: *| 07485 |* NOTHING *| 07486 |* *| 07487 \******************************************************************************/ 07488 07489 static boolean and_opr_handler(opnd_type *result_opnd, 07490 expr_arg_type *exp_desc) 07491 07492 { 07493 int col; 07494 expr_arg_type exp_desc_l; 07495 expr_arg_type exp_desc_r; 07496 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 07497 int ir_idx; 07498 int line; 07499 boolean ok = TRUE; 07500 opnd_type opnd; 07501 int opnd_col; 07502 int opnd_line; 07503 # if defined(_HIGH_LEVEL_IF_FORM) 07504 boolean save_has_present_opr; 07505 # endif 07506 boolean save_in_call_list; 07507 int save_number_of_functions; 07508 int save_number_of_functions_l; 07509 int type_idx; 07510 07511 07512 TRACE (Func_Entry, "and_opr_handler" , NULL); 07513 07514 ir_idx = OPND_IDX((*result_opnd)); 07515 line = IR_LINE_NUM(ir_idx); 07516 col = IR_COL_NUM(ir_idx); 07517 save_in_call_list = in_call_list; 07518 in_call_list = FALSE; 07519 07520 # if defined(_HIGH_LEVEL_IF_FORM) 07521 if (in_branch_true) { 07522 if (opt_flags.short_circuit_lvl == Short_Circuit_Present) { 07523 save_has_present_opr = has_present_opr; 07524 has_present_opr = FALSE; 07525 } 07526 else if (opt_flags.short_circuit_lvl == Short_Circuit_Functions) { 07527 save_number_of_functions = number_of_functions; 07528 number_of_functions = 0; 07529 } 07530 } 07531 # else 07532 if (in_branch_true) { 07533 save_number_of_functions = number_of_functions; 07534 number_of_functions = 0; 07535 } 07536 # endif 07537 07538 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 07539 exp_desc_l.rank = 0; 07540 ok = expr_sem(&opnd, &exp_desc_l); 07541 COPY_OPND(IR_OPND_L(ir_idx), opnd); 07542 07543 # if defined(_HIGH_LEVEL_IF_FORM) 07544 if (in_branch_true) { 07545 if (opt_flags.short_circuit_lvl == Short_Circuit_Present) { 07546 save_has_present_opr |= has_present_opr; 07547 IR_SHORT_CIRCUIT_L(ir_idx) = has_present_opr; 07548 has_present_opr = FALSE; 07549 } 07550 else if (opt_flags.short_circuit_lvl == Short_Circuit_Functions) { 07551 save_number_of_functions_l = number_of_functions; 07552 number_of_functions = 0; 07553 } 07554 } 07555 # else 07556 if (in_branch_true) { 07557 save_number_of_functions_l = number_of_functions; 07558 number_of_functions = 0; 07559 } 07560 # endif 07561 07562 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 07563 exp_desc_r.rank = 0; 07564 ok &= expr_sem(&opnd, &exp_desc_r); 07565 COPY_OPND(IR_OPND_R(ir_idx), opnd); 07566 07567 # if defined(_HIGH_LEVEL_IF_FORM) 07568 if (in_branch_true) { 07569 if (opt_flags.short_circuit_lvl == Short_Circuit_Present) { 07570 save_has_present_opr |= has_present_opr; 07571 IR_SHORT_CIRCUIT_R(ir_idx) = has_present_opr; 07572 has_present_opr = save_has_present_opr; 07573 } 07574 else if (opt_flags.short_circuit_lvl == Short_Circuit_Functions) { 07575 07576 if (save_number_of_functions_l == number_of_functions && 07577 number_of_functions == 0) { 07578 /* no functions */ 07579 IR_SHORT_CIRCUIT_L(ir_idx) = FALSE; 07580 IR_SHORT_CIRCUIT_R(ir_idx) = FALSE; 07581 } 07582 else if (save_number_of_functions_l <= number_of_functions) { 07583 IR_SHORT_CIRCUIT_R(ir_idx) = TRUE; 07584 IR_SHORT_CIRCUIT_L(ir_idx) = FALSE; 07585 } 07586 else { 07587 IR_SHORT_CIRCUIT_L(ir_idx) = TRUE; 07588 IR_SHORT_CIRCUIT_R(ir_idx) = FALSE; 07589 } 07590 07591 number_of_functions += save_number_of_functions_l + 07592 save_number_of_functions; 07593 } 07594 } 07595 # else 07596 if (in_branch_true) { 07597 07598 if (save_number_of_functions_l == number_of_functions && 07599 number_of_functions == 0) { 07600 /* no functions */ 07601 IR_SHORT_CIRCUIT_L(ir_idx) = FALSE; 07602 IR_SHORT_CIRCUIT_R(ir_idx) = FALSE; 07603 } 07604 else if (save_number_of_functions_l <= number_of_functions) { 07605 IR_SHORT_CIRCUIT_R(ir_idx) = TRUE; 07606 IR_SHORT_CIRCUIT_L(ir_idx) = FALSE; 07607 } 07608 else { 07609 IR_SHORT_CIRCUIT_L(ir_idx) = TRUE; 07610 IR_SHORT_CIRCUIT_R(ir_idx) = FALSE; 07611 } 07612 07613 number_of_functions += save_number_of_functions_l + 07614 save_number_of_functions; 07615 } 07616 # endif 07617 07618 if (!ok) { 07619 goto EXIT; 07620 } 07621 07622 exp_desc->has_constructor = exp_desc_l.has_constructor || 07623 exp_desc_r.has_constructor; 07624 07625 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 07626 07627 exp_desc->linear_type = AND_OR_TYPE(exp_desc_l.linear_type, 07628 exp_desc_r.linear_type); 07629 07630 if (exp_desc->linear_type != Err_Res && 07631 (exp_desc_l.rank == exp_desc_r.rank || 07632 exp_desc_l.rank * exp_desc_r.rank == 0)) { 07633 07634 if (AND_OR_EXTN(exp_desc_l.linear_type, 07635 exp_desc_r.linear_type)) { 07636 /* check for defined operator */ 07637 if (resolve_ext_opr(result_opnd, FALSE, save_in_call_list, 07638 FALSE, 07639 &ok, 07640 &exp_desc_l, &exp_desc_r)) { 07641 07642 (*exp_desc) = exp_desc_l; 07643 07644 goto EXIT; 07645 } 07646 else { 07647 07648 /* change to binary oper */ 07649 switch (IR_OPR(ir_idx)) { 07650 case And_Opr : 07651 IR_OPR(ir_idx) = Band_Opr; 07652 break; 07653 case Or_Opr : 07654 IR_OPR(ir_idx) = Bor_Opr; 07655 break; 07656 case Eqv_Opr : 07657 IR_OPR(ir_idx) = Beqv_Opr; 07658 break; 07659 case Neqv_Opr : 07660 IR_OPR(ir_idx) = Bneqv_Opr; 07661 break; 07662 } 07663 PRINTMSG(IR_LINE_NUM(ir_idx), 395, Ansi, 07664 IR_COL_NUM(ir_idx)); 07665 07666 if (exp_desc_l.type == Character || 07667 exp_desc_l.linear_type == Short_Typeless_Const) { 07668 07669 find_opnd_line_and_column((opnd_type *) 07670 &IR_OPND_L(ir_idx), 07671 &opnd_line, 07672 &opnd_col); 07673 07674 if (exp_desc_l.type == Character) { 07675 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 07676 } 07677 07678 type_idx = exp_desc_r.type_idx; 07679 07680 if (exp_desc_r.type == Character || 07681 exp_desc_r.type == Typeless) { 07682 type_idx = INTEGER_DEFAULT_TYPE; 07683 } 07684 07685 IR_IDX_L(ir_idx) = cast_typeless_constant(IR_IDX_L(ir_idx), 07686 type_idx, 07687 opnd_line, 07688 opnd_col); 07689 07690 exp_desc_l.type_idx = type_idx; 07691 exp_desc_l.type = TYP_TYPE(type_idx); 07692 exp_desc_l.linear_type = TYP_LINEAR(type_idx); 07693 } 07694 07695 if (exp_desc_r.type == Character || 07696 exp_desc_r.linear_type == Short_Typeless_Const) { 07697 07698 find_opnd_line_and_column((opnd_type *) 07699 &IR_OPND_R(ir_idx), 07700 &opnd_line, 07701 &opnd_col); 07702 07703 if (exp_desc_r.type == Character) { 07704 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 07705 } 07706 07707 07708 type_idx = exp_desc_l.type_idx; 07709 07710 if (exp_desc_l.type == Character || 07711 exp_desc_l.type == Typeless) { 07712 type_idx = INTEGER_DEFAULT_TYPE; 07713 } 07714 07715 IR_IDX_R(ir_idx) = cast_typeless_constant(IR_IDX_R(ir_idx), 07716 type_idx, 07717 opnd_line, 07718 opnd_col); 07719 07720 exp_desc_r.type_idx = type_idx; 07721 exp_desc_r.type = TYP_TYPE(type_idx); 07722 exp_desc_r.linear_type = TYP_LINEAR(type_idx); 07723 } 07724 07725 /* reset the linear type to reflect any change from above */ 07726 exp_desc->linear_type = AND_OR_TYPE(exp_desc_l.linear_type, 07727 exp_desc_r.linear_type); 07728 07729 if (num_host_wds[exp_desc_l.linear_type] != 07730 num_host_wds[exp_desc_r.linear_type]) { 07731 07732 PRINTMSG(IR_LINE_NUM(ir_idx), 07733 1188, 07734 Error, 07735 IR_COL_NUM(ir_idx)); 07736 ok = FALSE; 07737 } 07738 } 07739 } 07740 07741 exp_desc->type_idx = exp_desc->linear_type; 07742 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 07743 07744 if (! bin_array_syntax_check(&exp_desc_l, &exp_desc_r, 07745 exp_desc, line, col)) { 07746 ok = FALSE; 07747 } 07748 07749 exp_desc->constant = exp_desc_l.constant && exp_desc_r.constant; 07750 exp_desc->foldable = exp_desc_l.foldable && exp_desc_r.foldable; 07751 07752 exp_desc->will_fold_later = (exp_desc_l.will_fold_later & 07753 exp_desc_r.will_fold_later) | 07754 (exp_desc_l.will_fold_later & 07755 exp_desc_r.foldable) | 07756 (exp_desc_l.foldable & 07757 exp_desc_r.will_fold_later); 07758 07759 07760 if (opt_flags.ieeeconform && 07761 ! comp_gen_expr && 07762 (exp_desc_l.type == Real || 07763 exp_desc_l.type == Complex || 07764 exp_desc_r.type == Real || 07765 exp_desc_r.type == Complex)) { 07766 07767 /* don't fold real arithmatic under ieeeconform */ 07768 07769 exp_desc->foldable = FALSE; 07770 exp_desc->will_fold_later = FALSE; 07771 } 07772 else if (exp_desc->foldable && 07773 ok && 07774 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 07775 IR_FLD_R(ir_idx) == CN_Tbl_Idx) { 07776 07777 type_idx = exp_desc->type_idx; 07778 07779 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 07780 exp_desc_l.type_idx, 07781 (char *)&CN_CONST(IR_IDX_R(ir_idx)), 07782 exp_desc_r.type_idx, 07783 folded_const, 07784 &type_idx, 07785 line, 07786 col, 07787 2, 07788 IR_OPR(ir_idx))) { 07789 07790 exp_desc->type_idx = type_idx; 07791 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07792 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 07793 FALSE, 07794 folded_const); 07795 07796 OPND_LINE_NUM((*result_opnd)) = line; 07797 OPND_COL_NUM((*result_opnd)) = col; 07798 } 07799 else { 07800 ok = FALSE; 07801 } 07802 } 07803 } 07804 else if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 07805 (exp_desc->linear_type == Err_Res), 07806 &ok, 07807 &exp_desc_l, &exp_desc_r)) { 07808 07809 (*exp_desc) = exp_desc_l; 07810 07811 goto EXIT; 07812 } 07813 else { 07814 ok = FALSE; 07815 } 07816 07817 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 07818 IR_RANK(ir_idx) = exp_desc->rank; 07819 07820 if (IR_RANK(ir_idx)) { 07821 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 07822 } 07823 07824 EXIT: 07825 07826 TRACE (Func_Exit, "and_opr_handler", NULL); 07827 07828 return(ok); 07829 07830 } /* and_opr_handler */ 07831 07832 /******************************************************************************\ 07833 |* *| 07834 |* Description: *| 07835 |* semantic handler for the Defined_Un_Opr. *| 07836 |* *| 07837 |* Input parameters: *| 07838 |* NONE *| 07839 |* *| 07840 |* Output parameters: *| 07841 |* NONE *| 07842 |* *| 07843 |* Returns: *| 07844 |* NOTHING *| 07845 |* *| 07846 \******************************************************************************/ 07847 07848 static boolean defined_un_opr_handler(opnd_type *result_opnd, 07849 expr_arg_type *exp_desc) 07850 07851 { 07852 int attr_idx; 07853 expr_arg_type exp_desc_l; 07854 expr_arg_type exp_desc_r; 07855 int ir_idx; 07856 boolean ok = TRUE; 07857 opnd_type opnd; 07858 boolean save_in_call_list; 07859 07860 07861 TRACE (Func_Entry, "defined_un_opr_handler" , NULL); 07862 07863 ir_idx = OPND_IDX((*result_opnd)); 07864 save_in_call_list = in_call_list; 07865 in_call_list = FALSE; 07866 07867 /* Resolve attr link on interface operator attr */ 07868 07869 attr_idx = IR_IDX_L(ir_idx); 07870 AT_LOCKED_IN(attr_idx) = TRUE; 07871 07872 while (AT_ATTR_LINK(attr_idx) && 07873 ! AT_IGNORE_ATTR_LINK(attr_idx)) { 07874 07875 attr_idx = AT_ATTR_LINK(attr_idx); 07876 AT_LOCKED_IN(attr_idx) = TRUE; 07877 } 07878 07879 IR_IDX_L(ir_idx) = attr_idx; 07880 07881 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 07882 exp_desc_l.rank = 0; 07883 ok = expr_sem(&opnd, &exp_desc_l); 07884 COPY_OPND(IR_OPND_R(ir_idx), opnd); 07885 07886 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 07887 07888 /* resolve operator */ 07889 if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 07890 FALSE, 07891 &ok, 07892 &exp_desc_l, &exp_desc_r)) { 07893 07894 (*exp_desc) = exp_desc_l; 07895 } 07896 else { 07897 ok = FALSE; 07898 } 07899 07900 TRACE (Func_Exit, "defined_un_opr_handler", NULL); 07901 07902 return(ok); 07903 07904 } /* defined_un_opr_handler */ 07905 07906 /******************************************************************************\ 07907 |* *| 07908 |* Description: *| 07909 |* semantic handler for the Defined_Bin_Opr. *| 07910 |* *| 07911 |* Input parameters: *| 07912 |* NONE *| 07913 |* *| 07914 |* Output parameters: *| 07915 |* NONE *| 07916 |* *| 07917 |* Returns: *| 07918 |* NOTHING *| 07919 |* *| 07920 \******************************************************************************/ 07921 07922 static boolean defined_bin_opr_handler(opnd_type *result_opnd, 07923 expr_arg_type *exp_desc) 07924 07925 { 07926 int attr_idx; 07927 expr_arg_type exp_desc_l; 07928 expr_arg_type exp_desc_r; 07929 int ir_idx; 07930 boolean ok = TRUE; 07931 opnd_type opnd; 07932 boolean save_in_call_list; 07933 07934 07935 TRACE (Func_Entry, "defined_bin_opr_handler" , NULL); 07936 07937 ir_idx = OPND_IDX((*result_opnd)); 07938 save_in_call_list = in_call_list; 07939 in_call_list = FALSE; 07940 07941 /* Resolve attr link on interface operator attr */ 07942 07943 attr_idx = IR_IDX_L(ir_idx); 07944 AT_LOCKED_IN(attr_idx) = TRUE; 07945 07946 while (AT_ATTR_LINK(attr_idx) && 07947 ! AT_IGNORE_ATTR_LINK(attr_idx)) { 07948 07949 attr_idx = AT_ATTR_LINK(attr_idx); 07950 AT_LOCKED_IN(attr_idx) = TRUE; 07951 } 07952 07953 IR_IDX_L(ir_idx) = attr_idx; 07954 07955 COPY_OPND(opnd, IL_OPND(IR_IDX_R(ir_idx))); 07956 exp_desc_l.rank = 0; 07957 ok = expr_sem(&opnd, &exp_desc_l); 07958 COPY_OPND(IL_OPND(IR_IDX_R(ir_idx)), opnd); 07959 07960 COPY_OPND(opnd, IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)))); 07961 exp_desc_r.rank = 0; 07962 ok &= expr_sem(&opnd, &exp_desc_r); 07963 COPY_OPND(IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))), opnd); 07964 07965 /* resolve operator */ 07966 if (resolve_ext_opr(result_opnd, TRUE, save_in_call_list, 07967 FALSE, 07968 &ok, 07969 &exp_desc_l, &exp_desc_r)) { 07970 07971 (*exp_desc) = exp_desc_l; 07972 } 07973 else { 07974 ok = FALSE; 07975 } 07976 07977 07978 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 07979 07980 TRACE (Func_Exit, "defined_bin_opr_handler", NULL); 07981 07982 return(ok); 07983 07984 } /* defined_bin_opr_handler */ 07985 07986 /******************************************************************************\ 07987 |* *| 07988 |* Description: *| 07989 |* semantic handler for the Max_Opr and Min_Opr. *| 07990 |* *| 07991 |* Input parameters: *| 07992 |* NONE *| 07993 |* *| 07994 |* Output parameters: *| 07995 |* NONE *| 07996 |* *| 07997 |* Returns: *| 07998 |* NOTHING *| 07999 |* *| 08000 \******************************************************************************/ 08001 08002 static boolean max_opr_handler(opnd_type *result_opnd, 08003 expr_arg_type *exp_desc) 08004 08005 { 08006 int comp_idx; 08007 expr_arg_type exp_desc_l; 08008 int ir_idx; 08009 int list_idx; 08010 boolean ok = TRUE; 08011 opnd_type opnd; 08012 boolean save_in_call_list; 08013 08014 08015 TRACE (Func_Entry, "max_opr_handler" , NULL); 08016 08017 ir_idx = OPND_IDX((*result_opnd)); 08018 save_in_call_list = in_call_list; /* BRIANJ - set but not used */ 08019 in_call_list = FALSE; 08020 08021 /* these are only compiler gen'd max and min */ 08022 08023 list_idx = IR_IDX_L(ir_idx); 08024 08025 COPY_OPND(opnd, IL_OPND(list_idx)); 08026 exp_desc_l.rank = 0; 08027 ok = expr_sem(&opnd, &exp_desc_l); 08028 COPY_OPND(IL_OPND(list_idx), opnd); 08029 08030 /* assumes that these are all scalar things */ 08031 08032 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 08033 exp_desc->constant = exp_desc_l.constant; 08034 exp_desc->foldable = exp_desc_l.foldable; 08035 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 08036 08037 if (exp_desc_l.type == Typeless) { 08038 exp_desc->type = Integer; 08039 exp_desc->linear_type = CG_INTEGER_DEFAULT_TYPE; 08040 exp_desc->type_idx = CG_INTEGER_DEFAULT_TYPE; 08041 } 08042 else { 08043 exp_desc->type = exp_desc_l.type; 08044 exp_desc->linear_type = exp_desc_l.linear_type; 08045 exp_desc->type_idx = exp_desc_l.type_idx; 08046 } 08047 08048 if (exp_desc->foldable) { 08049 comp_idx = IL_IDX(list_idx); 08050 } 08051 08052 list_idx = IL_NEXT_LIST_IDX(list_idx); 08053 08054 while (list_idx != NULL_IDX) { 08055 COPY_OPND(opnd, IL_OPND(list_idx)); 08056 exp_desc_l.rank = 0; 08057 ok &= expr_sem(&opnd, &exp_desc_l); 08058 COPY_OPND(IL_OPND(list_idx), opnd); 08059 08060 exp_desc->has_symbolic = exp_desc->has_symbolic || 08061 exp_desc_l.has_symbolic; 08062 exp_desc->constant = exp_desc->constant && exp_desc_l.constant; 08063 exp_desc->foldable = exp_desc->foldable && exp_desc_l.foldable; 08064 08065 exp_desc->will_fold_later = exp_desc->will_fold_later && 08066 (exp_desc_l.will_fold_later || 08067 exp_desc_l.foldable); 08068 08069 if (exp_desc->foldable) { 08070 if (fold_relationals(IL_IDX(list_idx), 08071 comp_idx, 08072 (IR_OPR(ir_idx) == Max_Opr ? 08073 Gt_Opr : Lt_Opr))) { 08074 08075 comp_idx = IL_IDX(list_idx); 08076 } 08077 } 08078 08079 list_idx = IL_NEXT_LIST_IDX(list_idx); 08080 } 08081 08082 if (exp_desc->foldable) { 08083 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 08084 OPND_IDX((*result_opnd)) = comp_idx; 08085 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 08086 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 08087 exp_desc->type_idx = CN_TYPE_IDX(comp_idx); 08088 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 08089 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 08090 } 08091 08092 08093 TRACE (Func_Exit, "max_opr_handler", NULL); 08094 08095 return(ok); 08096 08097 } /* max_opr_handler */ 08098 08099 /******************************************************************************\ 08100 |* *| 08101 |* Description: *| 08102 |* semantic handler for the Struct_Opr. *| 08103 |* *| 08104 |* Input parameters: *| 08105 |* NONE *| 08106 |* *| 08107 |* Output parameters: *| 08108 |* NONE *| 08109 |* *| 08110 |* Returns: *| 08111 |* NOTHING *| 08112 |* *| 08113 \******************************************************************************/ 08114 08115 static boolean struct_opr_handler(opnd_type *result_opnd, 08116 expr_arg_type *exp_desc, 08117 int rank_in) 08118 08119 { 08120 expr_arg_type exp_desc_l; 08121 expr_arg_type exp_desc_r; 08122 boolean final_component = FALSE; 08123 int ir_idx; 08124 boolean ok = TRUE; 08125 opnd_type opnd; 08126 boolean save_in_call_list; 08127 boolean save_insert_subs_ok; 08128 08129 # ifdef _TARGET_OS_MAX 08130 int col; 08131 int line; 08132 # endif 08133 08134 TRACE (Func_Entry, "struct_opr_handler" , NULL); 08135 08136 ir_idx = OPND_IDX((*result_opnd)); 08137 # ifdef _TARGET_OS_MAX 08138 col = IR_COL_NUM(ir_idx); 08139 col = IR_LINE_NUM(ir_idx); 08140 # endif 08141 save_in_call_list = in_call_list; 08142 in_call_list = FALSE; 08143 08144 if (! in_component_ref) { 08145 final_component = TRUE; 08146 in_component_ref = TRUE; 08147 } 08148 08149 save_insert_subs_ok = insert_subs_ok; 08150 08151 insert_subs_ok = TRUE; 08152 08153 exp_desc_l.rank = rank_in; 08154 08155 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 08156 ok = expr_sem(&opnd, &exp_desc_l); 08157 COPY_OPND(IR_OPND_L(ir_idx), opnd); 08158 08159 if (OPND_FLD(opnd) == IR_Tbl_Idx && 08160 (IR_OPR(OPND_IDX(opnd)) == Substring_Opr || 08161 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr)) { 08162 08163 /* this only happens for variable size function results */ 08164 /* where the struct base is a dummy arg, the actual is */ 08165 /* a char sequence dt and it has been transformed into a */ 08166 /* substring. Remove the substring. */ 08167 08168 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(OPND_IDX(opnd))); 08169 } 08170 08171 in_call_list = save_in_call_list; 08172 08173 exp_desc_r.rank = exp_desc_l.rank; 08174 08175 insert_subs_ok = FALSE; 08176 08177 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 08178 ok &= expr_sem(&opnd, &exp_desc_r); 08179 COPY_OPND(IR_OPND_R(ir_idx), opnd); 08180 08181 insert_subs_ok = save_insert_subs_ok; 08182 08183 exp_desc->has_constructor = exp_desc_l.has_constructor || 08184 exp_desc_r.has_constructor; 08185 08186 exp_desc->has_symbolic = exp_desc_l.has_symbolic || exp_desc_r.has_symbolic; 08187 08188 if (final_component) { 08189 in_component_ref = FALSE; 08190 08191 if ((cif_flags & XREF_RECS) != 0 && 08192 xref_state != CIF_No_Usage_Rec) { 08193 08194 if (in_call_list) { 08195 /* output CIF_Symbol_Is_Actual_Arg */ 08196 cif_usage_rec(ir_idx, IR_Tbl_Idx, IR_LINE_NUM(ir_idx), 08197 IR_COL_NUM(ir_idx), 08198 CIF_Symbol_Is_Actual_Arg); 08199 } 08200 else { 08201 /* output according xref_state */ 08202 cif_usage_rec(ir_idx, IR_Tbl_Idx, IR_LINE_NUM(ir_idx), 08203 IR_COL_NUM(ir_idx), 08204 xref_state); 08205 } 08206 } 08207 } 08208 08209 if (insert_subs_ok) { 08210 08211 if (exp_desc_l.rank > exp_desc_r.rank) { 08212 exp_desc->rank = exp_desc_l.rank; 08213 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape, 08214 exp_desc_l.rank); 08215 } 08216 else { 08217 exp_desc->rank = exp_desc_r.rank; 08218 COPY_SHAPE(exp_desc->shape,exp_desc_r.shape, 08219 exp_desc_r.rank); 08220 } 08221 } 08222 else { 08223 exp_desc->rank = exp_desc_l.rank; 08224 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape, exp_desc_l.rank); 08225 } 08226 08227 08228 exp_desc->type = exp_desc_r.type; 08229 exp_desc->linear_type = exp_desc_r.linear_type; 08230 exp_desc->type_idx = exp_desc_r.type_idx; 08231 COPY_OPND(exp_desc->char_len, exp_desc_r.char_len); 08232 exp_desc->constant = exp_desc_l.constant; 08233 exp_desc->foldable = exp_desc_l.foldable; 08234 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 08235 08236 08237 /* pointer on right means pointer ... */ 08238 exp_desc->pointer = exp_desc_r.pointer; 08239 08240 /* pointer or target on left means target */ 08241 exp_desc->target = exp_desc_l.target || 08242 exp_desc_r.target || 08243 exp_desc_l.pointer; 08244 08245 exp_desc->vector_subscript = exp_desc_l.vector_subscript; 08246 exp_desc->reference = exp_desc_l.reference; 08247 exp_desc->pe_dim_ref = exp_desc_l.pe_dim_ref; 08248 COPY_OPND((exp_desc->bias_opnd), (exp_desc_l.bias_opnd)); 08249 exp_desc->component = TRUE; 08250 08251 /* if left has any rank at all it must be treated as */ 08252 /* a section. */ 08253 exp_desc->section = (exp_desc_l.rank > 0); 08254 exp_desc->array_elt = exp_desc_l.array_elt; 08255 exp_desc->assumed_shape = exp_desc_l.assumed_shape; 08256 exp_desc->assumed_size = exp_desc_l.assumed_size; 08257 exp_desc->contig_array = exp_desc_r.contig_array; 08258 exp_desc->dist_reshape_ref = exp_desc_l.dist_reshape_ref | 08259 exp_desc_r.dist_reshape_ref; 08260 08261 exp_desc->dope_vector = exp_desc_r.dope_vector; 08262 08263 if (exp_desc_r.dope_vector && 08264 ! no_sub_or_deref) { 08265 COPY_OPND((*result_opnd), IR_OPND_R(ir_idx)); 08266 COPY_OPND(IR_OPND_R(ir_idx), 08267 IR_OPND_L(OPND_IDX((*result_opnd)))); 08268 IR_FLD_L(OPND_IDX((*result_opnd))) = IR_Tbl_Idx; 08269 IR_IDX_L(OPND_IDX((*result_opnd))) = ir_idx; 08270 08271 IR_TYPE_IDX(OPND_IDX((*result_opnd))) = exp_desc->type_idx; 08272 08273 /* DO SET IR_RANK HERE TO THE PROPER RANK OF THE STRUCT OPR */ 08274 08275 IR_RANK(OPND_IDX((*result_opnd))) = exp_desc->rank; 08276 } 08277 08278 # if defined(COARRAY_FORTRAN) 08279 if (exp_desc->pe_dim_ref) { 08280 08281 # ifdef _TARGET_OS_MAX 08282 if (final_component && 08283 storage_bit_size_tbl[exp_desc->linear_type] != 64) { 08284 08285 find_opnd_line_and_column(&IR_OPND_R(ir_idx), &line, &col); 08286 PRINTMSG(line, 1585, Error, col); 08287 ok = FALSE; 08288 } 08289 # endif 08290 08291 if (exp_desc_r.dope_vector) { 08292 08293 # ifdef _TARGET_OS_MAX 08294 translate_t3e_dv_component(result_opnd, exp_desc); 08295 # else 08296 translate_dv_component(result_opnd, exp_desc); 08297 # endif 08298 } 08299 } 08300 # endif 08301 08302 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 08303 IR_RANK(ir_idx) = exp_desc->rank; 08304 08305 if (insert_subs_ok && 08306 ! no_sub_or_deref) { 08307 08308 if (exp_desc_r.rank > 0 && exp_desc_l.rank > 0) { 08309 08310 PRINTMSG(IR_LINE_NUM_R(ir_idx), 127, Error, 08311 IR_COL_NUM_R(ir_idx)); 08312 ok = FALSE; 08313 } 08314 08315 if (ATD_ARRAY_IDX(IR_IDX_R(ir_idx))) { 08316 08317 ok &= gen_whole_subscript(result_opnd, exp_desc); 08318 } 08319 else if (exp_desc->type == Character) { 08320 ok &= gen_whole_substring(result_opnd, exp_desc->rank); 08321 } 08322 } 08323 08324 08325 TRACE (Func_Exit, "struct_opr_handler", NULL); 08326 08327 return(ok); 08328 08329 } /* struct_opr_handler */ 08330 08331 /******************************************************************************\ 08332 |* *| 08333 |* Description: *| 08334 |* semantic handler for the Struct_Construct_Opr and *| 08335 |* Constant_Struct_Construct_Opr. *| 08336 |* *| 08337 |* Input parameters: *| 08338 |* NONE *| 08339 |* *| 08340 |* Output parameters: *| 08341 |* NONE *| 08342 |* *| 08343 |* Returns: *| 08344 |* NOTHING *| 08345 |* *| 08346 \******************************************************************************/ 08347 08348 static boolean struct_construct_opr_handler(opnd_type *result_opnd, 08349 expr_arg_type *exp_desc) 08350 08351 { 08352 int col; 08353 int comp_idx; 08354 boolean depends_on_outer_impdo; 08355 expr_arg_type exp_desc_l; 08356 expr_arg_type exp_desc_r; 08357 int i; 08358 int ir_idx; 08359 int line; 08360 int list_idx; 08361 char l_err_word[40]; 08362 boolean ok = TRUE; 08363 opnd_type opnd; 08364 opnd_type dv_opnd; 08365 int opnd_col; 08366 int opnd_line; 08367 char r_err_word[40]; 08368 int save_constructor_level; 08369 boolean save_defer_stmt_expansion; 08370 boolean defer_stmt_expansion_save; 08371 expr_mode_type save_expr_mode; 08372 boolean save_in_call_list; 08373 boolean save_io_item_must_flatten; 08374 int sn_idx; 08375 boolean top_constructor = FALSE; 08376 int type_idx; 08377 int tmp_dv_idx; 08378 08379 08380 TRACE (Func_Entry, "struct_construct_opr_handler" , NULL); 08381 08382 ir_idx = OPND_IDX((*result_opnd)); 08383 line = IR_LINE_NUM(ir_idx); 08384 col = IR_COL_NUM(ir_idx); 08385 save_io_item_must_flatten = io_item_must_flatten; 08386 save_in_call_list = in_call_list; /* BRIANJ set but not used */ 08387 in_call_list = FALSE; 08388 08389 save_expr_mode = expr_mode; 08390 expr_mode = Regular_Expr; 08391 08392 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 08393 08394 pgm_unit_illegal = FALSE; 08395 exp_desc_l.rank = 0; 08396 ok = expr_sem(&opnd, &exp_desc_l); 08397 pgm_unit_illegal = TRUE; 08398 expr_mode = save_expr_mode; 08399 08400 COPY_OPND(IR_OPND_L(ir_idx), opnd); 08401 08402 if (AT_OBJ_CLASS(OPND_IDX(opnd)) == Derived_Type) { 08403 08404 08405 /* expr_sem for the derived_type found a problem or */ 08406 /* AT_DCL_ERR is set for this derived_type. Either way */ 08407 /* it is not a valid attribute for a derived_type, so it */ 08408 /* cannot be used to get a structure constructor. */ 08409 08410 if (!ok) { 08411 goto EXIT; 08412 } 08413 08414 if (AT_USE_ASSOCIATED(OPND_IDX(opnd)) && 08415 ATT_PRIVATE_CPNT(OPND_IDX(opnd))) { 08416 find_opnd_line_and_column(&opnd, 08417 &opnd_line, 08418 &opnd_col); 08419 PRINTMSG(opnd_line, 883, Error, opnd_col, 08420 AT_OBJ_NAME_PTR(OPND_IDX(opnd))); 08421 08422 ok = FALSE; 08423 goto EXIT; 08424 } 08425 08426 /* still have structure constructor */ 08427 08428 save_defer_stmt_expansion = defer_stmt_expansion; 08429 save_constructor_level = constructor_level; 08430 08431 constructor_level++; 08432 08433 if (! in_constructor) { 08434 in_constructor = TRUE; 08435 top_constructor = TRUE; 08436 defer_stmt_expansion = TRUE; 08437 } 08438 08439 exp_desc->rank = 0; 08440 exp_desc->type = Structure; 08441 exp_desc->linear_type = Structure_Type; 08442 08443 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 08444 TYP_TYPE(TYP_WORK_IDX) = Structure; 08445 TYP_LINEAR(TYP_WORK_IDX) = Structure_Type; 08446 TYP_IDX(TYP_WORK_IDX) = OPND_IDX(opnd); 08447 exp_desc->type_idx = ntr_type_tbl(); 08448 08449 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 08450 IR_RANK(ir_idx) = exp_desc->rank; 08451 08452 if (ATT_NUM_CPNTS(TYP_IDX(exp_desc->type_idx)) != 08453 IR_LIST_CNT_R(ir_idx)) { 08454 08455 /* error .. not the right number of components */ 08456 08457 ok = FALSE; 08458 PRINTMSG(line, 357, Error, col); 08459 goto EXIT; 08460 } 08461 08462 exp_desc->foldable = TRUE; 08463 exp_desc->will_fold_later = TRUE; 08464 08465 list_idx = IR_IDX_R(ir_idx); 08466 sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX(exp_desc->type_idx)); 08467 08468 for (i = 0; i < IR_LIST_CNT_R(ir_idx); i++) { 08469 exp_desc_r.rank = 0; 08470 08471 COPY_OPND(opnd, IL_OPND(list_idx)); 08472 ok &= expr_sem(&opnd, &exp_desc_r); 08473 COPY_OPND(IL_OPND(list_idx), opnd); 08474 08475 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 08476 08477 /* save exp_desc */ 08478 arg_info_list_base = arg_info_list_top; 08479 arg_info_list_top = arg_info_list_base + 1; 08480 08481 if (arg_info_list_top >= arg_info_list_size) { 08482 enlarge_info_list_table(); 08483 } 08484 08485 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top; 08486 arg_info_list[arg_info_list_top] = init_arg_info; 08487 arg_info_list[arg_info_list_top].ed = exp_desc_r; 08488 08489 exp_desc->has_symbolic |= exp_desc_r.has_symbolic; 08490 08491 comp_idx = SN_ATTR_IDX(sn_idx); 08492 exp_desc_l.type_idx = ATD_TYPE_IDX(comp_idx); 08493 exp_desc_l.linear_type = TYP_LINEAR(exp_desc_l.type_idx); 08494 exp_desc_l.type = TYP_TYPE(exp_desc_l.type_idx); 08495 08496 if (ASG_TYPE(exp_desc_l.linear_type, 08497 exp_desc_r.linear_type) == Err_Res) { 08498 08499 /* error .. can't make asg */ 08500 08501 if ((exp_desc_r.type == Typeless) && ATD_POINTER(comp_idx)) { 08502 /* We have the NULL() intrinsic */ 08503 } 08504 else { 08505 ok = FALSE; 08506 PRINTMSG(IR_LINE_NUM(ir_idx), 358, Error, 08507 IR_COL_NUM(ir_idx), i + 1); 08508 } 08509 } 08510 08511 if (ASG_EXTN(exp_desc_l.linear_type, 08512 exp_desc_r.linear_type) && 08513 (exp_desc_r.type == Character || 08514 exp_desc_r.linear_type == Short_Typeless_Const)) { 08515 find_opnd_line_and_column(&opnd, 08516 &opnd_line, 08517 &opnd_col); 08518 08519 if (exp_desc_r.type == Character) { 08520 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 08521 } 08522 08523 08524 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 08525 exp_desc_l.linear_type, 08526 opnd_line, 08527 opnd_col); 08528 08529 exp_desc_r.type_idx = exp_desc_l.linear_type; 08530 exp_desc_r.type = TYP_TYPE(exp_desc_l.linear_type); 08531 exp_desc_r.linear_type = exp_desc_l.linear_type; 08532 } 08533 08534 if ((ATD_ARRAY_IDX(comp_idx) == 0 && 08535 exp_desc_r.rank != 0) || 08536 (ATD_ARRAY_IDX(comp_idx) != 0 && 08537 exp_desc_r.rank != 0 && 08538 BD_RANK(ATD_ARRAY_IDX(comp_idx)) != exp_desc_r.rank)) { 08539 /* error .. rank doesn't match */ 08540 ok = FALSE; 08541 find_opnd_line_and_column(&opnd, 08542 &opnd_line, 08543 &opnd_col); 08544 PRINTMSG(opnd_line, 360, Error, opnd_col, i + 1); 08545 } 08546 08547 if (ATD_POINTER(comp_idx) && ok) { 08548 08549 if (OPND_FLD(opnd) == AT_Tbl_Idx) { 08550 08551 if (AT_OBJ_CLASS(OPND_IDX(opnd)) != Data_Obj || 08552 (!ATD_TARGET(OPND_IDX(opnd)) && 08553 !ATD_POINTER(OPND_IDX(opnd)))) { 08554 08555 ok = FALSE; 08556 find_opnd_line_and_column(&opnd, 08557 &opnd_line, 08558 &opnd_col); 08559 PRINTMSG(opnd_line, 359, Error, opnd_col); 08560 } 08561 } 08562 else if (OPND_FLD(opnd) == IR_Tbl_Idx) { 08563 08564 if (IR_OPR(OPND_IDX(opnd)) == Null_Intrinsic_Opr) { 08565 tmp_dv_idx = gen_compiler_tmp(line, 08566 col, 08567 Priv, 08568 TRUE); 08569 08570 ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(comp_idx); 08571 ATD_STOR_BLK_IDX(tmp_dv_idx) = 08572 SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 08573 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE; 08574 ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(comp_idx); 08575 ATD_POINTER(tmp_dv_idx) = TRUE; 08576 08577 gen_opnd(&dv_opnd, 08578 tmp_dv_idx, 08579 AT_Tbl_Idx, 08580 line, 08581 col); 08582 08583 defer_stmt_expansion_save = defer_stmt_expansion; 08584 defer_stmt_expansion = FALSE; 08585 gen_static_dv_whole_def(&dv_opnd, 08586 tmp_dv_idx, 08587 Before); 08588 08589 defer_stmt_expansion = defer_stmt_expansion_save; 08590 08591 exp_desc_r.type_idx = ATD_TYPE_IDX(comp_idx); 08592 exp_desc_r.type = TYP_TYPE(ATD_TYPE_IDX(comp_idx)); 08593 exp_desc_r.linear_type = TYP_LINEAR(ATD_TYPE_IDX(comp_idx)); 08594 exp_desc_r.pointer = TRUE; 08595 exp_desc_r.tmp_reference = TRUE; 08596 exp_desc_r.foldable = TRUE; 08597 exp_desc_r.will_fold_later = TRUE; 08598 08599 if (ATD_ARRAY_IDX(comp_idx) == NULL_IDX) { 08600 exp_desc_r.rank = 0; 08601 } 08602 else { 08603 exp_desc_r.rank = BD_RANK(ATD_ARRAY_IDX(comp_idx)); 08604 } 08605 08606 08607 gen_opnd(&dv_opnd, 08608 gen_ir(AT_Tbl_Idx, 08609 tmp_dv_idx, 08610 Dv_Deref_Opr, 08611 exp_desc_r.type_idx, 08612 line, 08613 col, 08614 NO_Tbl_Idx, 08615 NULL_IDX), 08616 IR_Tbl_Idx, 08617 line, 08618 col); 08619 08620 if (exp_desc_r.rank > 0) { 08621 ok = gen_whole_subscript(&dv_opnd, &exp_desc_r); 08622 } 08623 08624 COPY_OPND(opnd, dv_opnd); 08625 COPY_OPND(IL_OPND(list_idx), opnd); 08626 } 08627 else if (IR_OPR(OPND_IDX(opnd)) == Call_Opr) { 08628 08629 if (!ATD_POINTER(ATP_RSLT_IDX(IR_IDX_L( 08630 OPND_IDX(opnd))))) { 08631 ok = FALSE; 08632 find_opnd_line_and_column(&opnd, 08633 &opnd_line, 08634 &opnd_col); 08635 PRINTMSG(opnd_line, 359, Error, opnd_col); 08636 } 08637 } 08638 else if (exp_desc_r.reference || 08639 exp_desc_r.tmp_reference) { 08640 08641 if (! exp_desc_r.pointer && ! exp_desc_r.target) { 08642 ok = FALSE; 08643 find_opnd_line_and_column(&opnd, 08644 &opnd_line, 08645 &opnd_col); 08646 PRINTMSG(opnd_line, 359, Error, opnd_col); 08647 } 08648 else { 08649 if (exp_desc_r.rank != 0) { 08650 /* check for IL_VECTOR_SUBSCRIPT */ 08651 if (exp_desc_r.vector_subscript) { 08652 08653 find_opnd_line_and_column(&opnd, 08654 &opnd_line, 08655 &opnd_col); 08656 PRINTMSG(opnd_line, 420, Error, 08657 opnd_col); 08658 ok = FALSE; 08659 } 08660 } 08661 } 08662 } 08663 else { /* an expression other than a call .. error */ 08664 ok = FALSE; 08665 find_opnd_line_and_column(&opnd, 08666 &opnd_line, 08667 &opnd_col); 08668 PRINTMSG(opnd_line, 359, Error, opnd_col); 08669 } 08670 } 08671 else { 08672 /* error .. assuming only constants here */ 08673 ok = FALSE; 08674 find_opnd_line_and_column(&opnd, 08675 &opnd_line, 08676 &opnd_col); 08677 PRINTMSG(opnd_line, 359, Error, opnd_col); 08678 } 08679 08680 if (ok && 08681 (ATD_ARRAY_IDX(comp_idx) ? 08682 BD_RANK(ATD_ARRAY_IDX(comp_idx)) : 0) != 08683 exp_desc_r.rank) { 08684 08685 ok = FALSE; 08686 find_opnd_line_and_column(&opnd, 08687 &opnd_line, 08688 &opnd_col); 08689 PRINTMSG(opnd_line, 431, Error, opnd_col); 08690 } 08691 08692 type_idx = ATD_TYPE_IDX(comp_idx); 08693 08694 if (ok && 08695 (TYP_TYPE(type_idx) != exp_desc_r.type || 08696 (TYP_TYPE(type_idx) == Structure && 08697 !compare_derived_types(type_idx, 08698 exp_desc_r.type_idx)))) { 08699 08700 r_err_word[0] = '\0'; 08701 l_err_word[0] = '\0'; 08702 08703 strcat(l_err_word, get_basic_type_str(type_idx)); 08704 08705 strcat(r_err_word, 08706 get_basic_type_str(exp_desc_r.type_idx)); 08707 08708 find_opnd_line_and_column(&opnd, 08709 &opnd_line, 08710 &opnd_col); 08711 08712 PRINTMSG(opnd_line, 432, Error, opnd_col, 08713 r_err_word, 08714 l_err_word); 08715 ok = FALSE; 08716 08717 } 08718 08719 if (ok && 08720 TYP_TYPE(type_idx) != Character && 08721 TYP_TYPE(type_idx) != Structure && 08722 TYP_LINEAR(type_idx) != exp_desc_r.linear_type) { 08723 08724 find_opnd_line_and_column(&opnd, 08725 &opnd_line, 08726 &opnd_col); 08727 08728 PRINTMSG(opnd_line, 419, Error, opnd_col); 08729 ok = FALSE; 08730 } 08731 08732 if (ok && 08733 TYP_TYPE(type_idx) == Character && 08734 TYP_FLD(type_idx) == CN_Tbl_Idx && 08735 exp_desc_r.char_len.fld == CN_Tbl_Idx && 08736 fold_relationals(TYP_IDX(type_idx), 08737 exp_desc_r.char_len.idx, Ne_Opr)) { 08738 08739 ok = FALSE; 08740 find_opnd_line_and_column(&opnd, 08741 &opnd_line, 08742 &opnd_col); 08743 PRINTMSG(opnd_line, 853, Error, opnd_col); 08744 } 08745 } 08746 08747 exp_desc->foldable = exp_desc->foldable && exp_desc_r.foldable; 08748 08749 exp_desc->will_fold_later &= (exp_desc_r.will_fold_later || 08750 exp_desc_r.foldable); 08751 08752 sn_idx = SN_SIBLING_LINK(sn_idx); 08753 list_idx = IL_NEXT_LIST_IDX(list_idx); 08754 } 08755 08756 defer_stmt_expansion = save_defer_stmt_expansion; 08757 08758 depends_on_outer_impdo = FALSE; 08759 08760 if (constructor_level > save_constructor_level) { 08761 constructor_level = save_constructor_level; 08762 08763 if (exp_desc->foldable || 08764 exp_desc->will_fold_later) { 08765 08766 IR_OPR(ir_idx) = Constant_Struct_Construct_Opr; 08767 } 08768 } 08769 else if (top_constructor) { 08770 depends_on_outer_impdo = TRUE; 08771 exp_desc->will_fold_later |= exp_desc->foldable; 08772 exp_desc->foldable = FALSE; 08773 } 08774 08775 if (! top_constructor) { 08776 exp_desc->has_constructor = TRUE; 08777 } 08778 08779 if (top_constructor && 08780 ! no_func_expansion && 08781 ok) { 08782 08783 if (exp_desc->foldable || 08784 exp_desc->will_fold_later) { 08785 08786 if (depends_on_outer_impdo) { 08787 /* intentionally blank */ 08788 } 08789 else if (expr_mode == Initialization_Expr) { 08790 exp_desc->foldable = TRUE; 08791 } 08792 else if (! create_constructor_constant(result_opnd, exp_desc)) { 08793 ok = FALSE; 08794 } 08795 } 08796 else { 08797 08798 ok = create_runtime_struct_constructor(result_opnd); 08799 08800 exp_desc->tmp_reference = TRUE; 08801 } 08802 } 08803 08804 if (top_constructor) { 08805 in_constructor = FALSE; 08806 } 08807 08808 io_item_must_flatten = save_io_item_must_flatten; 08809 } 08810 else if (AT_OBJ_CLASS(OPND_IDX(opnd)) == Pgm_Unit) { 08811 08812 /* change to function call */ 08813 IR_OPR(ir_idx) = Call_Opr; 08814 ok = expr_sem(result_opnd, exp_desc); 08815 } 08816 else { 08817 /* error .. shouldn't be here */ 08818 PRINTMSG(line, 975, Internal, col); 08819 } 08820 08821 EXIT: 08822 08823 TRACE (Func_Exit, "struct_construct_opr_handler", NULL); 08824 08825 return(ok); 08826 08827 } /* struct_construct_opr_handler */ 08828 08829 /******************************************************************************\ 08830 |* *| 08831 |* Description: *| 08832 |* semantic handler for the Array_Construct_Opr and *| 08833 |* Constant_Array_Construct_Opr. *| 08834 |* *| 08835 |* Input parameters: *| 08836 |* NONE *| 08837 |* *| 08838 |* Output parameters: *| 08839 |* NONE *| 08840 |* *| 08841 |* Returns: *| 08842 |* NOTHING *| 08843 |* *| 08844 \******************************************************************************/ 08845 08846 static boolean array_construct_opr_handler(opnd_type *result_opnd, 08847 expr_arg_type *exp_desc) 08848 08849 { 08850 size_level_type constructor_size_level; 08851 boolean depends_on_outer_impdo; 08852 int depth; 08853 int ir_idx; 08854 expr_arg_type loc_exp_desc; 08855 boolean ok = TRUE; 08856 opnd_type opnd; 08857 int save_constructor_level; 08858 boolean save_defer_stmt_expansion; 08859 boolean save_in_call_list; 08860 boolean save_io_item_must_flatten; 08861 opnd_type size_opnd; 08862 boolean top_constructor = FALSE; 08863 08864 08865 TRACE (Func_Entry, "array_construct_opr_handler" , NULL); 08866 08867 ir_idx = OPND_IDX((*result_opnd)); 08868 save_io_item_must_flatten = io_item_must_flatten; 08869 save_in_call_list = in_call_list; /* BRIANJ - Set but not used. */ 08870 in_call_list = FALSE; 08871 08872 save_defer_stmt_expansion = defer_stmt_expansion; 08873 save_constructor_level = constructor_level; 08874 constructor_level++; 08875 08876 if (! in_constructor) { 08877 top_constructor = TRUE; 08878 in_constructor = TRUE; 08879 defer_stmt_expansion = TRUE; 08880 } 08881 08882 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 08883 ok = array_construct_semantics(&opnd, exp_desc); 08884 COPY_OPND(IR_OPND_R(ir_idx), opnd); 08885 08886 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 08887 exp_desc->rank = 1; 08888 defer_stmt_expansion = save_defer_stmt_expansion; 08889 08890 depends_on_outer_impdo = FALSE; 08891 08892 if (constructor_level > save_constructor_level) { 08893 constructor_level = save_constructor_level; 08894 08895 if (exp_desc->foldable || 08896 exp_desc->will_fold_later) { 08897 08898 IR_OPR(ir_idx) = Constant_Array_Construct_Opr; 08899 } 08900 } 08901 else if (top_constructor) { 08902 depends_on_outer_impdo = TRUE; 08903 exp_desc->will_fold_later |= exp_desc->foldable; 08904 exp_desc->foldable = FALSE; 08905 } 08906 08907 if (top_constructor && 08908 ok) { 08909 08910 COPY_OPND(opnd, (*result_opnd)); 08911 constructor_size_level = Simple_Expr_Size; 08912 analyse_loops(&opnd, &size_opnd, &constructor_size_level); 08913 08914 if (constructor_size_level == Simple_Expr_Size) { 08915 ok &= expr_semantics(&size_opnd, &loc_exp_desc); 08916 } 08917 08918 # if 0 08919 # ifdef _DEBUG 08920 switch (OPND_FLD(size_opnd)) { 08921 case CN_Tbl_Idx: 08922 print_cn(OPND_IDX(size_opnd)); 08923 break; 08924 case IR_Tbl_Idx: 08925 print_ir(OPND_IDX(size_opnd)); 08926 break; 08927 case AT_Tbl_Idx: 08928 print_at_all(OPND_IDX(size_opnd)); 08929 break; 08930 } 08931 # endif 08932 # endif 08933 08934 COPY_OPND((exp_desc->shape[0]), size_opnd); 08935 exp_desc->constructor_size_level = constructor_size_level; 08936 08937 if (exp_desc->foldable || 08938 exp_desc->will_fold_later) { 08939 08940 switch (stmt_type) { 08941 case Allocate_Stmt : 08942 case Arith_If_Stmt : 08943 case Assignment_Stmt : 08944 case Backspace_Stmt : 08945 case Buffer_Stmt : 08946 case Call_Stmt : 08947 case Case_Stmt : 08948 case Close_Stmt : 08949 case Deallocate_Stmt : 08950 case Decode_Stmt : 08951 case Do_Iterative_Stmt : 08952 case Do_While_Stmt : 08953 case Do_Infinite_Stmt : 08954 case Else_If_Stmt : 08955 case Else_Where_Stmt : 08956 case Encode_Stmt : 08957 case Endfile_Stmt : 08958 case If_Cstrct_Stmt : 08959 case If_Stmt : 08960 case Inquire_Stmt : 08961 case Nullify_Stmt : 08962 case Open_Stmt : 08963 case Outmoded_If_Stmt : 08964 case Print_Stmt : 08965 case Read_Stmt : 08966 case Rewind_Stmt : 08967 case Select_Stmt : 08968 case Where_Cstrct_Stmt : 08969 case Where_Stmt : 08970 case Write_Stmt : 08971 /* These stmt types do not require a folded constructor */ 08972 /* so see if this should be a runtime constructor. */ 08973 08974 if (constructor_size_level == Simple_Expr_Size) { 08975 08976 /* if bigger than 5,000 elements, make it runtime */ 08977 08978 if (OPND_FLD(size_opnd) == CN_Tbl_Idx && 08979 compare_cn_and_value(OPND_IDX(size_opnd), 08980 5000, 08981 Gt_Opr)) { 08982 08983 exp_desc->will_fold_later = FALSE; 08984 exp_desc->foldable = FALSE; 08985 IR_OPR(ir_idx) = Array_Construct_Opr; 08986 } 08987 } 08988 else if (constructor_size_level == Interp_Loop_Size) { 08989 08990 depth = implied_do_depth(&size_opnd); 08991 08992 /* if more than 2 nested implied do's, make it runtime */ 08993 08994 if (depth > 2) { 08995 exp_desc->will_fold_later = FALSE; 08996 exp_desc->foldable = FALSE; 08997 IR_OPR(ir_idx) = Array_Construct_Opr; 08998 } 08999 else if (outer_imp_do_count(&size_opnd) > 50) { 09000 exp_desc->will_fold_later = FALSE; 09001 exp_desc->foldable = FALSE; 09002 IR_OPR(ir_idx) = Array_Construct_Opr; 09003 } 09004 } 09005 break; 09006 } 09007 } 09008 } 09009 09010 if (top_constructor && 09011 ! no_func_expansion && 09012 ok) { 09013 09014 if (exp_desc->foldable || 09015 exp_desc->will_fold_later) { 09016 09017 if (depends_on_outer_impdo) { 09018 /* intentionally blank */ 09019 } 09020 else if (expr_mode == Initialization_Expr) { 09021 exp_desc->foldable = TRUE; 09022 } 09023 else if (! create_constructor_constant(result_opnd, exp_desc)) { 09024 ok = FALSE; 09025 } 09026 } 09027 else { 09028 /* ok = create_runtime_array_constructor(result_opnd, exp_desc);*/ 09029 /* keep source-level array constructor??fzhao */ 09030 ok =TRUE; 09031 09032 } 09033 } 09034 09035 if (! top_constructor) { 09036 09037 exp_desc->has_constructor = TRUE; 09038 09039 /* save exp_desc */ 09040 arg_info_list_base = arg_info_list_top; 09041 arg_info_list_top = arg_info_list_base + 1; 09042 09043 if (arg_info_list_top >= arg_info_list_size) { 09044 enlarge_info_list_table(); 09045 } 09046 09047 IR_IDX_L(ir_idx) = arg_info_list_top; 09048 arg_info_list[arg_info_list_top] = init_arg_info; 09049 arg_info_list[arg_info_list_top].ed = *exp_desc; 09050 09051 } 09052 09053 if (top_constructor) { 09054 in_constructor = FALSE; 09055 } 09056 09057 io_item_must_flatten = save_io_item_must_flatten; 09058 09059 TRACE (Func_Exit, "array_construct_opr_handler", NULL); 09060 09061 return(ok); 09062 09063 } /* array_construct_opr_handler */ 09064 09065 /******************************************************************************\ 09066 |* *| 09067 |* Description: *| 09068 |* semantic handler for the Whole_Subscript_Opr, Section_Subscript_Opr, *| 09069 |* and Subscript_Opr. *| 09070 |* *| 09071 |* Input parameters: *| 09072 |* NONE *| 09073 |* *| 09074 |* Output parameters: *| 09075 |* NONE *| 09076 |* *| 09077 |* Returns: *| 09078 |* NOTHING *| 09079 |* *| 09080 \******************************************************************************/ 09081 09082 static boolean subscript_opr_handler(opnd_type *result_opnd, 09083 expr_arg_type *exp_desc, 09084 int rank_in) 09085 09086 { 09087 09088 enum section_value { 09089 Full_Section, 09090 Part_Section, 09091 Element, 09092 Vector_Section 09093 }; 09094 09095 typedef enum section_value section_type; 09096 09097 int allocatable_pointee_idx = NULL_IDX; 09098 section_type contig_state; 09099 section_type curr_section; 09100 boolean lb_default; 09101 boolean ub_default; 09102 boolean st_default; 09103 int attr_idx; 09104 int bd_idx; 09105 int col; 09106 int dv_idx; 09107 opnd_type dv_opnd; 09108 expr_arg_type exp_desc_l; 09109 expr_arg_type exp_desc_r; 09110 int host_attr_idx; 09111 int i; 09112 int ir_idx; 09113 int line; 09114 int listp_idx; 09115 int list_idx; 09116 int list2_idx; 09117 int num_dims; 09118 int minus_idx; 09119 boolean ok = TRUE; 09120 opnd_type opnd; 09121 opnd_type opnd2; 09122 int opnd_col; 09123 int opnd_line; 09124 int pe_dim_list_idx = NULL_IDX; 09125 int plus_idx; 09126 expr_mode_type save_expr_mode; 09127 boolean save_insert_subs_ok; 09128 boolean save_in_call_list; 09129 boolean save_in_component_ref; 09130 boolean save_in_implied_do; 09131 cif_usage_code_type save_xref_state; 09132 09133 # if defined(COARRAY_FORTRAN)/* && defined(_TARGET_OS_MAX)May */ 09134 int save_pe_dv_list_idx = NULL_IDX; 09135 # endif 09136 09137 09138 TRACE (Func_Entry, "subscript_opr_handler" , NULL); 09139 09140 ir_idx = OPND_IDX((*result_opnd)); 09141 line = IR_LINE_NUM(ir_idx); 09142 col = IR_COL_NUM(ir_idx); 09143 09144 exp_desc_l.rank = rank_in; 09145 09146 save_in_implied_do = in_implied_do; 09147 09148 if (IR_FLD_L(ir_idx) == AT_Tbl_Idx) { 09149 in_implied_do = FALSE; 09150 } 09151 09152 # if defined(COARRAY_FORTRAN) 09153 attr_idx = find_base_attr(&(IR_OPND_L(ir_idx)), &line, &col); 09154 host_attr_idx = attr_idx; 09155 09156 while (AT_ATTR_LINK(host_attr_idx) != NULL_IDX && 09157 ! AT_IGNORE_ATTR_LINK(host_attr_idx)) { 09158 09159 host_attr_idx = AT_ATTR_LINK(host_attr_idx); 09160 } 09161 09162 if (AT_OBJ_CLASS(host_attr_idx) == Data_Obj && 09163 ATD_CLASS(host_attr_idx) == Variable && 09164 host_attr_idx != attr_idx && 09165 ATD_PE_ARRAY_IDX(host_attr_idx) && 09166 ATD_ALLOCATABLE(host_attr_idx) && 09167 ATD_VARIABLE_TMP_IDX(host_attr_idx) != NULL_IDX) { 09168 09169 /* pointee must be in local scope, so use copy */ 09170 09171 ATD_CLASS(attr_idx) = Variable; 09172 09173 if (ATD_VARIABLE_TMP_IDX(attr_idx) == NULL_IDX) { 09174 /* get new pointee in local scope */ 09175 09176 allocatable_pointee_idx = gen_compiler_tmp(line, col, Shared, TRUE); 09177 09178 ATD_CLASS(allocatable_pointee_idx) = CRI__Pointee; 09179 AT_SEMANTICS_DONE(allocatable_pointee_idx) = TRUE; 09180 09181 ATD_TYPE_IDX(allocatable_pointee_idx) = 09182 ATD_TYPE_IDX(ATD_VARIABLE_TMP_IDX(host_attr_idx)); 09183 ATD_STOR_BLK_IDX(allocatable_pointee_idx) = 09184 SCP_SB_BASED_IDX(curr_scp_idx); 09185 09186 ATD_PTR_IDX(allocatable_pointee_idx) = 09187 ATD_PTR_IDX(ATD_VARIABLE_TMP_IDX(host_attr_idx)); 09188 ATD_ARRAY_IDX(allocatable_pointee_idx) = 09189 ATD_ARRAY_IDX(ATD_VARIABLE_TMP_IDX(host_attr_idx)); 09190 ATD_PE_ARRAY_IDX(allocatable_pointee_idx) = 09191 ATD_PE_ARRAY_IDX(ATD_VARIABLE_TMP_IDX(host_attr_idx)); 09192 09193 ATD_FLD(attr_idx) = AT_Tbl_Idx; 09194 ATD_VARIABLE_TMP_IDX(attr_idx) = allocatable_pointee_idx; 09195 09196 } 09197 else { 09198 allocatable_pointee_idx = ATD_VARIABLE_TMP_IDX(attr_idx); 09199 } 09200 } 09201 # endif 09202 09203 /* do not change in_call_list for array base (left side) */ 09204 09205 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 09206 save_insert_subs_ok = insert_subs_ok; 09207 insert_subs_ok = FALSE; 09208 pgm_unit_illegal = FALSE; 09209 ok = expr_sem(&opnd, &exp_desc_l); 09210 insert_subs_ok = TRUE; 09211 pgm_unit_illegal = TRUE; 09212 COPY_OPND(IR_OPND_L(ir_idx), opnd); 09213 09214 in_implied_do = save_in_implied_do; 09215 09216 exp_desc->has_constructor = exp_desc_l.has_constructor; 09217 09218 # if defined(COARRAY_FORTRAN) && defined(_TARGET_OS_MAX) 09219 if (exp_desc_l.pe_dim_ref && 09220 IR_FLD_L(ir_idx) == IR_Tbl_Idx && 09221 IR_OPR(IR_IDX_L(ir_idx)) == Subscript_Opr && 09222 IR_LIST_CNT_R(IR_IDX_L(ir_idx)) == 1 && 09223 IL_PE_SUBSCRIPT(IR_IDX_R(IR_IDX_L(ir_idx)))) { 09224 09225 /* save the pe subscript */ 09226 save_pe_dv_list_idx = IR_IDX_R(IR_IDX_L(ir_idx)); 09227 09228 plus_idx = IR_IDX_L(ir_idx); 09229 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx))); 09230 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 09231 FREE_IR_NODE(plus_idx); 09232 09233 } 09234 # endif 09235 09236 attr_idx = find_base_attr(&opnd, &line, &col); 09237 09238 if (attr_idx && 09239 AT_OBJ_CLASS(attr_idx) == Data_Obj) { 09240 09241 /* set in_call_list to false for right hand side */ 09242 09243 save_in_call_list = in_call_list; /* BRIANJ - Set but not used. */ 09244 in_call_list = FALSE; 09245 09246 bd_idx = ATD_ARRAY_IDX(attr_idx); 09247 09248 if (bd_idx && 09249 (BD_ARRAY_CLASS(bd_idx) == Explicit_Shape || 09250 BD_ARRAY_CLASS(bd_idx) == Deferred_Shape || 09251 BD_ARRAY_CLASS(bd_idx) == Assumed_Shape || 09252 BD_ARRAY_CLASS(bd_idx) == Assumed_Size)) { 09253 09254 for (i = 1; i <= BD_RANK(bd_idx); i++) { 09255 if (BD_LB_FLD(bd_idx,i) == AT_Tbl_Idx) { 09256 ADD_TMP_TO_SHARED_LIST(BD_LB_IDX(bd_idx,i)); 09257 } 09258 } 09259 } 09260 09261 # ifdef COARRAY_FORTRAN 09262 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX && 09263 ATD_PE_ARRAY_IDX(attr_idx) == NULL_IDX) 09264 # else 09265 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) 09266 # endif 09267 { 09268 PRINTMSG(line, 546, Internal, col); 09269 } 09270 09271 exp_desc->type = exp_desc_l.type; 09272 exp_desc->linear_type = exp_desc_l.linear_type; 09273 exp_desc->type_idx = exp_desc_l.type_idx; 09274 exp_desc->rank = 0; 09275 exp_desc->constant = exp_desc_l.constant; 09276 exp_desc->foldable = exp_desc_l.foldable; 09277 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 09278 exp_desc->reference = exp_desc_l.reference; 09279 exp_desc->pe_dim_ref = exp_desc_l.pe_dim_ref; 09280 COPY_OPND((exp_desc->bias_opnd), (exp_desc_l.bias_opnd)); 09281 exp_desc->cif_id = exp_desc_l.cif_id; 09282 exp_desc->component = exp_desc_l.component; 09283 exp_desc->dope_vector = exp_desc_l.dope_vector; 09284 exp_desc->vector_subscript = exp_desc_l.vector_subscript; 09285 exp_desc->section = exp_desc_l.section; 09286 exp_desc->has_symbolic= exp_desc_l.has_symbolic; 09287 09288 exp_desc->contig_array = exp_desc_l.contig_array; 09289 exp_desc->dist_reshape_ref = exp_desc_l.dist_reshape_ref; 09290 09291 COPY_OPND((exp_desc->char_len), (exp_desc_l.char_len)); 09292 09293 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx && 09294 IR_OPR(IR_IDX_L(ir_idx)) == Dv_Deref_Opr) { 09295 09296 COPY_OPND(dv_opnd, IR_OPND_L(IR_IDX_L(ir_idx))); 09297 } 09298 else { 09299 COPY_OPND(dv_opnd, IR_OPND_L(ir_idx)); 09300 } 09301 09302 copy_subtree(&dv_opnd, &dv_opnd); 09303 09304 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 09305 09306 list_idx = IR_IDX_R(ir_idx); 09307 num_dims = 0; 09308 09309 while (list_idx != NULL_IDX) { 09310 if (IL_PE_SUBSCRIPT(list_idx)) { 09311 pe_dim_list_idx = list_idx; 09312 break; 09313 } 09314 num_dims++; 09315 list_idx = IL_NEXT_LIST_IDX(list_idx); 09316 } 09317 09318 if (pe_dim_list_idx != NULL_IDX && 09319 num_dims == 0 && 09320 bd_idx != NULL_IDX) { 09321 /* have a whole array reference with pe dimensions. */ 09322 /* must generate a whole subscript opr */ 09323 09324 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 09325 ok &= gen_whole_subscript(&opnd, &exp_desc_l); 09326 09327 if (ok) { 09328 list_idx = IR_IDX_R(OPND_IDX(opnd)); 09329 09330 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 09331 if (IL_PE_SUBSCRIPT(IL_NEXT_LIST_IDX(list_idx))) { 09332 FREE_IR_NODE(IL_IDX(IL_NEXT_LIST_IDX(list_idx))); 09333 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(list_idx)); 09334 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 09335 IR_LIST_CNT_R(OPND_IDX(opnd)) -= 1; 09336 break; 09337 } 09338 list_idx = IL_NEXT_LIST_IDX(list_idx); 09339 } 09340 09341 num_dims = IR_LIST_CNT_R(OPND_IDX(opnd)); 09342 09343 IR_LIST_CNT_R(OPND_IDX(opnd)) += IR_LIST_CNT_R(ir_idx); 09344 IL_NEXT_LIST_IDX(list_idx) = pe_dim_list_idx; 09345 IL_PREV_LIST_IDX(pe_dim_list_idx) = list_idx; 09346 COPY_OPND((*result_opnd), opnd); 09347 ir_idx = OPND_IDX(opnd); 09348 } 09349 } 09350 09351 if (ok && 09352 ATD_PE_ARRAY_IDX(attr_idx) && 09353 ATD_ALLOCATABLE(attr_idx) && 09354 ATD_VARIABLE_TMP_IDX(attr_idx) != NULL_IDX && 09355 pe_dim_list_idx != NULL_IDX) { 09356 09357 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 09358 09359 if (allocatable_pointee_idx != NULL_IDX) { 09360 IR_IDX_L(ir_idx) = allocatable_pointee_idx; 09361 } 09362 else { 09363 IR_IDX_L(ir_idx) = ATD_VARIABLE_TMP_IDX(attr_idx); 09364 } 09365 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 09366 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 09367 09368 attr_idx = IR_IDX_L(ir_idx); 09369 bd_idx = ATD_ARRAY_IDX(attr_idx); 09370 09371 exp_desc_l.dope_vector = FALSE; 09372 exp_desc->dope_vector = exp_desc_l.dope_vector; 09373 } 09374 09375 if (IR_OPR(ir_idx) == Whole_Subscript_Opr) { 09376 exp_desc->pointer = exp_desc_l.pointer; 09377 exp_desc->target = exp_desc_l.target; 09378 } 09379 else { 09380 exp_desc->target = exp_desc_l.target || 09381 exp_desc_l.pointer; 09382 } 09383 09384 if (BD_RANK(bd_idx) < num_dims) { 09385 ok = FALSE; 09386 PRINTMSG(line, 204, Error, col); 09387 } 09388 else if (IR_LIST_CNT_R(ir_idx) == 0) { 09389 ok = FALSE; 09390 PRINTMSG(line, 393, Error, col); 09391 } 09392 else { 09393 09394 save_expr_mode = expr_mode; 09395 09396 if (expr_mode == Data_Stmt_Target) { 09397 expr_mode = Data_Stmt_Target_Expr; 09398 } 09399 else if (expr_mode == Restricted_Imp_Do_Target) { 09400 expr_mode = Restricted_Imp_Do_Expr; 09401 } 09402 09403 /* process subscripts */ 09404 listp_idx = NULL_IDX; 09405 list_idx = IR_IDX_R(ir_idx); 09406 09407 save_xref_state = xref_state; 09408 09409 if (xref_state != CIF_No_Usage_Rec) { 09410 xref_state = CIF_Symbol_Reference; 09411 } 09412 save_in_component_ref = in_component_ref; 09413 in_component_ref = FALSE; 09414 09415 contig_state = Full_Section; 09416 09417 for (i = 1; i <= num_dims; i++) { 09418 09419 curr_section = Full_Section; 09420 09421 exp_desc_r.rank = 0; 09422 09423 COPY_OPND(opnd, IL_OPND(list_idx)); 09424 ok &= expr_sem(&opnd, &exp_desc_r); 09425 COPY_OPND(IL_OPND(list_idx), opnd); 09426 09427 exp_desc->has_symbolic |= exp_desc_r.has_symbolic; 09428 exp_desc->has_constructor |= exp_desc_r.has_constructor; 09429 exp_desc->foldable &= exp_desc_r.foldable; 09430 09431 exp_desc->will_fold_later &= (exp_desc_r.will_fold_later || 09432 exp_desc_r.foldable); 09433 09434 IL_CONSTANT_SUBSCRIPT(list_idx) = exp_desc_r.foldable; 09435 09436 if (exp_desc_r.rank == 0) { 09437 curr_section = Element; 09438 } 09439 09440 if (exp_desc_r.linear_type == Long_Typeless) { 09441 find_opnd_line_and_column((opnd_type *) 09442 &IL_OPND(list_idx), 09443 &opnd_line, 09444 &opnd_col); 09445 PRINTMSG(opnd_line, 1133, Error, opnd_col); 09446 ok = FALSE; 09447 } 09448 else if (exp_desc_r.type != Integer && 09449 exp_desc_r.type != Typeless && 09450 exp_desc_r.rank == 0) { 09451 09452 find_opnd_line_and_column((opnd_type *) 09453 &IL_OPND(list_idx), 09454 &opnd_line, 09455 &opnd_col); 09456 PRINTMSG(opnd_line, 319, Error, opnd_col); 09457 ok = FALSE; 09458 } 09459 else if (exp_desc_r.rank == 1 && 09460 (exp_desc_r.type == Integer || 09461 exp_desc_r.type == Typeless)) { 09462 09463 (exp_desc->rank)++; 09464 09465 if (IL_FLD(list_idx) == IR_Tbl_Idx && 09466 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) { 09467 09468 exp_desc->section = TRUE; 09469 09470 list2_idx = IR_IDX_L(IL_IDX(list_idx)); 09471 09472 if (IL_FLD(list2_idx) == NO_Tbl_Idx) { 09473 /* fill in lower bound */ 09474 09475 lb_default = TRUE; 09476 09477 if (exp_desc_l.dope_vector) { 09478 gen_dv_access_low_bound(&opnd2, &dv_opnd, i); 09479 COPY_OPND(IL_OPND(list2_idx), opnd2); 09480 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 09481 09482 if (OPND_FLD(opnd2) != CN_Tbl_Idx) { 09483 exp_desc->foldable = FALSE; 09484 exp_desc->will_fold_later = FALSE; 09485 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = FALSE; 09486 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) = FALSE; 09487 } 09488 } 09489 else { 09490 IL_FLD(list2_idx) = BD_LB_FLD(bd_idx, i); 09491 IL_IDX(list2_idx) = BD_LB_IDX(bd_idx, i); 09492 IL_LINE_NUM(list2_idx) = IR_LINE_NUM(IL_IDX(list_idx)); 09493 IL_COL_NUM(list2_idx) = IR_COL_NUM(IL_IDX(list_idx)); 09494 09495 if (IL_FLD(list2_idx) == AT_Tbl_Idx) { 09496 ADD_TMP_TO_SHARED_LIST(IL_IDX(list2_idx)); 09497 } 09498 09499 if (IL_FLD(list2_idx) != CN_Tbl_Idx) { 09500 exp_desc->foldable = FALSE; 09501 exp_desc->will_fold_later = FALSE; 09502 09503 /* assumes that this is an AT_Tbl_Idx */ 09504 exp_desc_r.type_idx = 09505 ATD_TYPE_IDX(IL_IDX(list2_idx)); 09506 exp_desc_r.type = TYP_TYPE(exp_desc_r.type_idx); 09507 exp_desc_r.linear_type = 09508 TYP_LINEAR(exp_desc_r.type_idx); 09509 SHAPE_FOLDABLE(IL_OPND(list2_idx)) 09510 = FALSE; 09511 SHAPE_WILL_FOLD_LATER( 09512 IL_OPND(list2_idx)) = FALSE; 09513 } 09514 else { 09515 SHAPE_FOLDABLE(IL_OPND(list2_idx)) 09516 = TRUE; 09517 SHAPE_WILL_FOLD_LATER( 09518 IL_OPND(list2_idx)) = TRUE; 09519 exp_desc_r.type_idx = CN_TYPE_IDX(IL_IDX(list2_idx)); 09520 exp_desc_r.type = TYP_TYPE(exp_desc_r.type_idx); 09521 exp_desc_r.linear_type = 09522 TYP_LINEAR(exp_desc_r.type_idx); 09523 } 09524 09525 if (in_io_list) { 09526 09527 /* on mpp, must cast shorts to longs in io lists */ 09528 /* on solaris, must cast Integer_8 to Integer_4 */ 09529 09530 COPY_OPND(opnd2, IL_OPND(list2_idx)); 09531 cast_to_cg_default(&opnd2, &exp_desc_r); 09532 COPY_OPND(IL_OPND(list2_idx), opnd2); 09533 } 09534 09535 09536 /* assume that lower bound is constant */ 09537 /* should be in temp. */ 09538 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 09539 } 09540 } 09541 else if (IL_FLD(list2_idx) == CN_Tbl_Idx && 09542 BD_ARRAY_CLASS(bd_idx) == Explicit_Shape && 09543 BD_LB_FLD(bd_idx, i) == CN_Tbl_Idx && 09544 fold_relationals(IL_IDX(list2_idx), 09545 BD_LB_IDX(bd_idx, i), 09546 Eq_Opr)) { 09547 lb_default = TRUE; 09548 } 09549 else { 09550 lb_default = FALSE; 09551 } 09552 09553 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 09554 09555 if (IL_FLD(list2_idx) == NO_Tbl_Idx) { 09556 09557 ub_default = TRUE; 09558 09559 if (i == BD_RANK(bd_idx) && 09560 BD_ARRAY_CLASS(bd_idx) == Assumed_Size) { 09561 09562 PRINTMSG(IR_LINE_NUM(IL_IDX(list_idx)), 09563 321,Error, 09564 IR_COL_NUM(IL_IDX(list_idx))); 09565 ok = FALSE; 09566 } 09567 else if (exp_desc_l.dope_vector) { 09568 09569 gen_dv_access_low_bound(&opnd2, &dv_opnd, i); 09570 09571 dv_idx = gen_ir(OPND_FLD(dv_opnd), OPND_IDX(dv_opnd), 09572 Dv_Access_Extent,SA_INTEGER_DEFAULT_TYPE,line,col, 09573 NO_Tbl_Idx, NULL_IDX); 09574 09575 IR_DV_DIM(dv_idx) = i; 09576 09577 plus_idx = gen_ir(OPND_FLD(opnd2), OPND_IDX(opnd2), 09578 Plus_Opr,SA_INTEGER_DEFAULT_TYPE,line,col, 09579 IR_Tbl_Idx, dv_idx); 09580 09581 minus_idx = gen_ir(IR_Tbl_Idx, plus_idx, 09582 Minus_Opr,SA_INTEGER_DEFAULT_TYPE,line,col, 09583 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 09584 09585 IL_FLD(list2_idx) = IR_Tbl_Idx; 09586 IL_IDX(list2_idx) = minus_idx; 09587 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 09588 exp_desc->foldable = FALSE; 09589 exp_desc->will_fold_later = FALSE; 09590 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = FALSE; 09591 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) = FALSE; 09592 } 09593 else { 09594 /* fill in upper bound */ 09595 IL_FLD(list2_idx) = BD_UB_FLD(bd_idx, i); 09596 IL_IDX(list2_idx) = BD_UB_IDX(bd_idx, i); 09597 IL_LINE_NUM(list2_idx) = IR_LINE_NUM(IL_IDX(list_idx)); 09598 IL_COL_NUM(list2_idx) = IR_COL_NUM(IL_IDX(list_idx)); 09599 09600 if (IL_FLD(list2_idx) == AT_Tbl_Idx) { 09601 ADD_TMP_TO_SHARED_LIST(IL_IDX(list2_idx)); 09602 } 09603 09604 if (IL_FLD(list2_idx) != CN_Tbl_Idx) { 09605 exp_desc->foldable = FALSE; 09606 exp_desc->will_fold_later = FALSE; 09607 /* assumes that this is an AT_Tbl_Idx */ 09608 exp_desc_r.type_idx = 09609 ATD_TYPE_IDX(IL_IDX(list2_idx)); 09610 exp_desc_r.type = TYP_TYPE(exp_desc_r.type_idx); 09611 exp_desc_r.linear_type = 09612 TYP_LINEAR(exp_desc_r.type_idx); 09613 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = FALSE; 09614 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) = FALSE; 09615 } 09616 else { 09617 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = TRUE; 09618 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) = TRUE; 09619 exp_desc_r.type_idx = CN_TYPE_IDX(IL_IDX(list2_idx)); 09620 exp_desc_r.type = TYP_TYPE(exp_desc_r.type_idx); 09621 exp_desc_r.linear_type = 09622 TYP_LINEAR(exp_desc_r.type_idx); 09623 } 09624 09625 if (in_io_list) { 09626 09627 /* on mpp, must cast shorts to longs in io lists */ 09628 /* on solaris, must cast Integer_8 to Integer_4 */ 09629 09630 COPY_OPND(opnd2, IL_OPND(list2_idx)); 09631 cast_to_cg_default(&opnd2, &exp_desc_r); 09632 COPY_OPND(IL_OPND(list2_idx), opnd2); 09633 } 09634 09635 /* assume that upper bound is constant */ 09636 /* should be in temp. */ 09637 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 09638 } 09639 } 09640 else if (IL_FLD(list2_idx) == CN_Tbl_Idx && 09641 BD_ARRAY_CLASS(bd_idx) == Explicit_Shape && 09642 BD_UB_FLD(bd_idx, i) == CN_Tbl_Idx && 09643 fold_relationals(IL_IDX(list2_idx), 09644 BD_UB_IDX(bd_idx, i), 09645 Eq_Opr)) { 09646 ub_default = TRUE; 09647 } 09648 else { 09649 ub_default = FALSE; 09650 } 09651 09652 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 09653 09654 st_default = FALSE; 09655 09656 if (IL_FLD(list2_idx) == NO_Tbl_Idx) { 09657 09658 st_default = TRUE; 09659 09660 /* fill in stride = 1 */ 09661 IL_FLD(list2_idx) = CN_Tbl_Idx; 09662 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX; 09663 IL_LINE_NUM(list2_idx) = IR_LINE_NUM(IL_IDX(list_idx)); 09664 IL_COL_NUM(list2_idx) = IR_COL_NUM(IL_IDX(list_idx)); 09665 09666 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 09667 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = TRUE; 09668 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) = TRUE; 09669 } 09670 else if (IL_FLD(list2_idx) == CN_Tbl_Idx && 09671 compare_cn_and_value(IL_IDX(list2_idx), 0, Eq_Opr)) { 09672 09673 /* zero stride is illegal */ 09674 PRINTMSG(IL_LINE_NUM(list2_idx), 1001, Error, 09675 IL_COL_NUM(list2_idx)); 09676 ok = FALSE; 09677 } 09678 else if (IL_FLD(list2_idx) == CN_Tbl_Idx && 09679 compare_cn_and_value(IL_IDX(list2_idx), 1, Eq_Opr)) { 09680 st_default = TRUE; 09681 } 09682 09683 if (lb_default && 09684 ub_default && 09685 st_default) { 09686 curr_section = Full_Section; 09687 } 09688 else if (st_default) { 09689 curr_section = Part_Section; 09690 } 09691 else { 09692 exp_desc->contig_array = FALSE; 09693 } 09694 09695 if (ok) { 09696 make_triplet_extent_tree(&opnd, 09697 IR_IDX_L(IL_IDX(list_idx))); 09698 COPY_OPND(exp_desc->shape[exp_desc->rank - 1], opnd); 09699 } 09700 } 09701 else { 09702 /* have vector subscript */ 09703 IL_VECTOR_SUBSCRIPT(list_idx) = TRUE; 09704 exp_desc->vector_subscript = TRUE; 09705 COPY_OPND(exp_desc->shape[exp_desc->rank - 1], 09706 exp_desc_r.shape[0]); 09707 curr_section = Vector_Section; 09708 } 09709 } 09710 else if (exp_desc_r.rank > 1 || 09711 (exp_desc_r.type != Integer && 09712 exp_desc_r.type != Typeless)) { 09713 09714 /* error .. vector subscript must be rank 1 integer */ 09715 09716 find_opnd_line_and_column((opnd_type *) 09717 &IL_OPND(list_idx), 09718 &opnd_line, 09719 &opnd_col); 09720 PRINTMSG(opnd_line, 320, Error, opnd_col); 09721 ok = FALSE; 09722 } 09723 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 09724 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 09725 &opnd_line, 09726 &opnd_col); 09727 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 09728 INTEGER_DEFAULT_TYPE, 09729 opnd_line, 09730 opnd_col); 09731 exp_desc_r.type_idx = INTEGER_DEFAULT_TYPE; 09732 exp_desc_r.type = Integer; 09733 exp_desc_r.linear_type = INTEGER_DEFAULT_TYPE; 09734 } 09735 09736 09737 if (in_io_list) { 09738 09739 /* on mpp, must cast shorts to longs in io lists */ 09740 /* on solaris, must cast Integer_8 to Integer_4 */ 09741 09742 if (IL_FLD(list_idx) == IR_Tbl_Idx && 09743 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) { 09744 09745 /* intentionally blank, handled in triplet_opr_handler */ 09746 } 09747 else { 09748 COPY_OPND(opnd, IL_OPND(list_idx)); 09749 cast_to_cg_default(&opnd, &exp_desc_r); 09750 COPY_OPND(IL_OPND(list_idx), opnd); 09751 } 09752 } 09753 09754 if (curr_section == Vector_Section) { 09755 exp_desc->contig_array = FALSE; 09756 } 09757 else if (contig_state == Full_Section) { 09758 09759 if (curr_section == Part_Section) { 09760 contig_state = Part_Section; 09761 } 09762 else if (curr_section == Element) { 09763 contig_state = Element; 09764 } 09765 } 09766 else if (contig_state == Part_Section) { 09767 if (curr_section == Full_Section || 09768 curr_section == Part_Section) { 09769 exp_desc->contig_array = FALSE; 09770 } 09771 else if (curr_section == Element) { 09772 contig_state = Element; 09773 } 09774 } 09775 else if (contig_state == Element) { 09776 if (curr_section != Element) { 09777 exp_desc->contig_array = FALSE; 09778 } 09779 } 09780 09781 listp_idx = list_idx; 09782 list_idx = IL_NEXT_LIST_IDX(list_idx); 09783 } 09784 09785 expr_mode = save_expr_mode; 09786 xref_state = save_xref_state; 09787 in_component_ref = save_in_component_ref; 09788 09789 if (exp_desc->rank > 0) { 09790 IR_OPR(ir_idx) = Section_Subscript_Opr; 09791 } 09792 else { 09793 exp_desc->contig_array = FALSE; 09794 } 09795 09796 if (exp_desc_l.rank > 0 && 09797 IR_FLD_L(ir_idx) == IR_Tbl_Idx && 09798 (IR_OPR(IR_IDX_L(ir_idx)) == Struct_Opr || 09799 IR_FLD_L(IR_IDX_L(ir_idx)) == IR_Tbl_Idx)) { 09800 /* the subtree to left has non-zero rank */ 09801 09802 if (exp_desc->rank > 0) { 09803 PRINTMSG(IR_LINE_NUM(ir_idx), 127, Error, 09804 IR_COL_NUM(ir_idx)); 09805 ok = FALSE; 09806 } 09807 else { 09808 exp_desc->rank = exp_desc_l.rank; 09809 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape, 09810 exp_desc_l.rank); 09811 } 09812 } 09813 09814 if (! dump_flags.no_dimension_padding && 09815 BD_RANK(bd_idx) > num_dims) { 09816 09817 ATP_HAS_OVER_INDEXING(SCP_ATTR_IDX(curr_scp_idx)) = TRUE; 09818 09819 /* warn about fewer subscripts */ 09820 PRINTMSG(line, 375, Warning, col); 09821 09822 /* issue ansi msg for fewer subscripts */ 09823 PRINTMSG(line, 376, Ansi, col); 09824 09825 for (i = num_dims + 1; 09826 i <= BD_RANK(bd_idx); i++) { 09827 NTR_IR_LIST_TBL(list_idx); 09828 IL_PREV_LIST_IDX(list_idx) = listp_idx; 09829 IL_NEXT_LIST_IDX(list_idx) = IL_NEXT_LIST_IDX(listp_idx); 09830 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09831 IL_NEXT_LIST_IDX(listp_idx) = list_idx; 09832 09833 IR_LIST_CNT_R(ir_idx) += 1; 09834 09835 if (exp_desc_l.dope_vector) { 09836 gen_dv_access_low_bound(&opnd2, &dv_opnd, i); 09837 COPY_OPND(IL_OPND(list_idx), opnd2); 09838 IL_CONSTANT_SUBSCRIPT(list_idx) = TRUE; 09839 09840 if (OPND_FLD(opnd2) != CN_Tbl_Idx) { 09841 exp_desc->foldable = FALSE; 09842 exp_desc->will_fold_later = FALSE; 09843 SHAPE_FOLDABLE(IL_OPND(list_idx)) = FALSE; 09844 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = FALSE; 09845 } 09846 } 09847 else { 09848 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 09849 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 09850 IL_LINE_NUM(list_idx) = line; 09851 IL_COL_NUM(list_idx) = col; 09852 09853 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 09854 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 09855 } 09856 09857 if (IL_FLD(list_idx) != CN_Tbl_Idx) { 09858 exp_desc->foldable = FALSE; 09859 exp_desc->will_fold_later = FALSE; 09860 SHAPE_FOLDABLE(IL_OPND(list_idx)) = FALSE; 09861 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = FALSE; 09862 } 09863 else { 09864 SHAPE_FOLDABLE(IL_OPND(list_idx)) = TRUE; 09865 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = TRUE; 09866 } 09867 09868 09869 /* assume that lower bound is constant */ 09870 /* should be in temp. */ 09871 IL_CONSTANT_SUBSCRIPT(list_idx) = TRUE; 09872 } 09873 09874 listp_idx = list_idx; 09875 } 09876 } 09877 09878 #ifdef COARRAY_FORTRAN 09879 bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 09880 09881 if (bd_idx && 09882 pe_dim_list_idx != NULL_IDX) { 09883 09884 # if 0 09885 /* don't add pe dimensions for local reference. */ 09886 09887 if (pe_dim_list_idx == NULL_IDX) { 09888 /* no pe dimensions specified. */ 09889 09890 list_idx = IR_IDX_R(ir_idx); 09891 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 09892 list_idx = IL_NEXT_LIST_IDX(list_idx); 09893 } 09894 09895 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09896 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09897 list_idx = IL_NEXT_LIST_IDX(list_idx); 09898 IR_LIST_CNT_R(ir_idx) += 1; 09899 09900 IL_FLD(list_idx) = IR_Tbl_Idx; 09901 09902 NTR_IR_TBL(plus_idx); 09903 IR_OPR(plus_idx) = Local_Pe_Dim_Opr; 09904 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 09905 IR_LINE_NUM(plus_idx) = line; 09906 IR_COL_NUM(plus_idx) = col; 09907 IL_IDX(list_idx) = plus_idx; 09908 } 09909 # endif 09910 09911 num_dims = 0; 09912 list_idx = pe_dim_list_idx; 09913 09914 while (list_idx != NULL_IDX) { 09915 09916 num_dims++; 09917 list_idx = IL_NEXT_LIST_IDX(list_idx); 09918 } 09919 09920 if (BD_RANK(bd_idx) < num_dims) { 09921 ok = FALSE; 09922 PRINTMSG(line, 204, Error, col); 09923 } 09924 else { 09925 09926 save_expr_mode = expr_mode; 09927 09928 if (expr_mode == Data_Stmt_Target) { 09929 expr_mode = Data_Stmt_Target_Expr; 09930 } 09931 else if (expr_mode == Restricted_Imp_Do_Target) { 09932 expr_mode = Restricted_Imp_Do_Expr; 09933 } 09934 09935 /* process subscripts */ 09936 list_idx = pe_dim_list_idx; 09937 listp_idx = IL_PREV_LIST_IDX(list_idx); 09938 09939 save_xref_state = xref_state; 09940 09941 if (xref_state != CIF_No_Usage_Rec) { 09942 xref_state = CIF_Symbol_Reference; 09943 } 09944 save_in_component_ref = in_component_ref; 09945 in_component_ref = FALSE; 09946 09947 for (i = 1; i <= num_dims; i++) { 09948 09949 exp_desc_r.rank = 0; 09950 09951 COPY_OPND(opnd, IL_OPND(list_idx)); 09952 ok &= expr_sem(&opnd, &exp_desc_r); 09953 COPY_OPND(IL_OPND(list_idx), opnd); 09954 09955 exp_desc->has_symbolic |= exp_desc_r.has_symbolic; 09956 exp_desc->has_constructor |= exp_desc_r.has_constructor; 09957 exp_desc->foldable &= exp_desc_r.foldable; 09958 09959 exp_desc->will_fold_later &= (exp_desc_r.will_fold_later || 09960 exp_desc_r.foldable); 09961 09962 IL_CONSTANT_SUBSCRIPT(list_idx) = exp_desc_r.foldable; 09963 09964 if (exp_desc_r.linear_type == Long_Typeless) { 09965 find_opnd_line_and_column((opnd_type *) 09966 &IL_OPND(list_idx), 09967 &opnd_line, 09968 &opnd_col); 09969 PRINTMSG(opnd_line, 1133, Error, opnd_col); 09970 ok = FALSE; 09971 } 09972 else if (exp_desc_r.type != Integer && 09973 exp_desc_r.type != Typeless && 09974 exp_desc_r.rank == 0) { 09975 09976 find_opnd_line_and_column((opnd_type *) 09977 &IL_OPND(list_idx), 09978 &opnd_line, 09979 &opnd_col); 09980 PRINTMSG(opnd_line, 319, Error, opnd_col); 09981 ok = FALSE; 09982 } 09983 else if (exp_desc_r.rank == 1 && 09984 (exp_desc_r.type == Integer || 09985 exp_desc_r.type == Typeless)) { 09986 09987 (exp_desc->rank)++; 09988 09989 # if 0 09990 find_opnd_line_and_column((opnd_type *) 09991 &IL_OPND(list_idx), 09992 &opnd_line, 09993 &opnd_col); 09994 PRINTMSG(opnd_line, 1583, Error, opnd_col, 09995 "array syntax", "co-array variables"); 09996 ok = FALSE; 09997 09998 # else 09999 10000 if (IL_FLD(list_idx) == IR_Tbl_Idx && 10001 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) { 10002 10003 exp_desc->section = TRUE; 10004 10005 list2_idx = IR_IDX_L(IL_IDX(list_idx)); 10006 10007 if (IL_FLD(list2_idx) == NO_Tbl_Idx) { 10008 /* fill in lower bound */ 10009 10010 IL_FLD(list2_idx) = BD_LB_FLD(bd_idx, i); 10011 IL_IDX(list2_idx) = BD_LB_IDX(bd_idx, i); 10012 IL_LINE_NUM(list2_idx) = 10013 IR_LINE_NUM(IL_IDX(list_idx)); 10014 IL_COL_NUM(list2_idx) = 10015 IR_COL_NUM(IL_IDX(list_idx)); 10016 10017 if (IL_FLD(list2_idx) == AT_Tbl_Idx) { 10018 ADD_TMP_TO_SHARED_LIST(IL_IDX(list2_idx)); 10019 } 10020 10021 if (IL_FLD(list2_idx) != CN_Tbl_Idx) { 10022 exp_desc->foldable = FALSE; 10023 exp_desc->will_fold_later = FALSE; 10024 10025 /* assumes that this is an AT_Tbl_Idx */ 10026 exp_desc_r.type_idx = 10027 ATD_TYPE_IDX(IL_IDX(list2_idx)); 10028 exp_desc_r.type=TYP_TYPE(exp_desc_r.type_idx); 10029 exp_desc_r.linear_type = 10030 TYP_LINEAR(exp_desc_r.type_idx); 10031 SHAPE_FOLDABLE(IL_OPND(list2_idx)) 10032 = FALSE; 10033 SHAPE_WILL_FOLD_LATER( 10034 IL_OPND(list2_idx)) = FALSE; 10035 } 10036 else { 10037 SHAPE_FOLDABLE(IL_OPND(list2_idx)) 10038 = TRUE; 10039 SHAPE_WILL_FOLD_LATER( 10040 IL_OPND(list2_idx)) = TRUE; 10041 exp_desc_r.type_idx = 10042 CN_TYPE_IDX(IL_IDX(list2_idx)); 10043 exp_desc_r.type=TYP_TYPE(exp_desc_r.type_idx); 10044 exp_desc_r.linear_type = 10045 TYP_LINEAR(exp_desc_r.type_idx); 10046 } 10047 10048 /* assume that lower bound is constant */ 10049 /* should be in temp. */ 10050 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 10051 } 10052 10053 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 10054 10055 if (IL_FLD(list2_idx) == NO_Tbl_Idx) { 10056 10057 if (i == BD_RANK(bd_idx) && 10058 BD_ARRAY_CLASS(bd_idx) == Assumed_Size) { 10059 10060 PRINTMSG(IR_LINE_NUM(IL_IDX(list_idx)), 10061 321,Error, 10062 IR_COL_NUM(IL_IDX(list_idx))); 10063 ok = FALSE; 10064 } 10065 10066 /* fill in upper bound */ 10067 IL_FLD(list2_idx) = BD_UB_FLD(bd_idx, i); 10068 IL_IDX(list2_idx) = BD_UB_IDX(bd_idx, i); 10069 IL_LINE_NUM(list2_idx) = 10070 IR_LINE_NUM(IL_IDX(list_idx)); 10071 IL_COL_NUM(list2_idx) = 10072 IR_COL_NUM(IL_IDX(list_idx)); 10073 10074 if (IL_FLD(list2_idx) == AT_Tbl_Idx) { 10075 ADD_TMP_TO_SHARED_LIST(IL_IDX(list2_idx)); 10076 } 10077 10078 if (IL_FLD(list2_idx) != CN_Tbl_Idx) { 10079 exp_desc->foldable = FALSE; 10080 exp_desc->will_fold_later = FALSE; 10081 /* assumes that this is an AT_Tbl_Idx */ 10082 exp_desc_r.type_idx = 10083 ATD_TYPE_IDX(IL_IDX(list2_idx)); 10084 exp_desc_r.type=TYP_TYPE(exp_desc_r.type_idx); 10085 exp_desc_r.linear_type = 10086 TYP_LINEAR(exp_desc_r.type_idx); 10087 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = FALSE; 10088 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) 10089 = FALSE; 10090 } 10091 else { 10092 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = TRUE; 10093 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) 10094 = TRUE; 10095 exp_desc_r.type_idx = 10096 CN_TYPE_IDX(IL_IDX(list2_idx)); 10097 exp_desc_r.type=TYP_TYPE(exp_desc_r.type_idx); 10098 exp_desc_r.linear_type = 10099 TYP_LINEAR(exp_desc_r.type_idx); 10100 } 10101 10102 /* assume that upper bound is constant */ 10103 /* should be in temp. */ 10104 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 10105 } 10106 10107 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 10108 10109 if (IL_FLD(list2_idx) == NO_Tbl_Idx) { 10110 10111 /* fill in stride = 1 */ 10112 IL_FLD(list2_idx) = CN_Tbl_Idx; 10113 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX; 10114 IL_LINE_NUM(list2_idx) = 10115 IR_LINE_NUM(IL_IDX(list_idx)); 10116 IL_COL_NUM(list2_idx) = 10117 IR_COL_NUM(IL_IDX(list_idx)); 10118 10119 IL_CONSTANT_SUBSCRIPT(list2_idx) = TRUE; 10120 SHAPE_FOLDABLE(IL_OPND(list2_idx)) = TRUE; 10121 SHAPE_WILL_FOLD_LATER(IL_OPND(list2_idx)) = TRUE; 10122 } 10123 else if (IL_FLD(list2_idx) == CN_Tbl_Idx && 10124 compare_cn_and_value(IL_IDX(list2_idx), 10125 0, Eq_Opr)) { 10126 10127 /* zero stride is illegal */ 10128 PRINTMSG(IL_LINE_NUM(list2_idx), 1001, Error, 10129 IL_COL_NUM(list2_idx)); 10130 ok = FALSE; 10131 } 10132 10133 if (ok) { 10134 make_triplet_extent_tree(&opnd, 10135 IR_IDX_L(IL_IDX(list_idx))); 10136 COPY_OPND(exp_desc->shape[exp_desc->rank - 1], 10137 opnd); 10138 } 10139 } 10140 else { 10141 /* have vector subscript */ 10142 IL_VECTOR_SUBSCRIPT(list_idx) = TRUE; 10143 exp_desc->vector_subscript = TRUE; 10144 COPY_OPND(exp_desc->shape[exp_desc->rank - 1], 10145 exp_desc_r.shape[0]); 10146 } 10147 # endif 10148 } 10149 else if (exp_desc_r.rank > 1 || 10150 (exp_desc_r.type != Integer && 10151 exp_desc_r.type != Typeless)) { 10152 10153 /* error .. vector subscript must be rank 1 integer */ 10154 10155 find_opnd_line_and_column((opnd_type *) 10156 &IL_OPND(list_idx), 10157 &opnd_line, 10158 &opnd_col); 10159 PRINTMSG(opnd_line, 320, Error, opnd_col); 10160 ok = FALSE; 10161 } 10162 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 10163 find_opnd_line_and_column( 10164 (opnd_type *) &IL_OPND(list_idx), 10165 &opnd_line, 10166 &opnd_col); 10167 IL_IDX(list_idx) = 10168 cast_typeless_constant(IL_IDX(list_idx), 10169 INTEGER_DEFAULT_TYPE, 10170 opnd_line, 10171 opnd_col); 10172 exp_desc_r.type_idx = INTEGER_DEFAULT_TYPE; 10173 exp_desc_r.type = Integer; 10174 exp_desc_r.linear_type = INTEGER_DEFAULT_TYPE; 10175 } 10176 10177 listp_idx = list_idx; 10178 list_idx = IL_NEXT_LIST_IDX(list_idx); 10179 } 10180 10181 expr_mode = save_expr_mode; 10182 xref_state = save_xref_state; 10183 in_component_ref = save_in_component_ref; 10184 10185 if (exp_desc->rank > 0) { 10186 IR_OPR(ir_idx) = Section_Subscript_Opr; 10187 } 10188 10189 if (! dump_flags.no_dimension_padding && 10190 BD_RANK(bd_idx) > num_dims) { 10191 10192 ATP_HAS_OVER_INDEXING(SCP_ATTR_IDX(curr_scp_idx)) = TRUE; 10193 10194 /* warn about fewer subscripts */ 10195 PRINTMSG(line, 375, Warning, col); 10196 10197 /* issue ansi msg for fewer subscripts */ 10198 PRINTMSG(line, 376, Ansi, col); 10199 10200 for (i = num_dims + 1; 10201 i <= BD_RANK(bd_idx); i++) { 10202 10203 NTR_IR_LIST_TBL(list_idx); 10204 IL_PREV_LIST_IDX(list_idx) = listp_idx; 10205 IL_NEXT_LIST_IDX(list_idx)=IL_NEXT_LIST_IDX(listp_idx); 10206 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10207 IL_NEXT_LIST_IDX(listp_idx) = list_idx; 10208 10209 IR_LIST_CNT_R(ir_idx) += 1; 10210 10211 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 10212 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 10213 IL_LINE_NUM(list_idx) = line; 10214 IL_COL_NUM(list_idx) = col; 10215 10216 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 10217 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 10218 } 10219 10220 if (IL_FLD(list_idx) != CN_Tbl_Idx) { 10221 exp_desc->foldable = FALSE; 10222 exp_desc->will_fold_later = FALSE; 10223 SHAPE_FOLDABLE(IL_OPND(list_idx)) = FALSE; 10224 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = FALSE; 10225 } 10226 else { 10227 SHAPE_FOLDABLE(IL_OPND(list_idx)) = TRUE; 10228 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = TRUE; 10229 } 10230 10231 10232 /* assume that lower bound is constant */ 10233 /* should be in temp. */ 10234 IL_CONSTANT_SUBSCRIPT(list_idx) = TRUE; 10235 10236 listp_idx = list_idx; 10237 } /* for */ 10238 } 10239 } 10240 } 10241 # endif 10242 10243 /* set accumulated rank on ir */ 10244 IR_RANK(ir_idx) = exp_desc->rank; 10245 10246 if (exp_desc->rank == 0 && 10247 !exp_desc_l.pointer && 10248 !exp_desc_l.assumed_shape) { 10249 exp_desc->array_elt = TRUE; 10250 } 10251 10252 if (ok) { 10253 ok = check_array_bounds(ir_idx); 10254 } 10255 # if defined(COARRAY_FORTRAN) 10256 /* May# if defined(_TARGET_OS_MAX) */ 10257 if ( save_pe_dv_list_idx != NULL_IDX) { 10258 10259 /* add the pe subscript to ir_idx */ 10260 list_idx = IR_IDX_R(ir_idx); 10261 10262 while (IL_NEXT_LIST_IDX(list_idx)) { 10263 list_idx = IL_NEXT_LIST_IDX(list_idx); 10264 } 10265 10266 IL_NEXT_LIST_IDX(list_idx) = save_pe_dv_list_idx; 10267 IL_PREV_LIST_IDX(save_pe_dv_list_idx) = list_idx; 10268 IR_LIST_CNT_R(ir_idx) += 1; 10269 } else 10270 /* May# endif */ 10271 if (ok && 10272 ATD_PE_ARRAY_IDX(attr_idx)) { 10273 10274 if (pe_dim_list_idx != NULL_IDX) { 10275 10276 /* translate_distant_ref(result_opnd, exp_desc, pe_dim_list_idx); May*/ 10277 } 10278 # if defined(_TARGET_OS_MAX) 10279 else if (! ATD_ALLOCATABLE(attr_idx)) { 10280 /* supply mype() as pe dim */ 10281 10282 list_idx = IR_IDX_R(ir_idx); 10283 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 10284 list_idx = IL_NEXT_LIST_IDX(list_idx); 10285 } 10286 10287 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 10288 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10289 list_idx = IL_NEXT_LIST_IDX(list_idx); 10290 IR_LIST_CNT_R(ir_idx) += 1; 10291 10292 NTR_IR_TBL(plus_idx); 10293 IR_OPR(plus_idx) = My_Pe_Opr; 10294 IR_TYPE_IDX(plus_idx) = INTEGER_DEFAULT_TYPE; 10295 IR_LINE_NUM(plus_idx) = IR_LINE_NUM(ir_idx); 10296 IR_COL_NUM(plus_idx) = IR_COL_NUM(ir_idx); 10297 10298 IL_FLD(list_idx) = IR_Tbl_Idx; 10299 IL_IDX(list_idx) = plus_idx; 10300 10301 IL_PE_SUBSCRIPT(list_idx) = TRUE; 10302 io_item_must_flatten = TRUE; 10303 } 10304 # endif 10305 } 10306 # endif 10307 10308 /* insert substring if allowed */ 10309 10310 if (ok && 10311 save_insert_subs_ok && 10312 ! no_sub_or_deref && 10313 exp_desc->type == Character) { 10314 10315 ok = gen_whole_substring(result_opnd, exp_desc->rank); 10316 } 10317 } 10318 } /* if array */ 10319 else if (IR_FLD_L(ir_idx) == AT_Tbl_Idx && 10320 AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Pgm_Unit) { 10321 10322 IR_OPR(ir_idx) = Call_Opr; 10323 10324 ok = expr_sem(result_opnd, exp_desc); 10325 } 10326 else { 10327 /* some sort of internal error */ 10328 PRINTMSG(line, 975, Internal, col); 10329 } 10330 10331 TRACE (Func_Exit, "subscript_opr_handler", NULL); 10332 10333 return(ok); 10334 10335 } /* subscript_opr_handler */ 10336 10337 /******************************************************************************\ 10338 |* *| 10339 |* Description: *| 10340 |* semantic handler for the Whole_Substring_Opr and Substring_Opr. *| 10341 |* *| 10342 |* Input parameters: *| 10343 |* NONE *| 10344 |* *| 10345 |* Output parameters: *| 10346 |* NONE *| 10347 |* *| 10348 |* Returns: *| 10349 |* NOTHING *| 10350 |* *| 10351 \******************************************************************************/ 10352 10353 static boolean substring_opr_handler(opnd_type *result_opnd, 10354 expr_arg_type *exp_desc, 10355 int rank_in) 10356 10357 { 10358 int attr_idx; 10359 char *char_ptr1; 10360 char *char_ptr2; 10361 int clen_idx; 10362 int col; 10363 expr_arg_type exp_desc_l; 10364 expr_arg_type exp_desc_r; 10365 int i; 10366 int ir_idx; 10367 int line; 10368 int list_idx; 10369 boolean ok = TRUE; 10370 opnd_type opnd; 10371 int opnd_col; 10372 int opnd_line; 10373 boolean save_defer_stmt_expansion; 10374 expr_mode_type save_expr_mode; 10375 boolean save_in_component_ref; 10376 int save_number_of_functions; 10377 cif_usage_code_type save_xref_state; 10378 int tmp_idx; 10379 int type_idx; 10380 10381 10382 TRACE (Func_Entry, "substring_opr_handler" , NULL); 10383 10384 ir_idx = OPND_IDX((*result_opnd)); 10385 line = IR_LINE_NUM(ir_idx); 10386 col = IR_COL_NUM(ir_idx); 10387 10388 exp_desc_l.rank = rank_in; 10389 10390 /* do not change in_call_list for the left hand side */ 10391 10392 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 10393 insert_subs_ok = FALSE; 10394 ok = expr_sem(&opnd, &exp_desc_l); 10395 insert_subs_ok = TRUE; 10396 COPY_OPND(IR_OPND_L(ir_idx), opnd); 10397 10398 /* set in_call_list to false for right hand side */ 10399 in_call_list = FALSE; 10400 10401 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 10402 type_idx = CN_TYPE_IDX(OPND_IDX(opnd)); 10403 } 10404 else { 10405 attr_idx = find_base_attr(&opnd, &line, &col); 10406 type_idx = ATD_TYPE_IDX(attr_idx); 10407 } 10408 10409 exp_desc->has_constructor = exp_desc_l.has_constructor; 10410 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 10411 10412 exp_desc->constant = exp_desc_l.constant; 10413 exp_desc->foldable = exp_desc_l.foldable; 10414 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 10415 10416 exp_desc->rank = exp_desc_l.rank; 10417 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape,exp_desc_l.rank); 10418 exp_desc->type = exp_desc_l.type; 10419 exp_desc->linear_type = exp_desc_l.linear_type; 10420 exp_desc->type_idx = exp_desc_l.type_idx; 10421 10422 if (exp_desc->linear_type == Short_Char_Const) { 10423 10424 /* Assume that the subscript is not constant for now.*/ 10425 /* If it folds down below, it will be changed to */ 10426 /* Short_Char_Const again. */ 10427 /* We cannot allow i = "abcdefg"(1:N) */ 10428 10429 type_tbl[TYP_WORK_IDX] = type_tbl[exp_desc->type_idx]; 10430 TYP_LINEAR(TYP_WORK_IDX) = Character_1; 10431 exp_desc->type_idx = ntr_type_tbl(); 10432 exp_desc->linear_type = Character_1; 10433 } 10434 10435 /* length is run time dependent */ 10436 10437 if (IR_OPR(ir_idx) == Whole_Substring_Opr) { 10438 exp_desc->pointer = exp_desc_l.pointer; 10439 exp_desc->target = exp_desc_l.target; 10440 } 10441 else { 10442 exp_desc->target = exp_desc_l.target || 10443 exp_desc_l.pointer; 10444 } 10445 10446 exp_desc->vector_subscript = exp_desc_l.vector_subscript; 10447 exp_desc->reference = exp_desc_l.reference; 10448 exp_desc->pe_dim_ref = exp_desc_l.pe_dim_ref; 10449 COPY_OPND((exp_desc->bias_opnd), (exp_desc_l.bias_opnd)); 10450 exp_desc->cif_id = exp_desc_l.cif_id; 10451 exp_desc->component = exp_desc_l.component; 10452 exp_desc->section = exp_desc_l.section; 10453 exp_desc->array_elt = exp_desc_l.array_elt; 10454 exp_desc->dope_vector = exp_desc_l.dope_vector; 10455 exp_desc->contig_array = exp_desc_l.contig_array; 10456 exp_desc->dist_reshape_ref = exp_desc_l.dist_reshape_ref; 10457 10458 10459 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 10460 IR_RANK(ir_idx) = exp_desc->rank; 10461 10462 10463 if (exp_desc_l.type != Character) { 10464 PRINTMSG(line, 508, Error, col); 10465 ok = FALSE; 10466 } 10467 10468 save_expr_mode = expr_mode; 10469 save_xref_state = xref_state; 10470 10471 if (xref_state != CIF_No_Usage_Rec) { 10472 xref_state = CIF_Symbol_Reference; 10473 } 10474 save_in_component_ref = in_component_ref; 10475 in_component_ref = FALSE; 10476 10477 if (expr_mode == Data_Stmt_Target) { 10478 expr_mode = Data_Stmt_Target_Expr; 10479 } 10480 else if (expr_mode == Restricted_Imp_Do_Target) { 10481 expr_mode = Restricted_Imp_Do_Expr; 10482 } 10483 10484 list_idx = IR_IDX_R(ir_idx); 10485 10486 exp_desc_r.rank = 0; 10487 save_number_of_functions = number_of_functions; 10488 number_of_functions = 0; 10489 10490 COPY_OPND(opnd, IL_OPND(list_idx)); 10491 ok &= expr_sem(&opnd, &exp_desc_r); 10492 COPY_OPND(IL_OPND(list_idx), opnd); 10493 10494 exp_desc->has_symbolic |= exp_desc_r.has_symbolic; 10495 exp_desc->has_constructor |= exp_desc_r.has_constructor; 10496 10497 if (IL_FLD(list_idx) == NO_Tbl_Idx) { 10498 /* fill in const 1 */ 10499 IL_FLD(list_idx) = CN_Tbl_Idx; 10500 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 10501 IL_LINE_NUM(list_idx) = line; 10502 IL_COL_NUM(list_idx) = col; 10503 exp_desc_r.foldable = TRUE; 10504 } 10505 else if (exp_desc_r.linear_type == Long_Typeless) { 10506 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10507 &opnd_line, 10508 &opnd_col); 10509 PRINTMSG(opnd_line, 1133, Error, opnd_col); 10510 ok = FALSE; 10511 } 10512 else if (exp_desc_r.rank != 0 || 10513 (exp_desc_r.type != Integer && 10514 exp_desc_r.type != Typeless)) { 10515 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10516 &opnd_line, 10517 &opnd_col); 10518 PRINTMSG(opnd_line, 323, Error, opnd_col); 10519 ok = FALSE; 10520 } 10521 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 10522 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10523 &opnd_line, 10524 &opnd_col); 10525 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 10526 INTEGER_DEFAULT_TYPE, 10527 opnd_line, 10528 opnd_col); 10529 exp_desc_r.type_idx = INTEGER_DEFAULT_TYPE; 10530 exp_desc_r.type = Integer; 10531 exp_desc_r.linear_type = INTEGER_DEFAULT_TYPE; 10532 } 10533 10534 if (ok && 10535 IL_FLD(list_idx) == CN_Tbl_Idx && 10536 compare_cn_and_value(IL_IDX(list_idx), 1, Eq_Opr)) { 10537 /* intentionally blank */ 10538 } 10539 else { 10540 exp_desc->contig_array = FALSE; 10541 } 10542 10543 exp_desc->foldable = exp_desc->foldable && 10544 exp_desc_r.foldable; 10545 10546 exp_desc->will_fold_later &= (exp_desc_r.will_fold_later || 10547 exp_desc_r.foldable); 10548 10549 IL_CONSTANT_SUBSCRIPT(list_idx) = exp_desc_r.foldable; 10550 10551 list_idx = IL_NEXT_LIST_IDX(list_idx); 10552 10553 exp_desc_r.rank = 0; 10554 10555 COPY_OPND(opnd, IL_OPND(list_idx)); 10556 ok &= expr_sem(&opnd, &exp_desc_r); 10557 COPY_OPND(IL_OPND(list_idx), opnd); 10558 10559 exp_desc->has_symbolic |= exp_desc_r.has_symbolic; 10560 exp_desc->has_constructor |= exp_desc_r.has_constructor; 10561 10562 if (IL_FLD(list_idx) == NO_Tbl_Idx || 10563 (IL_FLD(list_idx) == CN_Tbl_Idx && 10564 TYP_CHAR_CLASS(type_idx) == Const_Len_Char && 10565 TYP_FLD(type_idx) == CN_Tbl_Idx && 10566 fold_relationals(IL_IDX(list_idx), TYP_IDX(type_idx), Eq_Opr))) { 10567 10568 /* intentionally blank */ 10569 } 10570 else { 10571 exp_desc->contig_array = FALSE; 10572 } 10573 10574 if (IL_FLD(list_idx) == NO_Tbl_Idx) { /* fill in string length */ 10575 10576 if (IR_FLD_L(ir_idx) != CN_Tbl_Idx && 10577 ATD_CLASS(attr_idx) == CRI__Pointee && 10578 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) { 10579 10580 NTR_IR_TBL(clen_idx); 10581 IR_OPR(clen_idx) = Clen_Opr; 10582 IR_TYPE_IDX(clen_idx) = CG_INTEGER_DEFAULT_TYPE; 10583 IR_LINE_NUM(clen_idx) = line; 10584 IR_COL_NUM(clen_idx) = col; 10585 IR_FLD_L(clen_idx) = AT_Tbl_Idx; 10586 IR_IDX_L(clen_idx) = attr_idx; 10587 IR_LINE_NUM_L(clen_idx) = line; 10588 IR_COL_NUM_L(clen_idx) = col; 10589 IL_FLD(list_idx) = IR_Tbl_Idx; 10590 IL_IDX(list_idx) = clen_idx; 10591 } 10592 else { 10593 IL_FLD(list_idx) = TYP_FLD(type_idx); 10594 IL_IDX(list_idx) = TYP_IDX(type_idx); 10595 IL_LINE_NUM(list_idx) = line; 10596 IL_COL_NUM(list_idx) = col; 10597 10598 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 10599 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 10600 } 10601 10602 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 10603 exp_desc_r.foldable = TRUE; 10604 } 10605 } 10606 } 10607 else if (exp_desc_r.linear_type == Long_Typeless) { 10608 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10609 &opnd_line, 10610 &opnd_col); 10611 PRINTMSG(opnd_line, 1133, Error, opnd_col); 10612 ok = FALSE; 10613 } 10614 else if (exp_desc_r.rank != 0 || 10615 (exp_desc_r.type != Integer && 10616 exp_desc_r.type != Typeless)) { 10617 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10618 &opnd_line, 10619 &opnd_col); 10620 PRINTMSG(opnd_line, 323, Error, opnd_col); 10621 ok = FALSE; 10622 } 10623 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 10624 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10625 &opnd_line, 10626 &opnd_col); 10627 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 10628 INTEGER_DEFAULT_TYPE, 10629 opnd_line, 10630 opnd_col); 10631 exp_desc_r.type_idx = INTEGER_DEFAULT_TYPE; 10632 exp_desc_r.type = Integer; 10633 exp_desc_r.linear_type = INTEGER_DEFAULT_TYPE; 10634 } 10635 10636 exp_desc->foldable = exp_desc->foldable && exp_desc_r.foldable; 10637 exp_desc->will_fold_later &= (exp_desc_r.will_fold_later || 10638 exp_desc_r.foldable); 10639 10640 IL_CONSTANT_SUBSCRIPT(list_idx) = exp_desc_r.foldable; 10641 10642 if (ok) { 10643 10644 add_substring_length(ir_idx); 10645 10646 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx && 10647 (IR_OPR(IR_IDX_L(ir_idx)) == Substring_Opr || 10648 IR_OPR(IR_IDX_L(ir_idx)) == Whole_Substring_Opr)) { 10649 10650 /* this is only seen during var size function result */ 10651 /* processing. Fold out the extra substring_opr */ 10652 10653 fold_nested_substrings(ir_idx); 10654 } 10655 10656 list_idx = IL_NEXT_LIST_IDX(list_idx); 10657 10658 COPY_OPND(exp_desc->char_len, IL_OPND(list_idx)); 10659 10660 ok &= check_substring_bounds(ir_idx); 10661 10662 if (ok && 10663 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 10664 IL_FLD(list_idx) == CN_Tbl_Idx && 10665 exp_desc->foldable) { 10666 10667 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 10668 TYP_TYPE(TYP_WORK_IDX) = Character; 10669 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 10670 TYP_FLD(TYP_WORK_IDX) = IL_FLD(list_idx), 10671 TYP_IDX(TYP_WORK_IDX) = IL_IDX(list_idx), 10672 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 10673 exp_desc->type = Character; 10674 exp_desc->linear_type = TYP_LINEAR(TYP_WORK_IDX); 10675 exp_desc->type_idx = ntr_type_tbl(); 10676 10677 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 10678 OPND_LINE_NUM((*result_opnd)) = line; 10679 OPND_COL_NUM((*result_opnd)) = col; 10680 10681 /* set up the new const table entry */ 10682 10683 OPND_IDX((*result_opnd))= ntr_const_tbl(exp_desc->type_idx, 10684 TRUE, 10685 NULL); 10686 /* BRIANJ - String manipulation */ 10687 10688 char_ptr1 = (char *)&CN_CONST(OPND_IDX((*result_opnd))); 10689 char_ptr2 = (char *)&CN_CONST(IR_IDX_L(ir_idx)) + 10690 CN_INT_TO_C(IL_IDX(IR_IDX_R(ir_idx))) - 1; 10691 10692 for (i=0; i < CN_INT_TO_C(IL_IDX(list_idx)); i++) { 10693 char_ptr1[i] = char_ptr2[i]; 10694 } 10695 10696 /* fill in the rest of a word with blanks */ 10697 10698 while (i % TARGET_CHARS_PER_WORD != 0) { 10699 char_ptr1[i] = ' '; 10700 i++; 10701 } 10702 10703 if (compare_cn_and_value(TYP_IDX(exp_desc->type_idx), 10704 MAX_CHARS_IN_TYPELESS, 10705 Le_Opr)) { 10706 exp_desc->linear_type = Short_Char_Const; 10707 type_tbl[TYP_WORK_IDX] = type_tbl[exp_desc->type_idx]; 10708 TYP_LINEAR(TYP_WORK_IDX)= Short_Char_Const; 10709 exp_desc->type_idx = ntr_type_tbl(); 10710 10711 } 10712 } 10713 else if (ok && 10714 IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 10715 10716 stmt_expansion_control_start(); 10717 save_defer_stmt_expansion = defer_stmt_expansion; 10718 defer_stmt_expansion = FALSE; 10719 10720 /* substring of character literal that doesn't fold */ 10721 /* like ... "abcdefg"(1:N) */ 10722 /* the literal must be put in a static variable. */ 10723 10724 tmp_idx = gen_initialized_tmp(IR_IDX_L(ir_idx), line,col); 10725 10726 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 10727 IR_IDX_L(ir_idx) = tmp_idx; 10728 IR_LINE_NUM_L(ir_idx) = line; 10729 IR_COL_NUM_L(ir_idx) = col; 10730 10731 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 10732 defer_stmt_expansion = save_defer_stmt_expansion; 10733 stmt_expansion_control_end(&opnd); 10734 COPY_OPND(IR_OPND_L(ir_idx), opnd); 10735 } 10736 } 10737 10738 number_of_functions += save_number_of_functions; 10739 10740 expr_mode = save_expr_mode; 10741 xref_state = save_xref_state; 10742 in_component_ref = save_in_component_ref; 10743 10744 10745 TRACE (Func_Exit, "substring_opr_handler", NULL); 10746 10747 return(ok); 10748 10749 } /* substring_opr_handler */ 10750 10751 /******************************************************************************\ 10752 |* *| 10753 |* Description: *| 10754 |* semantic handler for the Triplet_Opr. *| 10755 |* *| 10756 |* Input parameters: *| 10757 |* NONE *| 10758 |* *| 10759 |* Output parameters: *| 10760 |* NONE *| 10761 |* *| 10762 |* Returns: *| 10763 |* NOTHING *| 10764 |* *| 10765 \******************************************************************************/ 10766 10767 static boolean triplet_opr_handler(opnd_type *result_opnd, 10768 expr_arg_type *exp_desc) 10769 10770 { 10771 expr_arg_type exp_desc_l; 10772 int ir_idx; 10773 int list_idx; 10774 boolean ok = TRUE; 10775 opnd_type opnd; 10776 int opnd_col; 10777 int opnd_line; 10778 10779 10780 TRACE (Func_Entry, "triplet_opr_handler" , NULL); 10781 10782 ir_idx = OPND_IDX((*result_opnd)); 10783 in_call_list = FALSE; 10784 10785 exp_desc->constant = TRUE; 10786 exp_desc->foldable = TRUE; 10787 exp_desc->will_fold_later = TRUE; 10788 10789 list_idx = IR_IDX_L(ir_idx); 10790 COPY_OPND(opnd, IL_OPND(list_idx)); 10791 exp_desc_l.rank = 0; 10792 ok = expr_sem(&opnd, &exp_desc_l); 10793 COPY_OPND(IL_OPND(list_idx), opnd); 10794 IL_CONSTANT_SUBSCRIPT(list_idx) = exp_desc_l.foldable; 10795 exp_desc->has_constructor = exp_desc_l.has_constructor; 10796 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 10797 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 10798 10799 if (exp_desc_l.linear_type == Long_Typeless) { 10800 find_opnd_line_and_column((opnd_type *) 10801 &IL_OPND(list_idx), 10802 &opnd_line, 10803 &opnd_col); 10804 PRINTMSG(opnd_line, 1133, Error, opnd_col); 10805 ok = FALSE; 10806 } 10807 else if (exp_desc_l.rank > 0 || 10808 (exp_desc_l.type != Integer && 10809 exp_desc_l.type != Typeless)) { 10810 10811 /* error .. must be scalar int expr */ 10812 10813 ok = FALSE; 10814 find_opnd_line_and_column((opnd_type *) 10815 &IL_OPND(list_idx), 10816 &opnd_line, 10817 &opnd_col); 10818 PRINTMSG(opnd_line, 319, Error, opnd_col); 10819 } 10820 else if (exp_desc_l.linear_type == Short_Typeless_Const) { 10821 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10822 &opnd_line, 10823 &opnd_col); 10824 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 10825 INTEGER_DEFAULT_TYPE, 10826 opnd_line, 10827 opnd_col); 10828 exp_desc_l.type_idx = INTEGER_DEFAULT_TYPE; 10829 exp_desc_l.type = Integer; 10830 exp_desc_l.linear_type = INTEGER_DEFAULT_TYPE; 10831 } 10832 10833 exp_desc->constant = exp_desc_l.constant; 10834 exp_desc->foldable = exp_desc_l.foldable; 10835 exp_desc->will_fold_later = exp_desc_l.will_fold_later || 10836 exp_desc_l.foldable; 10837 SHAPE_FOLDABLE(IL_OPND(list_idx)) = exp_desc_l.foldable; 10838 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = 10839 exp_desc_l.will_fold_later; 10840 10841 if (in_io_list) { 10842 10843 /* on mpp, must cast shorts to longs in io lists */ 10844 /* on solaris, must cast Integer_8 to Integer_4 */ 10845 10846 COPY_OPND(opnd, IL_OPND(list_idx)); 10847 cast_to_cg_default(&opnd, &exp_desc_l); 10848 COPY_OPND(IL_OPND(list_idx), opnd); 10849 } 10850 } 10851 10852 list_idx = IL_NEXT_LIST_IDX(list_idx); 10853 exp_desc_l.rank = 0; 10854 COPY_OPND(opnd, IL_OPND(list_idx)); 10855 ok &= expr_sem(&opnd, &exp_desc_l); 10856 COPY_OPND(IL_OPND(list_idx), opnd); 10857 10858 IL_CONSTANT_SUBSCRIPT(list_idx) = exp_desc_l.foldable; 10859 10860 exp_desc->has_symbolic |= exp_desc_l.has_symbolic; 10861 exp_desc->has_constructor |= exp_desc_l.has_constructor; 10862 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 10863 10864 if (exp_desc_l.linear_type == Long_Typeless) { 10865 find_opnd_line_and_column((opnd_type *) 10866 &IL_OPND(list_idx), 10867 &opnd_line, 10868 &opnd_col); 10869 PRINTMSG(opnd_line, 1133, Error, opnd_col); 10870 ok = FALSE; 10871 } 10872 else if (exp_desc_l.rank > 0 || 10873 (exp_desc_l.type != Integer && 10874 exp_desc_l.type != Typeless)) { 10875 10876 /* error .. must be scalar int expr */ 10877 10878 ok = FALSE; 10879 find_opnd_line_and_column((opnd_type *) 10880 &IL_OPND(list_idx), 10881 &opnd_line, 10882 &opnd_col); 10883 PRINTMSG(opnd_line, 319, Error, opnd_col); 10884 } 10885 else if (exp_desc_l.linear_type == Short_Typeless_Const) { 10886 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10887 &opnd_line, 10888 &opnd_col); 10889 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 10890 INTEGER_DEFAULT_TYPE, 10891 opnd_line, 10892 opnd_col); 10893 exp_desc_l.type_idx = INTEGER_DEFAULT_TYPE; 10894 exp_desc_l.type = Integer; 10895 exp_desc_l.linear_type = INTEGER_DEFAULT_TYPE; 10896 } 10897 10898 exp_desc->constant = exp_desc->constant && exp_desc_l.constant; 10899 exp_desc->foldable = exp_desc->foldable && exp_desc_l.foldable; 10900 exp_desc->will_fold_later &= (exp_desc_l.will_fold_later || 10901 exp_desc_l.foldable); 10902 SHAPE_FOLDABLE(IL_OPND(list_idx)) = exp_desc_l.foldable; 10903 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = exp_desc_l.will_fold_later; 10904 10905 if (in_io_list) { 10906 10907 /* on mpp, must cast shorts to longs in io lists */ 10908 /* on solaris, must cast Integer_8 to Integer_4 */ 10909 10910 COPY_OPND(opnd, IL_OPND(list_idx)); 10911 cast_to_cg_default(&opnd, &exp_desc_l); 10912 COPY_OPND(IL_OPND(list_idx), opnd); 10913 10914 } 10915 } 10916 10917 exp_desc_l.rank = 0; 10918 list_idx = IL_NEXT_LIST_IDX(list_idx); 10919 COPY_OPND(opnd, IL_OPND(list_idx)); 10920 ok &= expr_sem(&opnd, &exp_desc_l); 10921 COPY_OPND(IL_OPND(list_idx), opnd); 10922 10923 IL_CONSTANT_SUBSCRIPT(list_idx) = exp_desc_l.foldable; 10924 10925 exp_desc->has_symbolic |= exp_desc_l.has_symbolic; 10926 exp_desc->has_constructor |= exp_desc_l.has_constructor; 10927 10928 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 10929 10930 if (exp_desc_l.linear_type == Long_Typeless) { 10931 find_opnd_line_and_column((opnd_type *) 10932 &IL_OPND(list_idx), 10933 &opnd_line, 10934 &opnd_col); 10935 PRINTMSG(opnd_line, 1133, Error, opnd_col); 10936 ok = FALSE; 10937 } 10938 else if (exp_desc_l.rank > 0 || 10939 (exp_desc_l.type != Integer && 10940 exp_desc_l.type != Typeless)) { 10941 10942 /* error .. must be scalar int expr */ 10943 10944 ok = FALSE; 10945 find_opnd_line_and_column((opnd_type *) 10946 &IL_OPND(list_idx), 10947 &opnd_line, 10948 &opnd_col); 10949 PRINTMSG(opnd_line, 319, Error, opnd_col); 10950 } 10951 else if (exp_desc_l.linear_type == Short_Typeless_Const) { 10952 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 10953 &opnd_line, 10954 &opnd_col); 10955 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 10956 INTEGER_DEFAULT_TYPE, 10957 opnd_line, 10958 opnd_col); 10959 exp_desc_l.type_idx = INTEGER_DEFAULT_TYPE; 10960 exp_desc_l.type = Integer; 10961 exp_desc_l.linear_type = INTEGER_DEFAULT_TYPE; 10962 } 10963 10964 exp_desc->constant = exp_desc->constant && exp_desc_l.constant; 10965 exp_desc->foldable = exp_desc->foldable && exp_desc_l.foldable; 10966 exp_desc->will_fold_later &= (exp_desc_l.will_fold_later || 10967 exp_desc_l.foldable); 10968 SHAPE_FOLDABLE(IL_OPND(list_idx)) = exp_desc_l.foldable; 10969 SHAPE_WILL_FOLD_LATER(IL_OPND(list_idx)) = exp_desc_l.will_fold_later; 10970 10971 if (in_io_list) { 10972 10973 /* on mpp, must cast shorts to longs in io lists */ 10974 /* on solaris, must cast Integer_8 to Integer_4 */ 10975 10976 COPY_OPND(opnd, IL_OPND(list_idx)); 10977 cast_to_cg_default(&opnd, &exp_desc_l); 10978 COPY_OPND(IL_OPND(list_idx), opnd); 10979 10980 } 10981 } 10982 10983 exp_desc->rank = 1; 10984 /* exp_desc->rank = 0; */ 10985 exp_desc->type = Integer; 10986 exp_desc->type_idx = CG_INTEGER_DEFAULT_TYPE; 10987 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 10988 10989 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 10990 IR_RANK(ir_idx) = exp_desc->rank; 10991 10992 TRACE (Func_Exit, "triplet_opr_handler", NULL); 10993 10994 return(ok); 10995 10996 } /* triplet_opr_handler */ 10997 10998 /******************************************************************************\ 10999 |* *| 11000 |* Description: *| 11001 |* semantic handler for the Dealloc_Obj_Opr. *| 11002 |* *| 11003 |* Input parameters: *| 11004 |* NONE *| 11005 |* *| 11006 |* Output parameters: *| 11007 |* NONE *| 11008 |* *| 11009 |* Returns: *| 11010 |* NOTHING *| 11011 |* *| 11012 \******************************************************************************/ 11013 11014 static boolean dealloc_obj_opr_handler(opnd_type *result_opnd, 11015 expr_arg_type *exp_desc, 11016 int rank_in) 11017 11018 { 11019 int attr_idx; 11020 int col; 11021 expr_arg_type exp_desc_l; 11022 int ir_idx; 11023 int line; 11024 boolean ok = TRUE; 11025 opnd_type opnd; 11026 11027 TRACE (Func_Entry, "dealloc_obj_opr_handler" , NULL); 11028 11029 ir_idx = OPND_IDX((*result_opnd)); 11030 line = IR_LINE_NUM(ir_idx); 11031 col = IR_COL_NUM(ir_idx); 11032 in_call_list = FALSE; 11033 11034 exp_desc_l.rank = rank_in; 11035 11036 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 11037 insert_subs_ok = FALSE; 11038 pgm_unit_illegal = FALSE; 11039 ok = expr_sem(&opnd, &exp_desc_l); 11040 insert_subs_ok = TRUE; 11041 pgm_unit_illegal = TRUE; 11042 COPY_OPND(IR_OPND_L(ir_idx), opnd); 11043 11044 attr_idx = find_base_attr(&opnd, &line, &col); 11045 11046 if (attr_idx && 11047 AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11048 11049 exp_desc->type = exp_desc_l.type; 11050 exp_desc->linear_type = exp_desc_l.linear_type; 11051 exp_desc->type_idx = exp_desc_l.type_idx; 11052 exp_desc->rank = 0; 11053 exp_desc->constant = exp_desc_l.constant; 11054 exp_desc->foldable = exp_desc_l.foldable; 11055 exp_desc->reference = TRUE; 11056 exp_desc->component = exp_desc_l.component; 11057 exp_desc->has_symbolic= exp_desc_l.has_symbolic; 11058 11059 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 11060 IR_RANK(ir_idx) = exp_desc->rank; 11061 11062 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) { 11063 11064 if (! ATD_POINTER(attr_idx)) { 11065 /* error .. scalar must be pointer*/ 11066 ok = FALSE; 11067 PRINTMSG(line, 428, Error, col); 11068 } 11069 11070 if (IR_FLD_R(ir_idx) != NO_Tbl_Idx) { 11071 /* had shape spec and musn't */ 11072 PRINTMSG(line, 975, Internal, col); 11073 } 11074 11075 /* might want to remove Alloc_Obj_Opr here */ 11076 } 11077 else { 11078 11079 if (!ATD_POINTER(attr_idx) && !ATD_ALLOCATABLE(attr_idx)) { 11080 11081 /* error .. must be allocatable or pointer */ 11082 ok = FALSE; 11083 PRINTMSG(line, 428, Error, col); 11084 } 11085 } 11086 } 11087 else { 11088 /* error .. must be allocatable or pointer */ 11089 ok = FALSE; 11090 PRINTMSG(line, 428, Error, col); 11091 } 11092 11093 11094 TRACE (Func_Exit, "dealloc_obj_opr_handler", NULL); 11095 11096 return(ok); 11097 11098 } /* dealloc_obj_opr_handler */ 11099 11100 /******************************************************************************\ 11101 |* *| 11102 |* Description: *| 11103 |* semantic handler for the Alloc_Obj_Opr. *| 11104 |* *| 11105 |* Input parameters: *| 11106 |* NONE *| 11107 |* *| 11108 |* Output parameters: *| 11109 |* NONE *| 11110 |* *| 11111 |* Returns: *| 11112 |* NOTHING *| 11113 |* *| 11114 \******************************************************************************/ 11115 11116 static boolean alloc_obj_opr_handler(opnd_type *result_opnd, 11117 expr_arg_type *exp_desc, 11118 int rank_in) 11119 11120 { 11121 int attr_idx; 11122 int bd_idx; 11123 int col; 11124 expr_arg_type exp_desc_l; 11125 expr_arg_type exp_desc_r; 11126 int i; 11127 int ir_idx; 11128 int line; 11129 int listp_idx; 11130 int list_keep_idx; 11131 int list_idx; 11132 boolean ok = TRUE; 11133 opnd_type opnd; 11134 int opnd_col; 11135 int opnd_line; 11136 int pe_bd_idx; 11137 boolean save_in_component_ref; 11138 cif_usage_code_type save_xref_state; 11139 11140 11141 TRACE (Func_Entry, "alloc_obj_opr_handler" , NULL); 11142 11143 ir_idx = OPND_IDX((*result_opnd)); 11144 line = IR_LINE_NUM(ir_idx); 11145 col = IR_COL_NUM(ir_idx); 11146 in_call_list = FALSE; 11147 11148 exp_desc_l.rank = rank_in; 11149 11150 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 11151 insert_subs_ok = FALSE; 11152 pgm_unit_illegal = FALSE; 11153 ok = expr_sem(&opnd, &exp_desc_l); 11154 insert_subs_ok = TRUE; 11155 pgm_unit_illegal = TRUE; 11156 COPY_OPND(IR_OPND_L(ir_idx), opnd); 11157 11158 attr_idx = find_base_attr(&opnd, &line, &col); 11159 11160 if (attr_idx && 11161 AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11162 11163 exp_desc->type = exp_desc_l.type; 11164 exp_desc->linear_type = exp_desc_l.linear_type; 11165 exp_desc->type_idx = exp_desc_l.type_idx; 11166 exp_desc->rank = 0; 11167 exp_desc->constant = exp_desc_l.constant; 11168 exp_desc->foldable = exp_desc_l.foldable; 11169 exp_desc->reference = TRUE; 11170 exp_desc->component = exp_desc_l.component; 11171 exp_desc->has_symbolic= exp_desc_l.has_symbolic; 11172 11173 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 11174 IR_RANK(ir_idx) = exp_desc->rank; 11175 11176 bd_idx = ATD_ARRAY_IDX(attr_idx); 11177 pe_bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 11178 11179 if (bd_idx == NULL_IDX) { 11180 11181 if (! ATD_POINTER(attr_idx)) { 11182 /* error .. scalar must be pointer*/ 11183 ok = FALSE; 11184 PRINTMSG(line, 201, Error, col); 11185 } 11186 11187 if (IR_FLD_R(ir_idx) != NO_Tbl_Idx) { 11188 /* had shape spec and musn't */ 11189 PRINTMSG(line, 975, Internal, col); 11190 } 11191 11192 /* might want to remove Alloc_Obj_Opr here */ 11193 } 11194 else if (IR_FLD_R(ir_idx) == NO_Tbl_Idx) { 11195 ok = FALSE; 11196 PRINTMSG(line, 205, Error, col); 11197 } 11198 else if (pe_bd_idx && 11199 BD_RANK(pe_bd_idx) + BD_RANK(bd_idx) != IR_LIST_CNT_R(ir_idx)) { 11200 11201 ok = FALSE; 11202 PRINTMSG(line, 402, Error, col); 11203 } 11204 else if (pe_bd_idx == NULL_IDX && 11205 BD_RANK(ATD_ARRAY_IDX(attr_idx)) != IR_LIST_CNT_R(ir_idx)) { 11206 ok = FALSE; 11207 PRINTMSG(line, 402, Error, col); 11208 } 11209 else { 11210 11211 if (!ATD_POINTER(attr_idx) && !ATD_ALLOCATABLE(attr_idx)) { 11212 11213 /* error .. must be allocatable or pointer */ 11214 ok = FALSE; 11215 PRINTMSG(line, 201, Error, col); 11216 } 11217 11218 /* process subscripts */ 11219 list_idx = IR_IDX_R(ir_idx); 11220 11221 save_xref_state = xref_state; 11222 11223 if (xref_state != CIF_No_Usage_Rec) { 11224 xref_state = CIF_Symbol_Reference; 11225 } 11226 save_in_component_ref = in_component_ref; 11227 in_component_ref = FALSE; 11228 11229 for (i = 1; i <= IR_LIST_CNT_R(ir_idx); i++) { 11230 list_keep_idx = list_idx; 11231 11232 if (IL_FLD(list_idx) == IR_Tbl_Idx && 11233 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) 11234 list_idx = IR_IDX_L(IL_IDX(list_idx)); 11235 11236 if (IL_FLD(list_idx) == IL_Tbl_Idx) { 11237 /* lower and upper bound here */ 11238 11239 /* lower */ 11240 11241 listp_idx = IL_IDX(list_idx); 11242 11243 exp_desc_r.rank = 0; 11244 11245 COPY_OPND(opnd, IL_OPND(listp_idx)); 11246 ok &= expr_sem(&opnd, &exp_desc_r); 11247 COPY_OPND(IL_OPND(listp_idx), opnd); 11248 11249 if (exp_desc_r.linear_type == Long_Typeless) { 11250 11251 find_opnd_line_and_column((opnd_type *) 11252 &IL_OPND(listp_idx), 11253 &opnd_line, 11254 &opnd_col); 11255 PRINTMSG(opnd_line, 1133, Error, opnd_col); 11256 ok = FALSE; 11257 } 11258 else if ((exp_desc_r.type != Integer && 11259 exp_desc_r.type != Typeless) || 11260 exp_desc_r.rank != 0) { 11261 11262 find_opnd_line_and_column((opnd_type *) 11263 &IL_OPND(listp_idx), 11264 &opnd_line, 11265 &opnd_col); 11266 PRINTMSG(opnd_line, 403, Error, opnd_col); 11267 ok = FALSE; 11268 } 11269 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 11270 find_opnd_line_and_column((opnd_type *) &IL_OPND(listp_idx), 11271 &opnd_line, 11272 &opnd_col); 11273 IL_IDX(listp_idx) = cast_typeless_constant(IL_IDX(listp_idx), 11274 INTEGER_DEFAULT_TYPE, 11275 opnd_line, 11276 opnd_col); 11277 exp_desc_r.type_idx = INTEGER_DEFAULT_TYPE; 11278 exp_desc_r.type = Integer; 11279 exp_desc_r.linear_type = INTEGER_DEFAULT_TYPE; 11280 } 11281 11282 exp_desc->constant = exp_desc->constant && exp_desc_r.constant; 11283 exp_desc->foldable = exp_desc->foldable && exp_desc_r.foldable; 11284 11285 /* upper */ 11286 11287 listp_idx = IL_NEXT_LIST_IDX(listp_idx); 11288 11289 exp_desc_r.rank = 0; 11290 11291 COPY_OPND(opnd, IL_OPND(listp_idx)); 11292 ok &= expr_sem(&opnd, &exp_desc_r); 11293 COPY_OPND(IL_OPND(listp_idx), opnd); 11294 11295 if (exp_desc_r.linear_type == Long_Typeless) { 11296 find_opnd_line_and_column((opnd_type *) 11297 &IL_OPND(listp_idx), 11298 &opnd_line, 11299 &opnd_col); 11300 PRINTMSG(opnd_line, 1133, Error, opnd_col); 11301 ok = FALSE; 11302 } 11303 else if ((exp_desc_r.type != Integer && 11304 exp_desc_r.type != Typeless) || 11305 exp_desc_r.rank != 0) { 11306 11307 find_opnd_line_and_column((opnd_type *) 11308 &IL_OPND(listp_idx), 11309 &opnd_line, 11310 &opnd_col); 11311 PRINTMSG(opnd_line, 403, Error, opnd_col); 11312 ok = FALSE; 11313 } 11314 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 11315 find_opnd_line_and_column((opnd_type *) &IL_OPND(listp_idx), 11316 &opnd_line, 11317 &opnd_col); 11318 IL_IDX(listp_idx) = cast_typeless_constant(IL_IDX(listp_idx), 11319 INTEGER_DEFAULT_TYPE, 11320 opnd_line, 11321 opnd_col); 11322 exp_desc_r.type_idx = INTEGER_DEFAULT_TYPE; 11323 exp_desc_r.type = Integer; 11324 exp_desc_r.linear_type = INTEGER_DEFAULT_TYPE; 11325 } 11326 11327 exp_desc->constant = exp_desc->constant && 11328 exp_desc_r.constant; 11329 exp_desc->foldable = exp_desc->foldable && 11330 exp_desc_r.foldable; 11331 11332 } 11333 else { 11334 /* just have upper bound */ 11335 11336 exp_desc_r.rank = 0; 11337 11338 COPY_OPND(opnd, IL_OPND(list_idx)); 11339 ok &= expr_sem(&opnd, &exp_desc_r); 11340 COPY_OPND(IL_OPND(list_idx), opnd); 11341 11342 11343 if (exp_desc_r.linear_type == Long_Typeless) { 11344 find_opnd_line_and_column((opnd_type *) 11345 &IL_OPND(list_idx), 11346 &opnd_line, 11347 &opnd_col); 11348 PRINTMSG(opnd_line, 1133, Error, opnd_col); 11349 11350 ok = FALSE; 11351 } 11352 else if ((exp_desc_r.type != Integer && 11353 exp_desc_r.type != Typeless) || 11354 exp_desc_r.rank != 0) { 11355 11356 find_opnd_line_and_column((opnd_type *) 11357 &IL_OPND(list_idx), 11358 &opnd_line, 11359 &opnd_col); 11360 PRINTMSG(opnd_line, 403, Error, opnd_col); 11361 11362 ok = FALSE; 11363 } 11364 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 11365 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 11366 &opnd_line, 11367 &opnd_col); 11368 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 11369 INTEGER_DEFAULT_TYPE, 11370 opnd_line, 11371 opnd_col); 11372 exp_desc_r.type_idx = INTEGER_DEFAULT_TYPE; 11373 exp_desc_r.type = Integer; 11374 exp_desc_r.linear_type = INTEGER_DEFAULT_TYPE; 11375 } 11376 11377 exp_desc->constant = exp_desc->constant && exp_desc_r.constant; 11378 exp_desc->foldable = exp_desc->foldable && exp_desc_r.foldable; 11379 } 11380 11381 /* list_idx = IL_NEXT_LIST_IDX(list_idx);*/ 11382 list_idx = IL_NEXT_LIST_IDX(list_keep_idx); 11383 11384 } /* for ... */ 11385 11386 xref_state = save_xref_state; 11387 in_component_ref = save_in_component_ref; 11388 11389 } /* else process subscripts */ 11390 } /* if data_obj */ 11391 else { 11392 /* error .. must be allocatable or pointer */ 11393 ok = FALSE; 11394 PRINTMSG(line, 201, Error, col); 11395 } 11396 11397 11398 TRACE (Func_Exit, "alloc_obj_opr_handler", NULL); 11399 11400 return(ok); 11401 11402 } /* alloc_obj_opr_handler */ 11403 11404 /******************************************************************************\ 11405 |* *| 11406 |* Description: *| 11407 |* semantic handler for the Cvrt_Opr. *| 11408 |* *| 11409 |* Input parameters: *| 11410 |* NONE *| 11411 |* *| 11412 |* Output parameters: *| 11413 |* NONE *| 11414 |* *| 11415 |* Returns: *| 11416 |* NOTHING *| 11417 |* *| 11418 \******************************************************************************/ 11419 11420 static boolean cvrt_opr_handler(opnd_type *result_opnd, 11421 expr_arg_type *exp_desc) 11422 11423 { 11424 expr_arg_type exp_desc_l; 11425 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 11426 int ir_idx; 11427 boolean ok = TRUE; 11428 opnd_type opnd; 11429 int type_idx; 11430 11431 11432 TRACE (Func_Entry, "cvrt_opr_handler" , NULL); 11433 11434 ir_idx = OPND_IDX((*result_opnd)); 11435 11436 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 11437 exp_desc_l.rank = 0; 11438 ok = expr_sem(&opnd, &exp_desc_l); 11439 COPY_OPND(IR_OPND_L(ir_idx), opnd); 11440 11441 exp_desc->has_constructor = exp_desc_l.has_constructor; 11442 11443 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 11444 exp_desc->constant = exp_desc_l.constant; 11445 exp_desc->foldable = exp_desc_l.foldable; 11446 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 11447 exp_desc->rank = exp_desc_l.rank; 11448 exp_desc->type = TYP_TYPE(IR_TYPE_IDX(ir_idx)); 11449 exp_desc->type_idx = IR_TYPE_IDX(ir_idx); 11450 exp_desc->linear_type = TYP_LINEAR(IR_TYPE_IDX(ir_idx)); 11451 11452 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape,exp_desc_l.rank); 11453 COPY_OPND(exp_desc->char_len, exp_desc_l.char_len); 11454 11455 if (exp_desc_l.linear_type == exp_desc->linear_type) { 11456 /* cvrt_Opr not needed */ 11457 COPY_OPND((*result_opnd), IR_OPND_L(ir_idx)); 11458 } 11459 else if (opt_flags.ieeeconform && 11460 ! comp_gen_expr && 11461 (exp_desc_l.type == Real || 11462 exp_desc_l.type == Complex)) { 11463 11464 /* don't fold real arithmatic under ieeeconform */ 11465 11466 exp_desc->foldable = FALSE; 11467 exp_desc->will_fold_later = FALSE; 11468 } 11469 else if (exp_desc->foldable && 11470 IR_FLD_L(ir_idx) == CN_Tbl_Idx && 11471 exp_desc_l.type == Typeless) { 11472 11473 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 11474 OPND_IDX((*result_opnd)) = cast_typeless_constant(IR_IDX_L(ir_idx), 11475 exp_desc->type_idx, 11476 IR_LINE_NUM(ir_idx), 11477 IR_COL_NUM(ir_idx)); 11478 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 11479 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 11480 } 11481 else if (exp_desc->foldable && 11482 IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 11483 11484 type_idx = exp_desc->type_idx; 11485 11486 if (folder_driver((char *)&CN_CONST(IR_IDX_L(ir_idx)), 11487 exp_desc_l.type_idx, 11488 NULL, 11489 NULL_IDX, 11490 folded_const, 11491 &type_idx, 11492 IR_LINE_NUM(ir_idx), 11493 IR_COL_NUM(ir_idx), 11494 1, 11495 Cvrt_Opr)) { 11496 11497 exp_desc->type_idx = type_idx; 11498 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 11499 OPND_IDX((*result_opnd)) = ntr_const_tbl(exp_desc->type_idx, 11500 FALSE, 11501 folded_const); 11502 11503 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 11504 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 11505 } 11506 else { 11507 ok = FALSE; 11508 } 11509 } 11510 11511 11512 TRACE (Func_Exit, "cvrt_opr_handler", NULL); 11513 11514 return(ok); 11515 11516 } /* cvrt_opr_handler */ 11517 11518 /******************************************************************************\ 11519 |* *| 11520 |* Description: *| 11521 |* semantic handler for the Paren_Opr. *| 11522 |* *| 11523 |* Input parameters: *| 11524 |* NONE *| 11525 |* *| 11526 |* Output parameters: *| 11527 |* NONE *| 11528 |* *| 11529 |* Returns: *| 11530 |* NOTHING *| 11531 |* *| 11532 \******************************************************************************/ 11533 11534 static boolean paren_opr_handler(opnd_type *result_opnd, 11535 expr_arg_type *exp_desc) 11536 11537 { 11538 expr_arg_type exp_desc_l; 11539 int ir_idx; 11540 boolean ok = TRUE; 11541 opnd_type opnd; 11542 11543 11544 TRACE (Func_Entry, "paren_opr_handler" , NULL); 11545 11546 ir_idx = OPND_IDX((*result_opnd)); 11547 in_call_list = FALSE; 11548 11549 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 11550 exp_desc_l.rank = 0; 11551 ok = expr_sem(&opnd, &exp_desc_l); 11552 COPY_OPND(IR_OPND_L(ir_idx), opnd); 11553 11554 11555 exp_desc->has_constructor = exp_desc_l.has_constructor; 11556 11557 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 11558 exp_desc->constant = exp_desc_l.constant; 11559 exp_desc->foldable = exp_desc_l.foldable; 11560 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 11561 exp_desc->rank = exp_desc_l.rank; 11562 exp_desc->type = exp_desc_l.type; 11563 exp_desc->type_idx = exp_desc_l.type_idx; 11564 exp_desc->linear_type = exp_desc_l.linear_type; 11565 exp_desc->vector_subscript = exp_desc_l.vector_subscript; 11566 11567 COPY_SHAPE(exp_desc->shape,exp_desc_l.shape,exp_desc_l.rank); 11568 COPY_OPND(exp_desc->char_len, exp_desc_l.char_len); 11569 11570 if (exp_desc_l.constant) { 11571 /* remove the paren_opr */ 11572 COPY_OPND((*result_opnd), opnd); 11573 /* could free up paren_opr ir */ 11574 } 11575 else if (IR_FLD_L(ir_idx) == IR_Tbl_Idx && 11576 IR_OPR(IR_IDX_L(ir_idx)) == Concat_Opr) { 11577 /* remove the paren_opr */ 11578 COPY_OPND((*result_opnd), opnd); 11579 /* could free up paren_opr ir */ 11580 } 11581 else if (IR_FLD_L(ir_idx) == IR_Tbl_Idx && 11582 IR_OPR(IR_IDX_L(ir_idx)) == Paren_Opr) { 11583 11584 /* remove redundant () */ 11585 11586 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IR_IDX_L(ir_idx))); 11587 IR_RANK(ir_idx) = exp_desc_l.rank; 11588 11589 if (IR_RANK(ir_idx)) { 11590 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 11591 } 11592 11593 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 11594 } 11595 else { 11596 IR_RANK(ir_idx) = exp_desc_l.rank; 11597 11598 if (IR_RANK(ir_idx)) { 11599 IR_ARRAY_SYNTAX(ir_idx) = TRUE; 11600 } 11601 11602 IR_TYPE_IDX(ir_idx) = exp_desc->type_idx; 11603 } 11604 11605 11606 TRACE (Func_Exit, "paren_opr_handler", NULL); 11607 11608 return(ok); 11609 11610 } /* paren_opr_handler */ 11611 11612 /******************************************************************************\ 11613 |* *| 11614 |* Description: *| 11615 |* semantic handler for the Stmt_Func_Call_Opr. *| 11616 |* *| 11617 |* Input parameters: *| 11618 |* NONE *| 11619 |* *| 11620 |* Output parameters: *| 11621 |* NONE *| 11622 |* *| 11623 |* Returns: *| 11624 |* NOTHING *| 11625 |* *| 11626 \******************************************************************************/ 11627 11628 static boolean stmt_func_call_opr_handler(opnd_type *result_opnd, 11629 expr_arg_type *exp_desc) 11630 11631 { 11632 int asg_idx; 11633 int col; 11634 int dummy_idx; 11635 expr_arg_type exp_desc_l; 11636 expr_arg_type exp_desc_r; 11637 int i; 11638 int ir_idx; 11639 int line; 11640 int list_idx; 11641 int loc_info_idx; 11642 char l_err_word[40]; 11643 opnd_type l_opnd; 11644 boolean ok = TRUE; 11645 opnd_type opnd; 11646 int opnd_col; 11647 int opnd_line; 11648 int paren_idx; 11649 char r_err_word[40]; 11650 int save_arg_info_list_base; 11651 expr_mode_type save_expr_mode; 11652 boolean save_defer_stmt_expansion; 11653 int save_number_of_functions; 11654 boolean save_tree_has_ranf; 11655 boolean save_io_item_must_flatten; 11656 boolean save_check_type_conversion; 11657 int save_target_type_idx; 11658 int save_target_char_len_idx; 11659 int sn_idx; 11660 int stmt_func_idx; 11661 opnd_type stmt_func_opnd; 11662 int tmp_idx; 11663 int type_idx; 11664 11665 11666 TRACE (Func_Entry, "stmt_func_call_opr_handler" , NULL); 11667 11668 stmt_expansion_control_start(); 11669 save_defer_stmt_expansion = defer_stmt_expansion; 11670 defer_stmt_expansion = FALSE; 11671 11672 ir_idx = OPND_IDX((*result_opnd)); 11673 line = IR_LINE_NUM(ir_idx); 11674 col = IR_COL_NUM(ir_idx); 11675 save_io_item_must_flatten = io_item_must_flatten; 11676 11677 /* BRIANJ - save_tree_has_ranf is never used */ 11678 11679 save_tree_has_ranf = tree_has_ranf; 11680 11681 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 11682 ok = expr_sem(&opnd, exp_desc); 11683 COPY_OPND(IR_OPND_L(ir_idx), opnd); 11684 stmt_func_idx = IR_IDX_L(ir_idx); 11685 11686 if (! ATS_SF_SEMANTICS_DONE(stmt_func_idx)) { 11687 ok = stmt_func_semantics(stmt_func_idx) && ok; 11688 } 11689 11690 if (AT_DCL_ERR(stmt_func_idx)) { 11691 /* previous error, nothing to say, just split */ 11692 ok = FALSE; 11693 goto EXIT; 11694 } 11695 11696 if (ATS_SF_ACTIVE(stmt_func_idx)) { 11697 11698 /* error , recursive use */ 11699 11700 find_opnd_line_and_column(&opnd, 11701 &opnd_line, 11702 &opnd_col); 11703 PRINTMSG(opnd_line, 753, Error, opnd_col, 11704 AT_OBJ_NAME_PTR(stmt_func_idx)); 11705 ok = FALSE; 11706 AT_DCL_ERR(stmt_func_idx) = TRUE; 11707 goto EXIT; 11708 } 11709 11710 if (ATP_NUM_DARGS(stmt_func_idx) != IR_LIST_CNT_R(ir_idx)) { 11711 11712 find_opnd_line_and_column((opnd_type *) &IR_OPND_L(ir_idx), 11713 &opnd_line, 11714 &opnd_col); 11715 PRINTMSG(opnd_line, 754, Error, opnd_col, 11716 AT_OBJ_NAME_PTR(stmt_func_idx)); 11717 ok = FALSE; 11718 goto EXIT; 11719 } 11720 11721 /* do memory management stuff to make sure the tables */ 11722 /* are big enough */ 11723 11724 if (max_call_list_size >= arg_list_size) { 11725 enlarge_call_list_tables(); 11726 } 11727 11728 save_arg_info_list_base = arg_info_list_base; 11729 11730 arg_info_list_base = arg_info_list_top; 11731 11732 arg_info_list_top = arg_info_list_base + 11733 IR_LIST_CNT_R(ir_idx); 11734 11735 if (arg_info_list_top >= arg_info_list_size) { 11736 enlarge_info_list_table(); 11737 } 11738 loc_info_idx = arg_info_list_base; 11739 11740 /* hook up the actual args with the dummy args */ 11741 11742 list_idx = IR_IDX_R(ir_idx); 11743 sn_idx = ATP_FIRST_IDX(stmt_func_idx); 11744 11745 for (i = loc_info_idx + 1; 11746 i <= loc_info_idx + IR_LIST_CNT_R(ir_idx); 11747 i++) { 11748 11749 dummy_idx = SN_ATTR_IDX(sn_idx); 11750 11751 save_number_of_functions = number_of_functions; 11752 tree_has_ranf = FALSE; 11753 COPY_OPND(opnd, IL_OPND(list_idx)); 11754 exp_desc_r.rank = 0; 11755 ok = expr_sem(&opnd, &exp_desc_r) && ok; 11756 COPY_OPND(IL_OPND(list_idx), opnd); 11757 11758 exp_desc_r.tree_has_ranf = tree_has_ranf; 11759 arg_info_list[i] = init_arg_info; 11760 arg_info_list[i].ed = exp_desc_r; 11761 11762 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 11763 IL_ARG_DESC_IDX(list_idx) = i; 11764 11765 /* check type, kind type, and rank */ 11766 11767 type_idx = ATD_TYPE_IDX(dummy_idx); 11768 11769 find_opnd_line_and_column(&opnd, &opnd_line, &opnd_col); 11770 11771 if (OPND_FLD(opnd) == AT_Tbl_Idx && 11772 AT_OBJ_CLASS(OPND_IDX(opnd)) != Data_Obj && 11773 fnd_semantic_err(Obj_Sf_Actual_Arg, 11774 opnd_line, 11775 opnd_col, 11776 OPND_IDX(opnd), 11777 TRUE)) { 11778 11779 ok = FALSE; 11780 } 11781 else { 11782 11783 if (exp_desc_r.rank > 0) { 11784 PRINTMSG(opnd_line, 750, Error, opnd_col, 11785 i - loc_info_idx, 11786 AT_OBJ_NAME_PTR(stmt_func_idx)); 11787 ok = FALSE; 11788 } 11789 11790 if (exp_desc_r.linear_type == Typeless_4 || 11791 exp_desc_r.linear_type == Typeless_8 || 11792 exp_desc_r.linear_type == Short_Typeless_Const) { 11793 11794 if (ASG_TYPE(TYP_LINEAR(type_idx), 11795 exp_desc_r.linear_type) == Err_Res) { 11796 r_err_word[0] = '\0'; 11797 l_err_word[0] = '\0'; 11798 11799 strcat(r_err_word, 11800 get_basic_type_str(exp_desc_r.type_idx)); 11801 strcat(l_err_word, get_basic_type_str(type_idx)); 11802 11803 PRINTMSG(opnd_line, 751, Error, opnd_col, 11804 r_err_word, 11805 AT_OBJ_NAME_PTR(dummy_idx), 11806 l_err_word); 11807 ok = FALSE; 11808 } 11809 else if (exp_desc_r.linear_type == Short_Typeless_Const) { 11810 OPND_IDX(opnd) = cast_typeless_constant(OPND_IDX(opnd), 11811 type_idx, 11812 opnd_line, 11813 opnd_col); 11814 exp_desc_r.linear_type = TYP_LINEAR(type_idx); 11815 exp_desc_r.type_idx = type_idx; 11816 exp_desc_r.type = TYP_TYPE(type_idx); 11817 11818 arg_info_list[i].ed = exp_desc_r; 11819 } 11820 } 11821 else if (exp_desc_r.type != TYP_TYPE(type_idx) || 11822 (exp_desc_r.type == Structure && 11823 !compare_derived_types(exp_desc_r.type_idx, 11824 type_idx))) { 11825 11826 r_err_word[0] = '\0'; 11827 l_err_word[0] = '\0'; 11828 11829 strcat(r_err_word, 11830 get_basic_type_str(exp_desc_r.type_idx)); 11831 strcat(l_err_word, get_basic_type_str(type_idx)); 11832 11833 PRINTMSG(opnd_line, 751, Error, opnd_col, 11834 r_err_word, 11835 AT_OBJ_NAME_PTR(dummy_idx), 11836 l_err_word); 11837 11838 ok = FALSE; 11839 } 11840 else if (exp_desc_r.type != Structure && 11841 exp_desc_r.type != Character && 11842 exp_desc_r.linear_type != TYP_LINEAR(type_idx)) { 11843 11844 PRINTMSG(opnd_line, 752, Error, opnd_col, 11845 i - loc_info_idx, 11846 AT_OBJ_NAME_PTR(stmt_func_idx)); 11847 ok = FALSE; 11848 } 11849 } 11850 11851 IL_HAS_FUNCTIONS(list_idx) = FALSE; 11852 11853 if (number_of_functions > save_number_of_functions) { 11854 IL_HAS_FUNCTIONS(list_idx) = TRUE; 11855 } 11856 11857 if (tree_has_ranf || 11858 (exp_desc_r.type == Character && 11859 TYP_TYPE(type_idx) == Character)) { 11860 11861 ok &= validate_char_len(&opnd, &exp_desc_r); 11862 arg_info_list[i].ed = exp_desc_r; 11863 11864 if (TYP_TYPE(type_idx) == Character && 11865 exp_desc_r.char_len.fld == CN_Tbl_Idx && 11866 TYP_FLD(type_idx) == CN_Tbl_Idx && 11867 fold_relationals(exp_desc_r.char_len.idx, 11868 TYP_IDX(type_idx), 11869 Lt_Opr)) { 11870 11871 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 11872 PRINTMSG(opnd_line, 1305, Caution, opnd_col); 11873 PRINTMSG(opnd_line, 1306, Ansi, opnd_col); 11874 cast_to_type_idx(&opnd, &exp_desc_r, type_idx); 11875 arg_info_list[i].ed = exp_desc_r; 11876 COPY_OPND(IL_OPND(list_idx), opnd); 11877 } 11878 else { 11879 /* error .. actual len is less than dummy len */ 11880 11881 PRINTMSG(opnd_line, 848, Error, opnd_col, 11882 AT_OBJ_NAME_PTR(dummy_idx)); 11883 ok = FALSE; 11884 } 11885 } 11886 11887 if (! ok) { 11888 /* intentionally blank */ 11889 } 11890 else if (TYP_TYPE(type_idx) == Character && 11891 exp_desc_r.type == Character && 11892 TYP_FLD(type_idx) == CN_Tbl_Idx && 11893 OPND_FLD(opnd) == CN_Tbl_Idx) { 11894 11895 save_check_type_conversion = check_type_conversion; 11896 save_target_type_idx = target_type_idx; 11897 save_target_char_len_idx = target_char_len_idx; 11898 11899 check_type_conversion = TRUE; 11900 target_type_idx = Character_1; 11901 11902 target_char_len_idx = TYP_IDX(type_idx); 11903 fold_aggragate_expression(&opnd, &exp_desc_r, TRUE); 11904 COPY_OPND(IL_OPND(list_idx), opnd); 11905 11906 check_type_conversion = save_check_type_conversion; 11907 target_type_idx = save_target_type_idx; 11908 target_char_len_idx = save_target_char_len_idx; 11909 11910 arg_info_list[i].arg_opnd.fld = OPND_FLD(opnd); 11911 arg_info_list[i].arg_opnd.idx = OPND_IDX(opnd); 11912 arg_info_list[i].ed = exp_desc_r; 11913 } 11914 else if (no_func_expansion) { 11915 arg_info_list[i].arg_opnd.fld = OPND_FLD(opnd); 11916 arg_info_list[i].arg_opnd.idx = OPND_IDX(opnd); 11917 } 11918 else if (tree_has_ranf || 11919 TYP_TYPE(type_idx) == Character) { 11920 11921 arg_info_list[i].ed.type_idx = type_idx; 11922 arg_info_list[i].ed.type = TYP_TYPE(type_idx); 11923 arg_info_list[i].ed.linear_type = TYP_LINEAR(type_idx); 11924 arg_info_list[i].ed.constant = FALSE; 11925 arg_info_list[i].ed.foldable = FALSE; 11926 arg_info_list[i].ed.will_fold_later = FALSE; 11927 11928 if (TYP_TYPE(type_idx) == Character) { 11929 arg_info_list[i].ed.char_len.fld = TYP_FLD(type_idx); 11930 arg_info_list[i].ed.char_len.idx = TYP_IDX(type_idx); 11931 OPND_LINE_NUM(arg_info_list[i].ed.char_len) = line; 11932 OPND_COL_NUM(arg_info_list[i].ed.char_len) = col; 11933 } 11934 11935 tmp_idx = create_tmp_asg(&opnd, 11936 &arg_info_list[i].ed, 11937 &l_opnd, 11938 Intent_In, 11939 FALSE, 11940 FALSE); 11941 11942 arg_info_list[i].arg_opnd.fld = AT_Tbl_Idx; 11943 arg_info_list[i].arg_opnd.idx = tmp_idx; 11944 11945 COPY_OPND(opnd, l_opnd); 11946 } 11947 } 11948 else { 11949 arg_info_list[i].arg_opnd.fld = OPND_FLD(opnd); 11950 arg_info_list[i].arg_opnd.idx = OPND_IDX(opnd); 11951 } 11952 11953 /* put a paren opr over any expression */ 11954 /* so that pdgcs can't mangle it. */ 11955 11956 if (! no_func_expansion && 11957 arg_info_list[i].arg_opnd.fld == IR_Tbl_Idx && 11958 IR_OPR(arg_info_list[i].arg_opnd.idx) != Whole_Subscript_Opr && 11959 IR_OPR(arg_info_list[i].arg_opnd.idx) != Section_Subscript_Opr && 11960 IR_OPR(arg_info_list[i].arg_opnd.idx) != Subscript_Opr && 11961 IR_OPR(arg_info_list[i].arg_opnd.idx) != Substring_Opr && 11962 IR_OPR(arg_info_list[i].arg_opnd.idx) != Whole_Substring_Opr && 11963 IR_OPR(arg_info_list[i].arg_opnd.idx) != Dv_Deref_Opr && 11964 IR_OPR(arg_info_list[i].arg_opnd.idx) != Struct_Opr && 11965 IR_OPR(arg_info_list[i].arg_opnd.idx) != Paren_Opr) { 11966 11967 NTR_IR_TBL(paren_idx); 11968 IR_OPR(paren_idx) = Paren_Opr; 11969 IR_TYPE_IDX(paren_idx) = arg_info_list[i].ed.type_idx; 11970 IR_LINE_NUM(paren_idx) = opnd_line; 11971 IR_COL_NUM(paren_idx) = opnd_col; 11972 COPY_OPND(IR_OPND_L(paren_idx), arg_info_list[i].arg_opnd); 11973 arg_info_list[i].arg_opnd.fld = IR_Tbl_Idx; 11974 arg_info_list[i].arg_opnd.idx = paren_idx; 11975 } 11976 11977 sn_idx++; 11978 list_idx = IL_NEXT_LIST_IDX(list_idx); 11979 } 11980 11981 /* now hook up all the info on the dummy arg attrs. */ 11982 /* can't do until here because of recursive uses. */ 11983 11984 sn_idx = ATP_FIRST_IDX(stmt_func_idx); 11985 11986 for (i = loc_info_idx + 1; 11987 i <= loc_info_idx + IR_LIST_CNT_R(ir_idx); 11988 i++) { 11989 11990 dummy_idx = SN_ATTR_IDX(sn_idx); 11991 ATD_SF_LINK(dummy_idx) = i; 11992 11993 ATD_FLD(dummy_idx) = arg_info_list[i].arg_opnd.fld; 11994 ATD_SF_ARG_IDX(dummy_idx) = arg_info_list[i].arg_opnd.idx; 11995 11996 sn_idx++; 11997 list_idx = IL_NEXT_LIST_IDX(list_idx); 11998 } 11999 12000 if (! ok) { 12001 goto EXIT; 12002 } 12003 12004 OPND_LINE_NUM(stmt_func_opnd)= line; 12005 OPND_COL_NUM(stmt_func_opnd) = col; 12006 OPND_FLD(stmt_func_opnd) = (fld_type) ATS_SF_FLD(stmt_func_idx); 12007 OPND_IDX(stmt_func_opnd) = ATS_SF_IDX(stmt_func_idx); 12008 copy_subtree(&stmt_func_opnd, &stmt_func_opnd); 12009 12010 /* set the stmt func active flag on stmt_func_idx */ 12011 12012 ATS_SF_ACTIVE(stmt_func_idx) = TRUE; 12013 12014 save_expr_mode = expr_mode; 12015 expr_mode = Stmt_Func_Expr; 12016 12017 exp_desc_l.rank = 0; 12018 ok = expr_sem(&stmt_func_opnd, &exp_desc_l) 12019 && ok; 12020 12021 expr_mode = save_expr_mode; 12022 12023 exp_desc->has_symbolic = exp_desc_l.has_symbolic; 12024 exp_desc->has_constructor = exp_desc_l.has_constructor; 12025 exp_desc->constant = exp_desc_l.constant; 12026 exp_desc->foldable = exp_desc_l.foldable; 12027 exp_desc->will_fold_later = exp_desc_l.will_fold_later; 12028 12029 type_idx = ATD_TYPE_IDX(stmt_func_idx); 12030 12031 exp_desc->type_idx = ATD_TYPE_IDX(stmt_func_idx); 12032 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 12033 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 12034 12035 if (exp_desc->type == Character) { 12036 exp_desc->char_len.fld = TYP_FLD(exp_desc->type_idx); 12037 exp_desc->char_len.idx = TYP_IDX(exp_desc->type_idx); 12038 OPND_LINE_NUM(exp_desc->char_len) = line; 12039 OPND_COL_NUM(exp_desc->char_len) = col; 12040 } 12041 12042 if (ok && 12043 ASG_EXTN(exp_desc->linear_type, exp_desc_l.linear_type) && 12044 (exp_desc_l.type == Character || 12045 exp_desc_l.linear_type == Short_Typeless_Const)) { 12046 find_opnd_line_and_column(&stmt_func_opnd, 12047 &opnd_line, 12048 &opnd_col); 12049 if (exp_desc_l.type == Character) { 12050 PRINTMSG(opnd_line, 161, Ansi, opnd_col); 12051 } 12052 12053 12054 OPND_IDX(stmt_func_opnd) = 12055 cast_typeless_constant(OPND_IDX(stmt_func_opnd), 12056 type_idx, 12057 opnd_line, 12058 opnd_col); 12059 12060 exp_desc_l.type_idx = type_idx; 12061 exp_desc_l.type = TYP_TYPE(type_idx); 12062 exp_desc_l.linear_type = TYP_LINEAR(type_idx); 12063 } 12064 else if (ok && 12065 TYP_TYPE(type_idx) != Character && 12066 TYP_TYPE(type_idx) != Structure && 12067 TYP_LINEAR(type_idx) != exp_desc_l.linear_type) { 12068 12069 cast_to_type_idx(&stmt_func_opnd, 12070 &exp_desc_l, 12071 exp_desc->type_idx); 12072 } 12073 12074 if (! ok) { 12075 /* intentionally blank */ 12076 } 12077 else if (TYP_TYPE(type_idx) == Character && 12078 exp_desc_l.type == Character && 12079 TYP_FLD(type_idx) == CN_Tbl_Idx && 12080 TYP_FLD(exp_desc_l.type_idx) == CN_Tbl_Idx && 12081 fold_relationals(TYP_IDX(type_idx), 12082 TYP_IDX(exp_desc_l.type_idx), 12083 Eq_Opr)) { 12084 12085 /* intentionally blank */ 12086 } 12087 else if (TYP_TYPE(type_idx) == Character && 12088 exp_desc_l.type == Character && 12089 TYP_FLD(type_idx) == CN_Tbl_Idx && 12090 OPND_FLD(stmt_func_opnd) == CN_Tbl_Idx) { 12091 12092 save_check_type_conversion = check_type_conversion; 12093 save_target_type_idx = target_type_idx; 12094 save_target_char_len_idx = target_char_len_idx; 12095 12096 check_type_conversion = TRUE; 12097 target_type_idx = Character_1; 12098 target_char_len_idx = TYP_IDX(type_idx); 12099 fold_aggragate_expression(&stmt_func_opnd, &exp_desc_l, TRUE); 12100 12101 check_type_conversion = save_check_type_conversion; 12102 target_type_idx = save_target_type_idx; 12103 target_char_len_idx = save_target_char_len_idx; 12104 } 12105 else if (! no_func_expansion && 12106 TYP_TYPE(type_idx) == Character) { 12107 12108 /* pull stmt func into tmp to handle padding or trunc */ 12109 12110 GEN_COMPILER_TMP_ASG(asg_idx, 12111 tmp_idx, 12112 TRUE, /* Semantics done */ 12113 line, 12114 col, 12115 type_idx, 12116 Priv); 12117 12118 COPY_OPND(IR_OPND_R(asg_idx), stmt_func_opnd); 12119 OPND_FLD(opnd) = AT_Tbl_Idx; 12120 OPND_IDX(opnd) = tmp_idx; 12121 OPND_LINE_NUM(opnd) = line; 12122 OPND_COL_NUM(opnd) = col; 12123 ok = gen_whole_substring(&opnd, 0); 12124 COPY_OPND(IR_OPND_L(asg_idx), opnd); 12125 12126 /* This is no longer a foldable operand. */ 12127 exp_desc->constant = FALSE; 12128 exp_desc->foldable = FALSE; 12129 exp_desc->will_fold_later = FALSE; 12130 12131 12132 gen_sh(Before, Assignment_Stmt, line, col, 12133 FALSE, FALSE, TRUE); 12134 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 12135 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 12136 12137 COPY_OPND(stmt_func_opnd, IR_OPND_L(asg_idx)); 12138 } 12139 12140 12141 COPY_OPND((*result_opnd), stmt_func_opnd); 12142 12143 if (OPND_FLD((*result_opnd)) != CN_Tbl_Idx && 12144 ! exp_desc->reference && 12145 ! exp_desc->tmp_reference) { 12146 12147 /* put a paren opr over the statement function so pdgcs doesn't */ 12148 /* reassociate anything in the expanded tree. */ 12149 12150 NTR_IR_TBL(paren_idx); 12151 IR_OPR(paren_idx) = Paren_Opr; 12152 IR_TYPE_IDX(paren_idx) = exp_desc->type_idx; 12153 IR_LINE_NUM(paren_idx) = line; 12154 IR_COL_NUM(paren_idx) = col; 12155 12156 COPY_OPND(IR_OPND_L(paren_idx), (*result_opnd)); 12157 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 12158 OPND_IDX((*result_opnd)) = paren_idx; 12159 } 12160 12161 /* clear the stmt func active flag on stmt_func_idx */ 12162 12163 ATS_SF_ACTIVE(stmt_func_idx) = FALSE; 12164 12165 /* restore arg_info_list to previous "stack frame" */ 12166 12167 arg_info_list_top = arg_info_list_base; 12168 arg_info_list_base = save_arg_info_list_base; 12169 12170 if (TYP_TYPE(type_idx) == Character) { 12171 io_item_must_flatten = save_io_item_must_flatten; 12172 } 12173 12174 EXIT: 12175 12176 defer_stmt_expansion = save_defer_stmt_expansion; 12177 stmt_expansion_control_end(result_opnd); 12178 12179 TRACE (Func_Exit, "stmt_func_call_opr_handler", NULL); 12180 12181 return(ok); 12182 12183 } /* stmt_func_call_opr_handler */ 12184 12185 /******************************************************************************\ 12186 |* *| 12187 |* Description: *| 12188 |* If possible, check substring bounds. *| 12189 |* *| 12190 |* Input parameters: *| 12191 |* NONE *| 12192 |* *| 12193 |* Output parameters: *| 12194 |* NONE *| 12195 |* *| 12196 |* Returns: *| 12197 |* NOTHING *| 12198 |* *| 12199 \******************************************************************************/ 12200 12201 boolean check_substring_bounds(int ir_idx) 12202 12203 { 12204 int base_attr; 12205 int col; 12206 int line; 12207 boolean ok = TRUE; 12208 int type_idx; 12209 12210 TRACE (Func_Entry, "check_substring_bounds", NULL); 12211 12212 if (IR_FLD_L(ir_idx) == CN_Tbl_Idx) { 12213 type_idx = CN_TYPE_IDX(IR_IDX_L(ir_idx)); 12214 } 12215 else { 12216 base_attr = find_base_attr(&(IR_OPND_L(ir_idx)), &line, &col); 12217 type_idx = ATD_TYPE_IDX(base_attr); 12218 } 12219 12220 if (IL_FLD(IR_IDX_R(ir_idx)) == CN_Tbl_Idx && 12221 IL_FLD(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))) == CN_Tbl_Idx && 12222 fold_relationals(IL_IDX(IR_IDX_R(ir_idx)), 12223 IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))), 12224 Le_Opr) && 12225 TYP_FLD(type_idx) == CN_Tbl_Idx) { 12226 12227 /* check range */ 12228 12229 if (compare_cn_and_value(IL_IDX(IR_IDX_R(ir_idx)), 1, Lt_Opr)) { 12230 12231 /* out of range, below */ 12232 12233 find_opnd_line_and_column((opnd_type *) 12234 &IL_OPND(IR_IDX_R(ir_idx)), 12235 &line, 12236 &col); 12237 # if 0 12238 PRINTMSG(line, 1634, Warning, col); 12239 # else 12240 PRINTMSG(line, 781, Error, col); 12241 ok = FALSE; 12242 # endif 12243 } 12244 else if (fold_relationals(IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))), 12245 TYP_IDX(type_idx), 12246 Gt_Opr)) { 12247 12248 /* out of range, above */ 12249 12250 find_opnd_line_and_column((opnd_type *)&IL_OPND(IL_NEXT_LIST_IDX( 12251 IR_IDX_R(ir_idx))), 12252 &line, 12253 &col); 12254 # if 0 12255 PRINTMSG(line, 1634, Warning, col); 12256 # else 12257 PRINTMSG(line, 781, Error, col); 12258 ok = FALSE; 12259 # endif 12260 } 12261 } 12262 12263 TRACE (Func_Exit, "check_substring_bounds", NULL); 12264 12265 return(ok); 12266 12267 } /* check_substring_bounds */ 12268 12269 /******************************************************************************\ 12270 |* *| 12271 |* Description: *| 12272 |* <description> *| 12273 |* *| 12274 |* Input parameters: *| 12275 |* NONE *| 12276 |* *| 12277 |* Output parameters: *| 12278 |* NONE *| 12279 |* *| 12280 |* Returns: *| 12281 |* NOTHING *| 12282 |* *| 12283 \******************************************************************************/ 12284 12285 boolean check_array_bounds(int ir_idx) 12286 12287 { 12288 int base_attr; 12289 int bd_idx; 12290 boolean check_ub = TRUE; 12291 opnd_type cond_opnd; 12292 opnd_type end_opnd; 12293 opnd_type inc_opnd; 12294 opnd_type lb_opnd; 12295 int line; 12296 int list_idx; 12297 int col; 12298 int i; 12299 boolean ok = TRUE; 12300 opnd_type start_opnd; 12301 opnd_type ub_opnd; 12302 12303 12304 TRACE (Func_Entry, "check_array_bounds", NULL); 12305 12306 if (! needs_bounds_check(ir_idx)) { 12307 goto EXIT; 12308 } 12309 12310 base_attr = find_base_attr(&(IR_OPND_L(ir_idx)), &line, &col); 12311 12312 bd_idx = ATD_ARRAY_IDX(base_attr); 12313 12314 /* if (BD_ARRAY_CLASS(bd_idx) != Explicit_Shape && 12315 (BD_ARRAY_CLASS(bd_idx) != Assumed_Size || 12316 BD_RANK(bd_idx) == 1)) { 12317 12318 goto EXIT; 12319 } */ 12320 12321 list_idx = IR_IDX_R(ir_idx); 12322 i = 1; 12323 12324 while (list_idx != NULL_IDX) { 12325 12326 if (IL_PE_SUBSCRIPT(list_idx) && 12327 ATD_PE_ARRAY_IDX(base_attr) != NULL_IDX && 12328 bd_idx != ATD_PE_ARRAY_IDX(base_attr)) { 12329 12330 bd_idx = ATD_PE_ARRAY_IDX(base_attr); 12331 i = 1; 12332 12333 check_ub = TRUE; 12334 12335 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size && 12336 i == BD_RANK(bd_idx)) { 12337 check_ub = FALSE; 12338 } 12339 } 12340 12341 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 12342 if (BD_LB_FLD(bd_idx, i) == CN_Tbl_Idx && 12343 fold_relationals(IL_IDX(list_idx), BD_LB_IDX(bd_idx, i), Lt_Opr)) { 12344 12345 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx), 12346 &line, 12347 &col); 12348 # if 0 12349 PRINTMSG(line, 1633, Warning, col, i); 12350 # else 12351 PRINTMSG(line, 1197, Error, col, i); 12352 ok = FALSE; 12353 # endif 12354 } 12355 else if (BD_UB_FLD(bd_idx, i) == CN_Tbl_Idx && 12356 check_ub && 12357 fold_relationals(IL_IDX(list_idx), BD_UB_IDX(bd_idx, i), Gt_Opr)) { 12358 12359 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx), 12360 &line, 12361 &col); 12362 # if 0 12363 PRINTMSG(line, 1633, Warning, col, i); 12364 # else 12365 PRINTMSG(line, 1197, Error, col, i); 12366 ok = FALSE; 12367 # endif 12368 } 12369 } 12370 else if (IL_FLD(list_idx) == IR_Tbl_Idx && 12371 check_ub && 12372 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr && 12373 IL_FLD(IR_IDX_L(IL_IDX(list_idx))) == CN_Tbl_Idx && 12374 IL_FLD(IL_NEXT_LIST_IDX(IR_IDX_L(IL_IDX(list_idx)))) 12375 == CN_Tbl_Idx && 12376 IL_FLD(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX( 12377 IR_IDX_L(IL_IDX(list_idx))))) == CN_Tbl_Idx && 12378 BD_LB_FLD(bd_idx, i) == CN_Tbl_Idx && 12379 BD_UB_FLD(bd_idx, i) == CN_Tbl_Idx) { 12380 12381 COPY_OPND(start_opnd, 12382 IL_OPND(IR_IDX_L(IL_IDX(list_idx)))); 12383 12384 COPY_OPND(end_opnd, 12385 IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L(IL_IDX(list_idx))))); 12386 12387 COPY_OPND(inc_opnd, 12388 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L( 12389 IL_IDX(list_idx)))))); 12390 12391 gen_opnd(&lb_opnd, 12392 BD_LB_IDX(bd_idx, i), 12393 BD_LB_FLD(bd_idx, i), 12394 line, 12395 col); 12396 12397 gen_opnd(&ub_opnd, 12398 BD_UB_IDX(bd_idx, i), 12399 BD_UB_FLD(bd_idx, i), 12400 line, 12401 col); 12402 12403 gen_rbounds_condition(&cond_opnd, 12404 &start_opnd, 12405 &end_opnd, 12406 &inc_opnd, 12407 &lb_opnd, 12408 &ub_opnd, 12409 line, 12410 col); 12411 12412 # ifdef _DEBUG 12413 if (OPND_FLD(cond_opnd) != CN_Tbl_Idx || 12414 TYP_TYPE(CN_TYPE_IDX(OPND_IDX(cond_opnd))) != Logical) { 12415 PRINTMSG(line, 626, Internal, col, 12416 "LOGICAL CN_Tbl_Idx", "check_array_bounds"); 12417 } 12418 # endif 12419 12420 if (THIS_IS_TRUE(&CN_CONST(OPND_IDX(cond_opnd)), 12421 CN_TYPE_IDX(OPND_IDX(cond_opnd)))) { 12422 12423 find_opnd_line_and_column(&start_opnd, &line, &col); 12424 # if 0 12425 PRINTMSG(line, 1633, Warning, col, i); 12426 # else 12427 PRINTMSG(line, 1197, Error, col, i); 12428 ok = FALSE; 12429 # endif 12430 } 12431 } 12432 12433 i++; 12434 list_idx = IL_NEXT_LIST_IDX(list_idx); 12435 12436 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size && 12437 i == BD_RANK(bd_idx)) { 12438 check_ub = FALSE; 12439 } 12440 } 12441 12442 EXIT: 12443 12444 TRACE (Func_Exit, "check_array_bounds", NULL); 12445 12446 return(ok); 12447 12448 } /* check_array_bounds */ 12449 12450 /******************************************************************************\ 12451 |* *| 12452 |* Description: *| 12453 |* Count the greatest depth of implied do's in an array constructor. *| 12454 |* *| 12455 |* Input parameters: *| 12456 |* NONE *| 12457 |* *| 12458 |* Output parameters: *| 12459 |* NONE *| 12460 |* *| 12461 |* Returns: *| 12462 |* NOTHING *| 12463 |* *| 12464 \******************************************************************************/ 12465 12466 static int implied_do_depth(opnd_type *top_opnd) 12467 12468 { 12469 int depth = 0; 12470 int i; 12471 int ir_idx; 12472 int list_idx; 12473 opnd_type opnd; 12474 12475 TRACE (Func_Entry, "implied_do_depth", NULL); 12476 12477 switch (OPND_FLD((*top_opnd))) { 12478 case IR_Tbl_Idx: 12479 ir_idx = OPND_IDX((*top_opnd)); 12480 if (IR_OPR(ir_idx) == Implied_Do_Opr) { 12481 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 12482 i = implied_do_depth(&opnd); 12483 depth = i + 1; 12484 } 12485 else { 12486 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 12487 depth = implied_do_depth(&opnd); 12488 12489 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 12490 i = implied_do_depth(&opnd); 12491 if (i > depth) 12492 depth = i; 12493 } 12494 break; 12495 case IL_Tbl_Idx: 12496 list_idx = OPND_IDX((*top_opnd)); 12497 while (list_idx) { 12498 COPY_OPND(opnd, IL_OPND(list_idx)); 12499 i = implied_do_depth(&opnd); 12500 if (i > depth) 12501 depth = i; 12502 list_idx = IL_NEXT_LIST_IDX(list_idx); 12503 } 12504 break; 12505 } 12506 12507 TRACE (Func_Exit, "implied_do_depth", NULL); 12508 12509 return(depth); 12510 12511 } /* implied_do_depth */ 12512 12513 /******************************************************************************\ 12514 |* *| 12515 |* Description: *| 12516 |* <description> *| 12517 |* *| 12518 |* Input parameters: *| 12519 |* NONE *| 12520 |* *| 12521 |* Output parameters: *| 12522 |* NONE *| 12523 |* *| 12524 |* Returns: *| 12525 |* NOTHING *| 12526 |* *| 12527 \******************************************************************************/ 12528 12529 static long64 outer_imp_do_count(opnd_type *size_opnd) 12530 12531 { 12532 int col; 12533 long64 count = 0; 12534 int div_idx; 12535 opnd_type end_opnd; 12536 expr_arg_type exp_desc; 12537 opnd_type inc_opnd; 12538 int ir_idx; 12539 int line; 12540 int list_idx; 12541 int minus_idx; 12542 boolean ok; 12543 opnd_type opnd; 12544 int plus_idx; 12545 cif_usage_code_type save_xref_state; 12546 opnd_type start_opnd; 12547 12548 12549 TRACE (Func_Entry, "outer_imp_do_count", NULL); 12550 12551 COPY_OPND(opnd, (*size_opnd)); 12552 12553 while (OPND_FLD(opnd) == IR_Tbl_Idx && 12554 IR_OPR(OPND_IDX(opnd)) != Implied_Do_Opr) { 12555 COPY_OPND(opnd, IR_OPND_R(OPND_IDX(opnd))); 12556 } 12557 12558 if (OPND_FLD(opnd) != IR_Tbl_Idx || 12559 IR_OPR(OPND_IDX(opnd)) != Implied_Do_Opr) { 12560 12561 goto EXIT; 12562 } 12563 12564 ir_idx = OPND_IDX(opnd); 12565 12566 line = IR_LINE_NUM(ir_idx); 12567 col = IR_COL_NUM(ir_idx); 12568 12569 list_idx = IR_IDX_R(ir_idx); 12570 12571 list_idx = IL_NEXT_LIST_IDX(list_idx); 12572 COPY_OPND(start_opnd, IL_OPND(list_idx)); 12573 12574 list_idx = IL_NEXT_LIST_IDX(list_idx); 12575 COPY_OPND(end_opnd, IL_OPND(list_idx)); 12576 12577 list_idx = IL_NEXT_LIST_IDX(list_idx); 12578 COPY_OPND(inc_opnd, IL_OPND(list_idx)); 12579 12580 minus_idx = gen_ir(OPND_FLD(end_opnd), OPND_IDX(end_opnd), 12581 Minus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, 12582 OPND_FLD(start_opnd),OPND_IDX(start_opnd)); 12583 12584 plus_idx = gen_ir(IR_Tbl_Idx, minus_idx, 12585 Plus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, 12586 OPND_FLD(inc_opnd), OPND_IDX(inc_opnd)); 12587 12588 div_idx = gen_ir(IR_Tbl_Idx, plus_idx, 12589 Div_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, 12590 OPND_FLD(inc_opnd), OPND_IDX(inc_opnd)); 12591 12592 gen_opnd(&opnd, div_idx, IR_Tbl_Idx, line, col); 12593 12594 exp_desc = init_exp_desc; 12595 exp_desc.rank = 0; 12596 save_xref_state = xref_state; 12597 xref_state = CIF_No_Usage_Rec; 12598 ok = expr_semantics(&opnd, &exp_desc); 12599 xref_state = save_xref_state; 12600 12601 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 12602 count = CN_INT_TO_C(OPND_IDX(opnd)); 12603 } 12604 12605 EXIT: 12606 12607 TRACE (Func_Exit, "outer_imp_do_count", NULL); 12608 12609 return(count); 12610 12611 } /* outer_imp_do_count */ 12612 12613 # if defined(COARRAY_FORTRAN) 12614 /******************************************************************************\ 12615 |* *| 12616 |* Description: *| 12617 |* Top level routine for f-- distant ref translation. This routine calls *| 12618 |* the appropriate routine depending on whether the object is a dope *| 12619 |* vector or not. *| 12620 |* *| 12621 |* Input parameters: *| 12622 |* NONE *| 12623 |* *| 12624 |* Output parameters: *| 12625 |* NONE *| 12626 |* *| 12627 |* Returns: *| 12628 |* NOTHING *| 12629 |* *| 12630 \******************************************************************************/ 12631 12632 void translate_distant_ref(opnd_type *result_opnd, 12633 expr_arg_type *exp_desc, 12634 int pe_dim_list_idx) 12635 12636 { 12637 int attr_idx; 12638 boolean save_defer_stmt_expansion; 12639 int sub_idx; 12640 12641 # if defined(_TARGET_OS_MAX) 12642 int line; 12643 int col; 12644 # endif 12645 12646 12647 TRACE (Func_Entry, "translate_distant_ref", NULL); 12648 12649 # if defined(_TARGET_OS_MAX) 12650 12651 if (IL_FLD(pe_dim_list_idx) == IR_Tbl_Idx && 12652 IR_OPR(IL_IDX(pe_dim_list_idx)) == My_Pe_Opr) { 12653 12654 /* nothing to do, intentionally blank */ 12655 12656 return; 12657 } 12658 12659 if (storage_bit_size_tbl[exp_desc->linear_type] != 64 && 12660 (exp_desc->type != Structure || 12661 ! in_component_ref)) { 12662 12663 find_opnd_line_and_column(result_opnd, &line, &col); 12664 PRINTMSG(line, 1585, Error, col); 12665 } 12666 12667 # endif 12668 12669 stmt_expansion_control_start(); 12670 save_defer_stmt_expansion = defer_stmt_expansion; 12671 defer_stmt_expansion = FALSE; 12672 12673 io_item_must_flatten = TRUE; 12674 12675 sub_idx = OPND_IDX((*result_opnd)); 12676 12677 while (IR_FLD_L(sub_idx) != AT_Tbl_Idx) { 12678 sub_idx = IR_IDX_L(sub_idx); 12679 } 12680 12681 attr_idx = IR_IDX_L(sub_idx); 12682 12683 # if defined(_TARGET_OS_MAX) 12684 translate_t3e_distant_ref(result_opnd, exp_desc, pe_dim_list_idx); 12685 # else 12686 if (ATD_IM_A_DOPE(attr_idx)) { 12687 translate_distant_dv_ref(result_opnd, exp_desc, pe_dim_list_idx); 12688 } 12689 else if (dump_flags.fmm1) { 12690 translate_distant_ref1(result_opnd, exp_desc, pe_dim_list_idx); 12691 } 12692 else { 12693 translate_distant_ref2(result_opnd, exp_desc, pe_dim_list_idx); 12694 } 12695 # endif 12696 12697 exp_desc->pe_dim_ref = TRUE; 12698 12699 defer_stmt_expansion = save_defer_stmt_expansion; 12700 stmt_expansion_control_end(result_opnd); 12701 12702 TRACE (Func_Exit, "translate_distant_ref", NULL); 12703 12704 return; 12705 12706 } /* translate_distant_ref */ 12707 12708 /******************************************************************************\ 12709 |* *| 12710 |* Description: *| 12711 |* Translate pe dimension dope vector reference. A temp dope vector is *| 12712 |* created with the adjusted address. *| 12713 |* *| 12714 |* Input parameters: *| 12715 |* NONE *| 12716 |* *| 12717 |* Output parameters: *| 12718 |* NONE *| 12719 |* *| 12720 |* Returns: *| 12721 |* NOTHING *| 12722 |* *| 12723 \******************************************************************************/ 12724 12725 static void translate_distant_dv_ref(opnd_type *result_opnd, 12726 expr_arg_type *exp_desc, 12727 int pe_dim_list_idx) 12728 12729 { 12730 int bd_idx; 12731 int col; 12732 int deref_idx; 12733 int dv_idx; 12734 int i; 12735 int ir_idx; 12736 int ir_idx2; 12737 int line; 12738 int list_idx; 12739 opnd_type opnd; 12740 int plus_idx; 12741 int sub_idx = NULL_IDX; 12742 int tmp_dv_idx; 12743 12744 TRACE (Func_Entry, "translate_distant_dv_ref", NULL); 12745 12746 find_opnd_line_and_column(result_opnd, &line, &col); 12747 12748 deref_idx = OPND_IDX((*result_opnd)); 12749 12750 while (IR_FLD_L(deref_idx) != AT_Tbl_Idx) { 12751 if (IR_OPR(IR_IDX_L(deref_idx)) == Dv_Deref_Opr) { 12752 sub_idx = deref_idx; 12753 } 12754 deref_idx = IR_IDX_L(deref_idx); 12755 } 12756 12757 # if defined(_DEBUG) 12758 if (sub_idx == NULL_IDX) { 12759 PRINTMSG(line, 626, Internal, col, 12760 "Subscript_Opr", "translate_distant_dv_ref"); 12761 } 12762 # endif 12763 12764 dv_idx = IR_IDX_L(deref_idx); 12765 12766 if (ATD_ARRAY_IDX(dv_idx) != NULL_IDX) { 12767 list_idx = IR_IDX_R(sub_idx); 12768 12769 for (i = 1; i < BD_RANK(ATD_ARRAY_IDX(dv_idx)); i++) { 12770 list_idx = IL_NEXT_LIST_IDX(list_idx); 12771 } 12772 12773 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 12774 IR_LIST_CNT_R(sub_idx) = BD_RANK(ATD_ARRAY_IDX(dv_idx)); 12775 } 12776 12777 tmp_dv_idx = gen_compiler_tmp(line, col, Priv, TRUE); 12778 ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(dv_idx); 12779 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 12780 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE; 12781 ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(dv_idx); 12782 ATD_POINTER(tmp_dv_idx) = ATD_POINTER(dv_idx); 12783 12784 NTR_IR_TBL(ir_idx); 12785 IR_OPR(ir_idx) = Dv_Whole_Copy_Opr; 12786 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 12787 IR_LINE_NUM(ir_idx) = line; 12788 IR_COL_NUM(ir_idx) = col; 12789 12790 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 12791 IR_IDX_L(ir_idx) = tmp_dv_idx; 12792 IR_LINE_NUM_L(ir_idx) = line; 12793 IR_COL_NUM_L(ir_idx) = col; 12794 12795 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 12796 IR_IDX_R(ir_idx) = dv_idx; 12797 IR_LINE_NUM_R(ir_idx) = line; 12798 IR_COL_NUM_R(ir_idx) = col; 12799 12800 gen_sh(Before, Assignment_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 12801 SH_COL_NUM(curr_stmt_sh_idx), FALSE, FALSE, TRUE); 12802 12803 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 12804 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 12805 12806 bd_idx = ATD_PE_ARRAY_IDX(dv_idx); 12807 12808 linearize_pe_dims(pe_dim_list_idx, 12809 bd_idx, 12810 line, 12811 col, 12812 &opnd); 12813 12814 /* generate reference to bias component of pe_offset_attr */ 12815 12816 gen_bias_ref(&opnd); 12817 12818 COPY_OPND((exp_desc->bias_opnd), opnd); 12819 12820 /* increment the base address by the bias_opnd */ 12821 12822 NTR_IR_TBL(ir_idx); 12823 IR_OPR(ir_idx) = Dv_Set_Base_Addr; 12824 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 12825 IR_LINE_NUM(ir_idx) = line; 12826 IR_COL_NUM(ir_idx) = col; 12827 12828 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 12829 IR_IDX_L(ir_idx) = tmp_dv_idx; 12830 IR_LINE_NUM_L(ir_idx) = line; 12831 IR_COL_NUM_L(ir_idx) = col; 12832 12833 NTR_IR_TBL(plus_idx); 12834 IR_OPR(plus_idx) = Plus_Opr; 12835 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE; 12836 IR_LINE_NUM(plus_idx) = line; 12837 IR_COL_NUM(plus_idx) = col; 12838 12839 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 12840 IR_IDX_R(ir_idx) = plus_idx; 12841 12842 COPY_OPND(IR_OPND_R(plus_idx), opnd); 12843 12844 NTR_IR_TBL(ir_idx2); 12845 IR_OPR(ir_idx2) = Dv_Access_Base_Addr; 12846 IR_TYPE_IDX(ir_idx2) = SA_INTEGER_DEFAULT_TYPE; 12847 IR_LINE_NUM(ir_idx2) = line; 12848 IR_COL_NUM(ir_idx2) = col; 12849 12850 IR_FLD_L(ir_idx2) = AT_Tbl_Idx; 12851 IR_IDX_L(ir_idx2) = tmp_dv_idx; 12852 IR_LINE_NUM_L(ir_idx2) = line; 12853 IR_COL_NUM_L(ir_idx2) = col; 12854 12855 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 12856 IR_IDX_L(plus_idx) = ir_idx2; 12857 12858 gen_sh(Before, Assignment_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 12859 SH_COL_NUM(curr_stmt_sh_idx), FALSE, FALSE, TRUE); 12860 12861 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 12862 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 12863 12864 12865 /* now replace the original dv_idx with the tmp_dv_idx */ 12866 12867 IR_IDX_L(deref_idx) = tmp_dv_idx; 12868 12869 TRACE (Func_Exit, "translate_distant_dv_ref", NULL); 12870 12871 return; 12872 12873 } /* translate_distant_dv_ref */ 12874 12875 /******************************************************************************\ 12876 |* *| 12877 |* Description: *| 12878 |* Linearize the pe dimensions so that there is one pe dimension. *| 12879 |* *| 12880 |* Input parameters: *| 12881 |* NONE *| 12882 |* *| 12883 |* Output parameters: *| 12884 |* NONE *| 12885 |* *| 12886 |* Returns: *| 12887 |* NOTHING *| 12888 |* *| 12889 \******************************************************************************/ 12890 # if defined(_TARGET_OS_MAX) 12891 12892 static void translate_t3e_distant_ref(opnd_type *result_opnd, 12893 expr_arg_type *exp_desc, 12894 int pe_dim_list_idx) 12895 12896 { 12897 int attr_idx; 12898 int bd_idx; 12899 int col; 12900 int i; 12901 int line; 12902 int list_idx; 12903 expr_arg_type loc_exp_desc; 12904 boolean ok; 12905 opnd_type opnd; 12906 cif_usage_code_type save_xref_state; 12907 int sub_idx; 12908 12909 12910 TRACE (Func_Entry, "translate_t3e_distant_ref", NULL); 12911 12912 find_opnd_line_and_column(result_opnd, &line, &col); 12913 12914 sub_idx = OPND_IDX((*result_opnd)); 12915 12916 while (IR_FLD_L(sub_idx) != AT_Tbl_Idx && 12917 (IR_FLD_L(sub_idx) != IR_Tbl_Idx || 12918 IR_OPR(IR_IDX_L(sub_idx)) != Dv_Deref_Opr)) { 12919 sub_idx = IR_IDX_L(sub_idx); 12920 } 12921 12922 if (IR_FLD_L(sub_idx) == AT_Tbl_Idx) { 12923 attr_idx = IR_IDX_L(sub_idx); 12924 } 12925 else { 12926 attr_idx = IR_IDX_L(IR_IDX_L(sub_idx)); 12927 } 12928 12929 bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 12930 12931 linearize_pe_dims(pe_dim_list_idx, 12932 bd_idx, 12933 line, 12934 col, 12935 &opnd); 12936 12937 save_xref_state = xref_state; 12938 xref_state = CIF_No_Usage_Rec; 12939 loc_exp_desc.rank = 0; 12940 ok = expr_semantics(&opnd, &loc_exp_desc); 12941 xref_state = save_xref_state; 12942 12943 COPY_OPND((exp_desc->bias_opnd), opnd); 12944 12945 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 12946 list_idx = IR_IDX_R(sub_idx); 12947 12948 for (i = 0; i < BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) { 12949 list_idx = IL_NEXT_LIST_IDX(list_idx); 12950 } 12951 12952 # ifdef _DEBUG 12953 if (list_idx != pe_dim_list_idx) { 12954 PRINTMSG(line, 626, Internal, col, 12955 "list_idx != pe_dim_list_idx", 12956 "translate_t3e_distant_ref"); 12957 } 12958 # endif 12959 12960 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 12961 IR_LIST_CNT_R(sub_idx) = BD_RANK(ATD_ARRAY_IDX(attr_idx)) + 1; 12962 } 12963 else { 12964 IL_NEXT_LIST_IDX(pe_dim_list_idx) = NULL_IDX; 12965 IR_LIST_CNT_R(sub_idx) = 1; 12966 } 12967 12968 COPY_OPND(IL_OPND(pe_dim_list_idx), opnd); 12969 12970 TRACE (Func_Exit, "translate_t3e_distant_ref", NULL); 12971 12972 return; 12973 12974 } /* translate_t3e_distant_ref */ 12975 # endif 12976 12977 /******************************************************************************\ 12978 |* *| 12979 |* Description: *| 12980 |* Translate pe dimension references into pointer/pointee pair. *| 12981 |* *| 12982 |* Input parameters: *| 12983 |* NONE *| 12984 |* *| 12985 |* Output parameters: *| 12986 |* NONE *| 12987 |* *| 12988 |* Returns: *| 12989 |* NOTHING *| 12990 |* *| 12991 \******************************************************************************/ 12992 12993 static void translate_distant_ref1(opnd_type *result_opnd, 12994 expr_arg_type *exp_desc, 12995 int pe_dim_list_idx) 12996 12997 { 12998 int asg_idx; 12999 int attr_idx; 13000 int bd_idx; 13001 int col; 13002 int i; 13003 int line; 13004 int list_idx; 13005 expr_arg_type loc_exp_desc; 13006 int loc_idx; 13007 boolean ok = TRUE; 13008 opnd_type opnd; 13009 int plus_idx; 13010 int ptr_idx; 13011 int ptee_idx; 13012 int save_curr_stmt_sh_idx; 13013 cif_usage_code_type save_xref_state; 13014 int sub_idx; 13015 13016 TRACE (Func_Entry, "translate_distant_ref1", NULL); 13017 13018 find_opnd_line_and_column(result_opnd, &line, &col); 13019 13020 sub_idx = OPND_IDX((*result_opnd)); 13021 13022 while (IR_FLD_L(sub_idx) != AT_Tbl_Idx) { 13023 sub_idx = IR_IDX_L(sub_idx); 13024 } 13025 13026 attr_idx = IR_IDX_L(sub_idx); 13027 13028 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 13029 list_idx = IR_IDX_R(sub_idx); 13030 13031 for (i = 1; i < BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) { 13032 list_idx = IL_NEXT_LIST_IDX(list_idx); 13033 } 13034 13035 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 13036 IR_LIST_CNT_R(sub_idx) = BD_RANK(ATD_ARRAY_IDX(attr_idx)); 13037 } 13038 13039 bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 13040 13041 /* generate the ptr/pointee pair */ 13042 13043 ptr_idx = gen_compiler_tmp(line, col, Shared, TRUE); 13044 ATD_TYPE_IDX(ptr_idx) = CRI_Ptr_8; 13045 AT_SEMANTICS_DONE(ptr_idx) = TRUE; 13046 ATD_STOR_BLK_IDX(ptr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 13047 13048 ptee_idx = gen_compiler_tmp(line, col, Shared, TRUE); 13049 ATD_CLASS(ptee_idx) = CRI__Pointee; 13050 AT_SEMANTICS_DONE(ptee_idx) = TRUE; 13051 ATD_STOR_BLK_IDX(ptee_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 13052 ATD_TYPE_IDX(ptee_idx) = ATD_TYPE_IDX(attr_idx); 13053 ATD_ARRAY_IDX(ptee_idx) = ATD_ARRAY_IDX(attr_idx); 13054 ATD_PTR_IDX(ptee_idx) = ptr_idx; 13055 13056 /* generate assignment to ptr */ 13057 13058 NTR_IR_TBL(asg_idx); 13059 IR_OPR(asg_idx) = Asg_Opr; 13060 IR_TYPE_IDX(asg_idx) = CRI_Ptr_8; 13061 IR_LINE_NUM(asg_idx) = line; 13062 IR_COL_NUM(asg_idx) = col; 13063 13064 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 13065 IR_IDX_L(asg_idx) = ptr_idx; 13066 IR_LINE_NUM_L(asg_idx) = line; 13067 IR_COL_NUM_L(asg_idx) = col; 13068 13069 NTR_IR_TBL(plus_idx); 13070 IR_OPR(plus_idx) = Plus_Opr; 13071 IR_TYPE_IDX(plus_idx) = CRI_Ptr_8; 13072 IR_LINE_NUM(plus_idx) = line; 13073 IR_COL_NUM(plus_idx) = col; 13074 13075 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 13076 IR_IDX_R(asg_idx) = plus_idx; 13077 13078 NTR_IR_TBL(loc_idx); 13079 IR_OPR(loc_idx) = Loc_Opr; 13080 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 13081 IR_LINE_NUM(loc_idx) = line; 13082 IR_COL_NUM(loc_idx) = col; 13083 13084 /* do I need to worry about a proper reference tree for loc? BHJ */ 13085 13086 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 13087 IR_IDX_L(loc_idx) = attr_idx; 13088 IR_LINE_NUM_L(loc_idx) = line; 13089 IR_COL_NUM_L(loc_idx) = col; 13090 13091 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 13092 IR_IDX_L(plus_idx) = loc_idx; 13093 13094 linearize_pe_dims(pe_dim_list_idx, 13095 bd_idx, 13096 line, 13097 col, 13098 &opnd); 13099 13100 /* generate reference to bias component of pe_offset_attr */ 13101 13102 gen_bias_ref(&opnd); 13103 13104 COPY_OPND((exp_desc->bias_opnd), opnd); 13105 13106 COPY_OPND(IR_OPND_R(plus_idx), opnd); 13107 13108 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 13109 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 13110 FALSE, FALSE, TRUE); 13111 13112 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 13113 13114 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 13115 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 13116 13117 COPY_OPND(opnd, IR_OPND_R(asg_idx)); 13118 save_xref_state = xref_state; 13119 xref_state = CIF_No_Usage_Rec; 13120 loc_exp_desc.rank = 0; 13121 ok &= expr_semantics(&opnd, &loc_exp_desc); 13122 xref_state = save_xref_state; 13123 COPY_OPND(IR_OPND_R(asg_idx), opnd); 13124 13125 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 13126 13127 13128 /* now replace the original attr with the ptee_idx */ 13129 13130 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) { 13131 if (TYP_TYPE(ATD_TYPE_IDX(ptee_idx)) == Structure) { 13132 loc_exp_desc = init_exp_desc; 13133 loc_exp_desc.type_idx = ATD_TYPE_IDX(ptee_idx); 13134 loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx); 13135 loc_exp_desc.linear_type = TYP_LINEAR(loc_exp_desc.type_idx); 13136 loc_exp_desc.rank = 1; 13137 loc_exp_desc.shape[0].fld = CN_Tbl_Idx; 13138 loc_exp_desc.shape[0].idx = CN_INTEGER_ONE_IDX; 13139 13140 ATD_ARRAY_IDX(ptee_idx) = create_bd_ntry_for_const(&loc_exp_desc, 13141 line, 13142 col); 13143 13144 NTR_IR_LIST_TBL(list_idx); 13145 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 13146 IR_LIST_CNT_R(sub_idx) = 1; 13147 IR_IDX_R(sub_idx) = list_idx; 13148 IL_FLD(list_idx) = CN_Tbl_Idx; 13149 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 13150 IL_LINE_NUM(list_idx) = line; 13151 IL_COL_NUM(list_idx) = col; 13152 13153 IR_IDX_L(sub_idx) = ptee_idx; 13154 } 13155 else if (sub_idx == OPND_IDX((*result_opnd))) { 13156 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 13157 OPND_IDX((*result_opnd)) = ptee_idx; 13158 OPND_LINE_NUM((*result_opnd)) = line; 13159 OPND_COL_NUM((*result_opnd)) = col; 13160 } 13161 else { 13162 plus_idx = OPND_IDX((*result_opnd)); 13163 13164 while (IR_IDX_L(plus_idx) != sub_idx) { 13165 plus_idx = IR_IDX_L(plus_idx); 13166 } 13167 13168 IR_FLD_L(plus_idx) = AT_Tbl_Idx; 13169 IR_IDX_L(plus_idx) = ptee_idx; 13170 IR_LINE_NUM_L(plus_idx) = line; 13171 IR_COL_NUM_L(plus_idx) = col; 13172 } 13173 } 13174 else { 13175 IR_IDX_L(sub_idx) = ptee_idx; 13176 } 13177 13178 TRACE (Func_Exit, "translate_distant_ref1", NULL); 13179 13180 return; 13181 13182 } /* translate_distant_ref1 */ 13183 13184 /******************************************************************************\ 13185 |* *| 13186 |* Description: *| 13187 |* <description> *| 13188 |* *| 13189 |* Input parameters: *| 13190 |* NONE *| 13191 |* *| 13192 |* Output parameters: *| 13193 |* NONE *| 13194 |* *| 13195 |* Returns: *| 13196 |* NOTHING *| 13197 |* *| 13198 \******************************************************************************/ 13199 13200 static void linearize_pe_dims(int pe_dim_list_idx, 13201 int bd_idx, 13202 int line, 13203 int col, 13204 opnd_type *result_opnd) 13205 13206 { 13207 int i; 13208 int list_idx; 13209 int minus_idx; 13210 int mult_idx; 13211 int plus_idx; 13212 13213 TRACE (Func_Entry, "linearize_pe_dims", NULL); 13214 13215 list_idx = pe_dim_list_idx; 13216 13217 NTR_IR_TBL(minus_idx); 13218 IR_OPR(minus_idx) = Minus_Opr; 13219 IR_TYPE_IDX(minus_idx) = INTEGER_DEFAULT_TYPE; 13220 IR_LINE_NUM(minus_idx) = line; 13221 IR_COL_NUM(minus_idx) = col; 13222 13223 NTR_IR_TBL(plus_idx); 13224 IR_OPR(plus_idx) = Plus_Opr; 13225 IR_TYPE_IDX(plus_idx) = INTEGER_DEFAULT_TYPE; 13226 IR_LINE_NUM(plus_idx) = line; 13227 IR_COL_NUM(plus_idx) = col; 13228 13229 COPY_OPND(IR_OPND_L(plus_idx), IL_OPND(list_idx)); 13230 IR_FLD_R(plus_idx) = CN_Tbl_Idx; 13231 IR_IDX_R(plus_idx) = CN_INTEGER_ONE_IDX; 13232 IR_LINE_NUM_R(plus_idx) = line; 13233 IR_COL_NUM_R(plus_idx) = col; 13234 13235 IR_FLD_L(minus_idx) = IR_Tbl_Idx; 13236 IR_IDX_L(minus_idx) = plus_idx; 13237 13238 IR_FLD_R(minus_idx) = BD_LB_FLD(bd_idx, 1); 13239 IR_IDX_R(minus_idx) = BD_LB_IDX(bd_idx, 1); 13240 IR_LINE_NUM_R(minus_idx) = line; 13241 IR_COL_NUM_R(minus_idx) = col; 13242 13243 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 13244 OPND_IDX((*result_opnd)) = minus_idx; 13245 13246 list_idx = IL_NEXT_LIST_IDX(list_idx); 13247 13248 for (i = 2; i <= BD_RANK(bd_idx); i++) { 13249 NTR_IR_TBL(plus_idx); 13250 IR_OPR(plus_idx) = Plus_Opr; 13251 IR_TYPE_IDX(plus_idx) = INTEGER_DEFAULT_TYPE; 13252 IR_LINE_NUM(plus_idx) = line; 13253 IR_COL_NUM(plus_idx) = col; 13254 13255 COPY_OPND(IR_OPND_L(plus_idx), (*result_opnd)); 13256 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 13257 OPND_IDX((*result_opnd)) = plus_idx; 13258 13259 NTR_IR_TBL(mult_idx); 13260 IR_OPR(mult_idx) = Mult_Opr; 13261 IR_TYPE_IDX(mult_idx) = INTEGER_DEFAULT_TYPE; 13262 IR_LINE_NUM(mult_idx) = line; 13263 IR_COL_NUM(mult_idx) = col; 13264 13265 NTR_IR_TBL(minus_idx); 13266 IR_OPR(minus_idx) = Minus_Opr; 13267 IR_TYPE_IDX(minus_idx) = INTEGER_DEFAULT_TYPE; 13268 IR_LINE_NUM(minus_idx) = line; 13269 IR_COL_NUM(minus_idx) = col; 13270 13271 COPY_OPND(IR_OPND_L(minus_idx), IL_OPND(list_idx)); 13272 13273 IR_FLD_R(minus_idx) = BD_LB_FLD(bd_idx, i); 13274 IR_IDX_R(minus_idx) = BD_LB_IDX(bd_idx, i); 13275 IR_LINE_NUM_R(minus_idx) = line; 13276 IR_COL_NUM_R(minus_idx) = col; 13277 13278 IR_FLD_L(mult_idx) = IR_Tbl_Idx; 13279 IR_IDX_L(mult_idx) = minus_idx; 13280 13281 IR_FLD_R(mult_idx) = BD_SM_FLD(bd_idx, i); 13282 IR_IDX_R(mult_idx) = BD_SM_IDX(bd_idx, i); 13283 IR_LINE_NUM_R(mult_idx) = line; 13284 IR_COL_NUM_R(mult_idx) = col; 13285 13286 IR_FLD_R(plus_idx) = IR_Tbl_Idx; 13287 IR_IDX_R(plus_idx) = mult_idx; 13288 13289 list_idx = IL_NEXT_LIST_IDX(list_idx); 13290 } 13291 13292 13293 TRACE (Func_Exit, "linearize_pe_dims", NULL); 13294 13295 return; 13296 13297 } /* linearize_pe_dims */ 13298 13299 /******************************************************************************\ 13300 |* *| 13301 |* Description: *| 13302 |* <description> *| 13303 |* *| 13304 |* Input parameters: *| 13305 |* NONE *| 13306 |* *| 13307 |* Output parameters: *| 13308 |* NONE *| 13309 |* *| 13310 |* Returns: *| 13311 |* NOTHING *| 13312 |* *| 13313 \******************************************************************************/ 13314 13315 void translate_dv_component(opnd_type *result_opnd, 13316 expr_arg_type *exp_desc) 13317 13318 { 13319 int col; 13320 int dv_idx; 13321 int ir_idx; 13322 int ir_idx2; 13323 int line; 13324 opnd_type opnd; 13325 int plus_idx; 13326 boolean save_defer_stmt_expansion; 13327 int tmp_dv_idx; 13328 int unused; 13329 13330 13331 TRACE (Func_Entry, "translate_dv_component", NULL); 13332 13333 stmt_expansion_control_start(); 13334 save_defer_stmt_expansion = defer_stmt_expansion; 13335 defer_stmt_expansion = FALSE; 13336 13337 io_item_must_flatten = TRUE; 13338 13339 find_opnd_line_and_column(result_opnd, &line, &col); 13340 13341 COPY_OPND(opnd, (*result_opnd)); 13342 13343 if (OPND_FLD(opnd) == IR_Tbl_Idx && 13344 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) { 13345 13346 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 13347 } 13348 13349 unused = find_left_attr(&opnd); 13350 13351 # ifdef _DEBUG 13352 if (OPND_FLD(opnd) != IR_Tbl_Idx || 13353 IR_OPR(OPND_IDX(opnd)) != Struct_Opr) { 13354 PRINTMSG(line, 626, Internal, col, 13355 "Struct_Opr", "translate_dv_component"); 13356 } 13357 # endif 13358 13359 dv_idx = IR_IDX_R(OPND_IDX(opnd)); 13360 13361 tmp_dv_idx = gen_compiler_tmp(line, col, Priv, TRUE); 13362 ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(dv_idx); 13363 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 13364 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE; 13365 ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(dv_idx); 13366 ATD_POINTER(tmp_dv_idx) = ATD_POINTER(dv_idx); 13367 13368 NTR_IR_TBL(ir_idx); 13369 IR_OPR(ir_idx) = Dv_Whole_Copy_Opr; 13370 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 13371 IR_LINE_NUM(ir_idx) = line; 13372 IR_COL_NUM(ir_idx) = col; 13373 13374 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 13375 IR_IDX_L(ir_idx) = tmp_dv_idx; 13376 IR_LINE_NUM_L(ir_idx) = line; 13377 IR_COL_NUM_L(ir_idx) = col; 13378 13379 COPY_OPND(IR_OPND_R(ir_idx), opnd); 13380 13381 gen_sh(Before, Assignment_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 13382 SH_COL_NUM(curr_stmt_sh_idx), FALSE, FALSE, TRUE); 13383 13384 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 13385 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13386 13387 /* increment the base address by the bias_opnd */ 13388 13389 NTR_IR_TBL(ir_idx); 13390 IR_OPR(ir_idx) = Dv_Set_Base_Addr; 13391 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 13392 IR_LINE_NUM(ir_idx) = line; 13393 IR_COL_NUM(ir_idx) = col; 13394 13395 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 13396 IR_IDX_L(ir_idx) = tmp_dv_idx; 13397 IR_LINE_NUM_L(ir_idx) = line; 13398 IR_COL_NUM_L(ir_idx) = col; 13399 13400 NTR_IR_TBL(plus_idx); 13401 IR_OPR(plus_idx) = Plus_Opr; 13402 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE; 13403 IR_LINE_NUM(plus_idx) = line; 13404 IR_COL_NUM(plus_idx) = col; 13405 13406 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 13407 IR_IDX_R(ir_idx) = plus_idx; 13408 13409 copy_subtree(&(exp_desc->bias_opnd), &opnd); 13410 13411 COPY_OPND(IR_OPND_R(plus_idx), opnd); 13412 13413 NTR_IR_TBL(ir_idx2); 13414 IR_OPR(ir_idx2) = Dv_Access_Base_Addr; 13415 IR_TYPE_IDX(ir_idx2) = SA_INTEGER_DEFAULT_TYPE; 13416 IR_LINE_NUM(ir_idx2) = line; 13417 IR_COL_NUM(ir_idx2) = col; 13418 13419 IR_FLD_L(ir_idx2) = AT_Tbl_Idx; 13420 IR_IDX_L(ir_idx2) = tmp_dv_idx; 13421 IR_LINE_NUM_L(ir_idx2) = line; 13422 IR_COL_NUM_L(ir_idx2) = col; 13423 13424 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 13425 IR_IDX_L(plus_idx) = ir_idx2; 13426 13427 gen_sh(Before, Assignment_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 13428 SH_COL_NUM(curr_stmt_sh_idx), FALSE, FALSE, TRUE); 13429 13430 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 13431 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13432 13433 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 13434 IR_OPR(OPND_IDX((*result_opnd))) == Dv_Deref_Opr) { 13435 13436 OPND_FLD(IR_OPND_L(OPND_IDX((*result_opnd)))) = AT_Tbl_Idx; 13437 OPND_IDX(IR_OPND_L(OPND_IDX((*result_opnd)))) = tmp_dv_idx; 13438 } 13439 else { 13440 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 13441 OPND_IDX((*result_opnd)) = tmp_dv_idx; 13442 } 13443 13444 defer_stmt_expansion = save_defer_stmt_expansion; 13445 stmt_expansion_control_end(result_opnd); 13446 13447 TRACE (Func_Exit, "translate_dv_component", NULL); 13448 13449 return; 13450 13451 } /* translate_dv_component */ 13452 13453 /******************************************************************************\ 13454 |* *| 13455 |* Description: *| 13456 |* <description> *| 13457 |* *| 13458 |* Input parameters: *| 13459 |* NONE *| 13460 |* *| 13461 |* Output parameters: *| 13462 |* NONE *| 13463 |* *| 13464 |* Returns: *| 13465 |* NOTHING *| 13466 |* *| 13467 \******************************************************************************/ 13468 13469 # ifdef _TARGET_OS_MAX 13470 static void translate_t3e_dv_component(opnd_type *result_opnd, 13471 expr_arg_type *exp_desc) 13472 13473 { 13474 /* the allocatable flag means use a ptr/pointee pair. */ 13475 /* It is on right now for all dv's. They must point to */ 13476 /* contiguous storage. Eventually, it will only be on */ 13477 /* for ALLOCATABLE arrays. */ 13478 13479 boolean allocatable = TRUE; 13480 int asg_idx; 13481 int base_attr; 13482 int col; 13483 int dv_idx; 13484 int ir_idx; 13485 int line; 13486 int list_idx; 13487 opnd_type opnd; 13488 int ptr_idx; 13489 int ptee_idx; 13490 boolean save_defer_stmt_expansion; 13491 int tmp_dv_idx; 13492 13493 13494 TRACE (Func_Entry, "translate_t3e_dv_component", NULL); 13495 13496 stmt_expansion_control_start(); 13497 save_defer_stmt_expansion = defer_stmt_expansion; 13498 defer_stmt_expansion = FALSE; 13499 13500 COPY_OPND(opnd, (*result_opnd)); 13501 13502 io_item_must_flatten = TRUE; 13503 13504 if (OPND_FLD(opnd) == IR_Tbl_Idx && 13505 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) { 13506 13507 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 13508 } 13509 13510 base_attr = find_left_attr(&opnd); 13511 dv_idx = find_base_attr(&opnd, &line, &col); 13512 13513 find_opnd_line_and_column(result_opnd, &line, &col); 13514 13515 tmp_dv_idx = gen_compiler_tmp(line, col, Priv, TRUE); 13516 ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(dv_idx); 13517 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 13518 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE; 13519 ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(dv_idx); 13520 ATD_POINTER(tmp_dv_idx) = ATD_POINTER(dv_idx); 13521 13522 NTR_IR_TBL(ir_idx); 13523 IR_OPR(ir_idx) = Dv_Whole_Copy_Opr; 13524 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 13525 IR_LINE_NUM(ir_idx) = line; 13526 IR_COL_NUM(ir_idx) = col; 13527 13528 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 13529 IR_IDX_L(ir_idx) = tmp_dv_idx; 13530 IR_LINE_NUM_L(ir_idx) = line; 13531 IR_COL_NUM_L(ir_idx) = col; 13532 13533 COPY_OPND(IR_OPND_R(ir_idx), opnd); 13534 13535 ATD_FLD(tmp_dv_idx) = OPND_FLD(opnd); 13536 ATD_TMP_IDX(tmp_dv_idx) = OPND_IDX(opnd); 13537 13538 gen_sh(Before, Assignment_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 13539 SH_COL_NUM(curr_stmt_sh_idx), FALSE, FALSE, TRUE); 13540 13541 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 13542 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13543 13544 if (allocatable) { 13545 /* generate the ptr/pointee pair */ 13546 13547 ptr_idx = gen_compiler_tmp(line, col, Shared, TRUE); 13548 ATD_TYPE_IDX(ptr_idx) = CRI_Ptr_8; 13549 AT_SEMANTICS_DONE(ptr_idx) = TRUE; 13550 ATD_STOR_BLK_IDX(ptr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 13551 13552 ptee_idx = gen_compiler_tmp(line, col, Shared, TRUE); 13553 ATD_CLASS(ptee_idx) = CRI__Pointee; 13554 AT_SEMANTICS_DONE(ptee_idx) = TRUE; 13555 ATD_STOR_BLK_IDX(ptee_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 13556 ATD_TYPE_IDX(ptee_idx) = ATD_TYPE_IDX(dv_idx); 13557 ATD_PTR_IDX(ptee_idx) = ptr_idx; 13558 13559 if (ATD_ARRAY_IDX(tmp_dv_idx) != NULL_IDX) { 13560 ATD_ARRAY_IDX(ptee_idx) = capture_bounds_from_dv(tmp_dv_idx, 13561 line, 13562 col); 13563 } 13564 13565 ATD_PE_ARRAY_IDX(ptee_idx) = ATD_PE_ARRAY_IDX(base_attr); 13566 13567 /* set ptr to BASE_ADDRESS(tmp_dv_idx) */ 13568 13569 NTR_IR_TBL(asg_idx); 13570 IR_OPR(asg_idx) = Asg_Opr; 13571 IR_TYPE_IDX(asg_idx) = CRI_Ptr_8; 13572 IR_LINE_NUM(asg_idx) = line; 13573 IR_COL_NUM(asg_idx) = col; 13574 13575 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 13576 IR_IDX_L(asg_idx) = ptr_idx; 13577 IR_LINE_NUM_L(asg_idx) = line; 13578 IR_COL_NUM_L(asg_idx) = col; 13579 13580 NTR_IR_TBL(ir_idx); 13581 IR_OPR(ir_idx) = Dv_Access_Base_Addr; 13582 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 13583 IR_LINE_NUM(ir_idx) = line; 13584 IR_COL_NUM(ir_idx) = col; 13585 13586 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 13587 IR_IDX_L(ir_idx) = tmp_dv_idx; 13588 IR_LINE_NUM_L(ir_idx) = line; 13589 IR_COL_NUM_L(ir_idx) = col; 13590 13591 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 13592 IR_IDX_R(asg_idx) = ir_idx; 13593 13594 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 13595 13596 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13597 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13598 13599 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 13600 OPND_IDX((*result_opnd)) = ptee_idx; 13601 13602 exp_desc->dope_vector = FALSE; 13603 } 13604 else { 13605 13606 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 13607 IR_OPR(OPND_IDX((*result_opnd))) == Dv_Deref_Opr) { 13608 13609 OPND_FLD(IR_OPND_L(OPND_IDX((*result_opnd)))) = AT_Tbl_Idx; 13610 OPND_IDX(IR_OPND_L(OPND_IDX((*result_opnd)))) = tmp_dv_idx; 13611 } 13612 else { 13613 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 13614 OPND_IDX((*result_opnd)) = tmp_dv_idx; 13615 } 13616 13617 ATD_PE_ARRAY_IDX(tmp_dv_idx) = ATD_PE_ARRAY_IDX(base_attr); 13618 } 13619 13620 defer_stmt_expansion = save_defer_stmt_expansion; 13621 stmt_expansion_control_end(result_opnd); 13622 13623 /* for t3e, put the linearized pe subscript on a new subscript_opr */ 13624 NTR_IR_TBL(ir_idx); 13625 IR_OPR(ir_idx) = Subscript_Opr; 13626 IR_LINE_NUM(ir_idx) = line; 13627 IR_COL_NUM(ir_idx) = col; 13628 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(tmp_dv_idx); 13629 13630 COPY_OPND(IR_OPND_L(ir_idx), (*result_opnd)); 13631 13632 NTR_IR_LIST_TBL(list_idx); 13633 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 13634 IR_IDX_R(ir_idx) = list_idx; 13635 IR_LIST_CNT_R(ir_idx) = 1; 13636 COPY_OPND(IL_OPND(list_idx), exp_desc->bias_opnd); 13637 IL_PE_SUBSCRIPT(list_idx) = TRUE; 13638 13639 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 13640 OPND_IDX((*result_opnd)) = ir_idx; 13641 13642 TRACE (Func_Exit, "translate_t3e_dv_component", NULL); 13643 13644 return; 13645 13646 } /* translate_t3e_dv_component */ 13647 # endif 13648 13649 /******************************************************************************\ 13650 |* *| 13651 |* Description: *| 13652 |* <description> *| 13653 |* *| 13654 |* Input parameters: *| 13655 |* NONE *| 13656 |* *| 13657 |* Output parameters: *| 13658 |* NONE *| 13659 |* *| 13660 |* Returns: *| 13661 |* NOTHING *| 13662 |* *| 13663 \******************************************************************************/ 13664 13665 # if defined(_TARGET_OS_MAX) 13666 static int capture_bounds_from_dv(int dv_attr_idx, 13667 int line, 13668 int col) 13669 13670 { 13671 int asg_idx; 13672 int bd_idx; 13673 opnd_type dv_opnd; 13674 int i; 13675 int ir_idx; 13676 opnd_type len_opnd; 13677 int minus_idx; 13678 opnd_type opnd; 13679 int plus_idx; 13680 int tmp_idx; 13681 13682 TRACE (Func_Entry, "capture_bounds_from_dv", NULL); 13683 13684 bd_idx = reserve_array_ntry(BD_RANK(ATD_ARRAY_IDX(dv_attr_idx))); 13685 BD_RANK(bd_idx) = BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)); 13686 BD_LINE_NUM(bd_idx) = line; 13687 BD_COLUMN_NUM(bd_idx) = col; 13688 BD_ARRAY_SIZE(bd_idx) = Var_Len_Array; 13689 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape; 13690 BD_RESOLVED(bd_idx) = TRUE; 13691 13692 gen_opnd(&dv_opnd, dv_attr_idx, AT_Tbl_Idx, line, col); 13693 13694 for (i =1; i <= BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)); i++) { 13695 13696 /* capture LB */ 13697 13698 gen_dv_access_low_bound(&opnd, &dv_opnd, i); 13699 13700 if (OPND_FLD(opnd) == CN_Tbl_Idx || 13701 (OPND_FLD(opnd) == AT_Tbl_Idx && 13702 ATD_CLASS(OPND_IDX(opnd)) == Compiler_Tmp)) { 13703 13704 BD_LB_FLD(bd_idx,i) = OPND_FLD(opnd); 13705 BD_LB_IDX(bd_idx,i) = OPND_IDX(opnd); 13706 } 13707 else { 13708 GEN_COMPILER_TMP_ASG(asg_idx, 13709 tmp_idx, 13710 TRUE, /* Semantics done*/ 13711 line, 13712 col, 13713 SA_INTEGER_DEFAULT_TYPE, 13714 Priv); 13715 13716 COPY_OPND(IR_OPND_R(asg_idx), opnd); 13717 13718 gen_sh(Before, Assignment_Stmt, line, col, 13719 FALSE, FALSE, TRUE); 13720 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13721 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13722 13723 gen_copyin_bounds_stmt(tmp_idx); 13724 13725 BD_LB_FLD(bd_idx,i) = AT_Tbl_Idx; 13726 BD_LB_IDX(bd_idx,i) = tmp_idx; 13727 } 13728 13729 /* capture XT */ 13730 13731 GEN_COMPILER_TMP_ASG(asg_idx, 13732 tmp_idx, 13733 TRUE, /* Semantics done*/ 13734 line, 13735 col, 13736 SA_INTEGER_DEFAULT_TYPE, 13737 Priv); 13738 13739 NTR_IR_TBL(ir_idx); 13740 IR_OPR(ir_idx) = Dv_Access_Extent; 13741 IR_DV_DIM(ir_idx) = i; 13742 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 13743 IR_LINE_NUM(ir_idx) = line; 13744 IR_COL_NUM(ir_idx) = col; 13745 13746 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 13747 IR_IDX_L(ir_idx) = dv_attr_idx; 13748 IR_LINE_NUM_L(ir_idx) = line; 13749 IR_COL_NUM_L(ir_idx) = col; 13750 13751 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 13752 IR_IDX_R(asg_idx) = ir_idx; 13753 13754 gen_sh(Before, Assignment_Stmt, line, col, 13755 FALSE, FALSE, TRUE); 13756 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13757 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13758 13759 gen_copyin_bounds_stmt(tmp_idx); 13760 13761 BD_XT_FLD(bd_idx,i) = AT_Tbl_Idx; 13762 BD_XT_IDX(bd_idx,i) = tmp_idx; 13763 13764 if (i == 1) { 13765 OPND_FLD(len_opnd) = AT_Tbl_Idx; 13766 OPND_IDX(len_opnd) = tmp_idx; 13767 OPND_LINE_NUM(len_opnd) = line; 13768 OPND_COL_NUM(len_opnd) = col; 13769 } 13770 else { 13771 NTR_IR_TBL(ir_idx); 13772 IR_OPR(ir_idx) = Mult_Opr; 13773 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 13774 IR_LINE_NUM(ir_idx) = line; 13775 IR_COL_NUM(ir_idx) = col; 13776 13777 COPY_OPND(IR_OPND_L(ir_idx), len_opnd); 13778 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 13779 IR_IDX_R(ir_idx) = tmp_idx; 13780 IR_LINE_NUM_R(ir_idx) = line; 13781 IR_COL_NUM_R(ir_idx) = col; 13782 13783 OPND_FLD(len_opnd) = IR_Tbl_Idx; 13784 OPND_IDX(len_opnd) = ir_idx; 13785 } 13786 13787 /* capture SM */ 13788 13789 GEN_COMPILER_TMP_ASG(asg_idx, 13790 tmp_idx, 13791 TRUE, /* Semantics done*/ 13792 line, 13793 col, 13794 SA_INTEGER_DEFAULT_TYPE, 13795 Priv); 13796 13797 NTR_IR_TBL(ir_idx); 13798 IR_OPR(ir_idx) = Dv_Access_Stride_Mult; 13799 IR_DV_DIM(ir_idx) = i; 13800 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 13801 IR_LINE_NUM(ir_idx) = line; 13802 IR_COL_NUM(ir_idx) = col; 13803 13804 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 13805 IR_IDX_L(ir_idx) = dv_attr_idx; 13806 IR_LINE_NUM_L(ir_idx) = line; 13807 IR_COL_NUM_L(ir_idx) = col; 13808 13809 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 13810 IR_IDX_R(asg_idx) = ir_idx; 13811 13812 gen_sh(Before, Assignment_Stmt, line, col, 13813 FALSE, FALSE, TRUE); 13814 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13815 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13816 13817 BD_SM_FLD(bd_idx,i) = AT_Tbl_Idx; 13818 BD_SM_IDX(bd_idx,i) = tmp_idx; 13819 13820 /* generate UB = (LB + XT) - 1 */ 13821 13822 GEN_COMPILER_TMP_ASG(asg_idx, 13823 tmp_idx, 13824 TRUE, /* Semantics done*/ 13825 line, 13826 col, 13827 SA_INTEGER_DEFAULT_TYPE, 13828 Priv); 13829 13830 NTR_IR_TBL(plus_idx); 13831 IR_OPR(plus_idx) = Plus_Opr; 13832 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 13833 IR_LINE_NUM(plus_idx) = line; 13834 IR_COL_NUM(plus_idx) = col; 13835 13836 IR_FLD_L(plus_idx) = AT_Tbl_Idx; 13837 IR_IDX_L(plus_idx) = BD_LB_IDX(bd_idx,i); 13838 IR_LINE_NUM_L(plus_idx) = line; 13839 IR_COL_NUM_L(plus_idx) = col; 13840 13841 IR_FLD_R(plus_idx) = AT_Tbl_Idx; 13842 IR_IDX_R(plus_idx) = BD_XT_IDX(bd_idx,i); 13843 IR_LINE_NUM_R(plus_idx) = line; 13844 IR_COL_NUM_R(plus_idx) = col; 13845 13846 NTR_IR_TBL(minus_idx); 13847 IR_OPR(minus_idx) = Minus_Opr; 13848 IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE; 13849 IR_LINE_NUM(minus_idx) = line; 13850 IR_COL_NUM(minus_idx) = col; 13851 13852 IR_FLD_L(minus_idx) = IR_Tbl_Idx; 13853 IR_IDX_L(minus_idx) = plus_idx; 13854 13855 IR_FLD_R(minus_idx) = CN_Tbl_Idx; 13856 IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX; 13857 IR_LINE_NUM_R(minus_idx) = line; 13858 IR_COL_NUM_R(minus_idx) = col; 13859 13860 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 13861 IR_IDX_R(asg_idx) = minus_idx; 13862 13863 gen_sh(Before, Assignment_Stmt, line, col, 13864 FALSE, FALSE, TRUE); 13865 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13866 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13867 13868 gen_copyin_bounds_stmt(tmp_idx); 13869 13870 BD_UB_FLD(bd_idx,i) = AT_Tbl_Idx; 13871 BD_UB_IDX(bd_idx,i) = tmp_idx; 13872 } 13873 13874 GEN_COMPILER_TMP_ASG(asg_idx, 13875 tmp_idx, 13876 TRUE, /* Semantics done*/ 13877 line, 13878 col, 13879 SA_INTEGER_DEFAULT_TYPE, 13880 Priv); 13881 13882 COPY_OPND(IR_OPND_R(asg_idx), len_opnd); 13883 13884 gen_sh(Before, Assignment_Stmt, line, col, 13885 FALSE, FALSE, TRUE); 13886 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13887 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13888 13889 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 13890 BD_LEN_IDX(bd_idx) = tmp_idx; 13891 13892 BD_FLOW_DEPENDENT(bd_idx) = TRUE; 13893 13894 bd_idx = ntr_array_in_bd_tbl(bd_idx); 13895 13896 TRACE (Func_Exit, "capture_bounds_from_dv", NULL); 13897 13898 return(bd_idx); 13899 13900 } /* capture_bounds_from_dv */ 13901 # endif 13902 13903 /******************************************************************************\ 13904 |* *| 13905 |* Description: *| 13906 |* Translate pe dimension refs into overindexed refs. *| 13907 |* *| 13908 |* Input parameters: *| 13909 |* NONE *| 13910 |* *| 13911 |* Output parameters: *| 13912 |* NONE *| 13913 |* *| 13914 |* Returns: *| 13915 |* NOTHING *| 13916 |* *| 13917 \******************************************************************************/ 13918 13919 static void translate_distant_ref2(opnd_type *result_opnd, 13920 expr_arg_type *exp_desc, 13921 int pe_dim_list_idx) 13922 13923 { 13924 int attr_idx; 13925 int bd_idx; 13926 long_type bytes_per_element[MAX_WORDS_FOR_INTEGER]; 13927 opnd_type bytes_opnd; 13928 int col; 13929 int div_idx; 13930 int i; 13931 int line; 13932 int list_idx; 13933 boolean ok; 13934 opnd_type opnd; 13935 int plus_idx; 13936 int plus_idx2; 13937 int sub_idx; 13938 int type_idx; 13939 int type1_idx; 13940 13941 13942 TRACE (Func_Entry, "translate_distant_ref2", NULL); 13943 13944 find_opnd_line_and_column(result_opnd, &line, &col); 13945 13946 sub_idx = OPND_IDX((*result_opnd)); 13947 13948 while (IR_FLD_L(sub_idx) != AT_Tbl_Idx) { 13949 sub_idx = IR_IDX_L(sub_idx); 13950 } 13951 13952 attr_idx = IR_IDX_L(sub_idx); 13953 13954 type_idx = ATD_TYPE_IDX(attr_idx); 13955 13956 OPND_LINE_NUM(bytes_opnd) = line; 13957 OPND_COL_NUM(bytes_opnd) = col; 13958 13959 if (TYP_TYPE(type_idx) == Structure) { 13960 # ifdef _DEBUG 13961 if (ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)) != CN_Tbl_Idx) { 13962 PRINTMSG(line, 626, Internal, col, 13963 "CN_Tbl_Idx", "translate_distant_ref2"); 13964 } 13965 # endif 13966 type1_idx = CN_TYPE_IDX(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))); 13967 13968 ok = folder_driver((char *) 13969 &CN_CONST(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))), 13970 type1_idx, 13971 (char *)&CN_CONST(CN_INTEGER_CHAR_BIT_IDX), 13972 CG_INTEGER_DEFAULT_TYPE, 13973 bytes_per_element, 13974 &type1_idx, 13975 line, 13976 col, 13977 2, 13978 Div_Opr); 13979 13980 OPND_FLD(bytes_opnd) = CN_Tbl_Idx; 13981 OPND_IDX(bytes_opnd) = ntr_const_tbl(type1_idx, 13982 FALSE, 13983 bytes_per_element); 13984 } 13985 else if (TYP_TYPE(type_idx) == Character) { 13986 OPND_FLD(bytes_opnd) = TYP_FLD(type_idx); 13987 OPND_IDX(bytes_opnd) = TYP_IDX(type_idx); 13988 } 13989 else { 13990 OPND_FLD(bytes_opnd) = CN_Tbl_Idx; 13991 OPND_IDX(bytes_opnd) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 13992 (storage_bit_size_tbl[TYP_LINEAR(type_idx)] / 8)); 13993 } 13994 13995 bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 13996 13997 NTR_IR_TBL(plus_idx); 13998 IR_OPR(plus_idx) = Plus_Opr; 13999 IR_TYPE_IDX(plus_idx) = Integer_8; 14000 IR_LINE_NUM(plus_idx) = line; 14001 IR_COL_NUM(plus_idx) = col; 14002 14003 linearize_pe_dims(pe_dim_list_idx, 14004 bd_idx, 14005 line, 14006 col, 14007 &opnd); 14008 14009 /* generate reference to bias component of pe_offset_attr */ 14010 14011 gen_bias_ref(&opnd); 14012 14013 COPY_OPND((exp_desc->bias_opnd), opnd); 14014 14015 NTR_IR_TBL(div_idx); 14016 IR_OPR(div_idx) = Div_Opr; 14017 IR_TYPE_IDX(div_idx) = INTEGER_DEFAULT_TYPE; 14018 IR_LINE_NUM(div_idx) = line; 14019 IR_COL_NUM(div_idx) = col; 14020 14021 COPY_OPND(IR_OPND_L(div_idx), opnd); 14022 COPY_OPND(IR_OPND_R(div_idx), bytes_opnd); 14023 14024 IR_FLD_R(plus_idx) = IR_Tbl_Idx; 14025 IR_IDX_R(plus_idx) = div_idx; 14026 14027 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 14028 /* add this into the first subscript */ 14029 14030 list_idx = IR_IDX_R(sub_idx); 14031 14032 if (IL_FLD(list_idx) == IR_Tbl_Idx && 14033 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) { 14034 14035 /* add to both start and end */ 14036 list_idx = IR_IDX_L(IL_IDX(list_idx)); 14037 14038 gen_opnd(&opnd, plus_idx, IR_Tbl_Idx, line, col); 14039 copy_subtree(&opnd, &opnd); 14040 plus_idx2 = OPND_IDX(opnd); 14041 COPY_OPND(IR_OPND_L(plus_idx), IL_OPND(list_idx)); 14042 IL_FLD(list_idx) = IR_Tbl_Idx; 14043 IL_IDX(list_idx) = plus_idx; 14044 14045 list_idx = IL_NEXT_LIST_IDX(list_idx); 14046 COPY_OPND(IR_OPND_L(plus_idx2), IL_OPND(list_idx)); 14047 IL_FLD(list_idx) = IR_Tbl_Idx; 14048 IL_IDX(list_idx) = plus_idx2; 14049 14050 list_idx = IR_IDX_R(sub_idx); 14051 } 14052 else { 14053 COPY_OPND(IR_OPND_L(plus_idx), IL_OPND(list_idx)); 14054 IL_FLD(list_idx) = IR_Tbl_Idx; 14055 IL_IDX(list_idx) = plus_idx; 14056 } 14057 14058 for (i = 1; i < BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) { 14059 list_idx = IL_NEXT_LIST_IDX(list_idx); 14060 } 14061 14062 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 14063 IR_LIST_CNT_R(sub_idx) = BD_RANK(ATD_ARRAY_IDX(attr_idx)); 14064 } 14065 else { 14066 COPY_OPND(IL_OPND(IR_IDX_R(sub_idx)), IR_OPND_R(plus_idx)); 14067 IL_NEXT_LIST_IDX(IR_IDX_R(sub_idx)) = NULL_IDX; 14068 IR_LIST_CNT_R(sub_idx) = 1; 14069 } 14070 14071 TRACE (Func_Exit, "translate_distant_ref2", NULL); 14072 14073 return; 14074 14075 } /* translate_distant_ref2 */ 14076 14077 /******************************************************************************\ 14078 |* *| 14079 |* Description: *| 14080 |* <description> *| 14081 |* *| 14082 |* Input parameters: *| 14083 |* NONE *| 14084 |* *| 14085 |* Output parameters: *| 14086 |* NONE *| 14087 |* *| 14088 |* Returns: *| 14089 |* NOTHING *| 14090 |* *| 14091 \******************************************************************************/ 14092 14093 static int set_up_pe_offset_attr(void) 14094 14095 { 14096 14097 int attr_idx; 14098 expr_arg_type exp_desc; 14099 int name_idx; 14100 int sb_idx; 14101 14102 # if !defined(_TARGET_OS_UNICOS) 14103 int dt_idx; 14104 int np_idx; 14105 long64 offset; 14106 int prev_sn_idx; 14107 int sn_idx; 14108 # endif 14109 14110 # if defined(_TARGET_OS_UNICOS) 14111 # define BIAS_SIZE 32 14112 # else 14113 # define BIAS_SIZE 128 14114 # endif 14115 14116 TRACE (Func_Entry, "set_up_pe_offset_attr", NULL); 14117 14118 /***********************\ 14119 |* set up common block *| 14120 \***********************/ 14121 14122 # if defined(_TARGET_OS_UNICOS) 14123 CREATE_ID(TOKEN_ID(token), "_fmm_pe_bias", 12); 14124 TOKEN_LEN(token) = 12; 14125 # else 14126 CREATE_ID(TOKEN_ID(token), "__shmem_local_info", 18); 14127 TOKEN_LEN(token) = 18; 14128 # endif 14129 TOKEN_VALUE(token) = Tok_Id; 14130 TOKEN_LINE(token) = stmt_start_line; 14131 TOKEN_COLUMN(token) = stmt_start_col; 14132 14133 sb_idx = srch_stor_blk_tbl(TOKEN_STR(token), 14134 TOKEN_LEN(token), 14135 curr_scp_idx); 14136 14137 if (sb_idx == NULL_IDX) { 14138 sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token), 14139 TOKEN_LEN(token), 14140 TOKEN_LINE(token), 14141 TOKEN_COLUMN(token), 14142 # if defined(_TARGET_OS_UNICOS) 14143 Task_Common); 14144 # else 14145 Common); 14146 # endif 14147 14148 SB_BLANK_COMMON(sb_idx) = FALSE; 14149 SB_COMMON_NEEDS_OFFSET(sb_idx) = FALSE; 14150 SB_NAME_IN_STONE(sb_idx) = TRUE; 14151 } 14152 else { 14153 /* error */ 14154 } 14155 14156 # if ! defined(_TARGET_OS_UNICOS) 14157 14158 /****************************\ 14159 |* create derived type attr *| 14160 \****************************/ 14161 14162 CREATE_ID(TOKEN_ID(token), "__shmem_local_info_type", 23); 14163 TOKEN_LEN(token) = 23; 14164 TOKEN_VALUE(token) = Tok_Id; 14165 TOKEN_LINE(token) = stmt_start_line; 14166 TOKEN_COLUMN(token) = stmt_start_col; 14167 14168 dt_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 14169 14170 if (dt_idx == NULL_IDX) { 14171 dt_idx = ntr_sym_tbl(&token, name_idx); 14172 AT_OBJ_CLASS(dt_idx) = Derived_Type; 14173 ATT_SCP_IDX(dt_idx) = curr_scp_idx; 14174 ATT_NUMERIC_CPNT(dt_idx) = TRUE; 14175 ATT_DCL_NUMERIC_SEQ(dt_idx) = TRUE; 14176 ATT_SEQUENCE_SET(dt_idx) = TRUE; 14177 } 14178 else { 14179 /* error */ 14180 } 14181 14182 ATT_NUM_CPNTS(dt_idx) = 0; 14183 14184 /**************************\ 14185 |* now for the components *| 14186 \**************************/ 14187 14188 offset = 0; 14189 14190 /* integer (4) :: anchor */ 14191 14192 CREATE_ID(TOKEN_ID(token), "anchor", 6); 14193 TOKEN_LEN(token) = 6; 14194 TOKEN_VALUE(token) = Tok_Id; 14195 TOKEN_LINE(token) = stmt_start_line; 14196 TOKEN_COLUMN(token) = stmt_start_col; 14197 14198 NTR_SN_TBL(sn_idx); 14199 NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx); 14200 NTR_ATTR_TBL(attr_idx); 14201 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14202 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token); 14203 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token); 14204 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token); 14205 AT_NAME_IDX(attr_idx) = np_idx; 14206 SN_NAME_LEN(sn_idx) = TOKEN_LEN(token); 14207 SN_NAME_IDX(sn_idx) = np_idx; 14208 SN_ATTR_IDX(sn_idx) = attr_idx; 14209 14210 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14211 ATD_CLASS(attr_idx) = Struct_Component; 14212 ATD_DERIVED_TYPE_IDX(attr_idx) = dt_idx; 14213 14214 AT_TYPED(attr_idx) = TRUE; 14215 14216 ATD_TYPE_IDX(attr_idx) = Integer_4; 14217 14218 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14219 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14220 ATD_CPNT_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX; 14221 14222 offset += storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))]; 14223 14224 ATT_FIRST_CPNT_IDX(dt_idx) = sn_idx; 14225 ATT_NUM_CPNTS(dt_idx) += 1; 14226 14227 prev_sn_idx = sn_idx; 14228 14229 /* integer (4) :: mype */ 14230 14231 CREATE_ID(TOKEN_ID(token), "mype", 4); 14232 TOKEN_LEN(token) = 4; 14233 TOKEN_VALUE(token) = Tok_Id; 14234 TOKEN_LINE(token) = stmt_start_line; 14235 TOKEN_COLUMN(token) = stmt_start_col; 14236 14237 NTR_SN_TBL(sn_idx); 14238 NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx); 14239 NTR_ATTR_TBL(attr_idx); 14240 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14241 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token); 14242 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token); 14243 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token); 14244 AT_NAME_IDX(attr_idx) = np_idx; 14245 SN_NAME_LEN(sn_idx) = TOKEN_LEN(token); 14246 SN_NAME_IDX(sn_idx) = np_idx; 14247 SN_ATTR_IDX(sn_idx) = attr_idx; 14248 14249 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14250 ATD_CLASS(attr_idx) = Struct_Component; 14251 ATD_DERIVED_TYPE_IDX(attr_idx) = dt_idx; 14252 AT_TYPED(attr_idx) = TRUE; 14253 14254 ATD_TYPE_IDX(attr_idx) = Integer_4; 14255 14256 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14257 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14258 ATD_CPNT_OFFSET_IDX(attr_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, offset); 14259 14260 offset += storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))]; 14261 14262 ATT_NUM_CPNTS(dt_idx) += 1; 14263 SN_SIBLING_LINK(prev_sn_idx) = sn_idx; 14264 14265 prev_sn_idx = sn_idx; 14266 14267 /* integer (4) :: initcomplete */ 14268 14269 CREATE_ID(TOKEN_ID(token), "initcomplete", 12); 14270 TOKEN_LEN(token) = 12; 14271 TOKEN_VALUE(token) = Tok_Id; 14272 TOKEN_LINE(token) = stmt_start_line; 14273 TOKEN_COLUMN(token) = stmt_start_col; 14274 14275 NTR_SN_TBL(sn_idx); 14276 NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx); 14277 NTR_ATTR_TBL(attr_idx); 14278 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14279 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token); 14280 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token); 14281 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token); 14282 AT_NAME_IDX(attr_idx) = np_idx; 14283 SN_NAME_LEN(sn_idx) = TOKEN_LEN(token); 14284 SN_NAME_IDX(sn_idx) = np_idx; 14285 SN_ATTR_IDX(sn_idx) = attr_idx; 14286 14287 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14288 ATD_CLASS(attr_idx) = Struct_Component; 14289 ATD_DERIVED_TYPE_IDX(attr_idx) = dt_idx; 14290 AT_TYPED(attr_idx) = TRUE; 14291 14292 ATD_TYPE_IDX(attr_idx) = Integer_4; 14293 14294 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14295 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14296 ATD_CPNT_OFFSET_IDX(attr_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, offset); 14297 14298 offset += storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))] + 32; 14299 14300 ATT_NUM_CPNTS(dt_idx) += 1; 14301 SN_SIBLING_LINK(prev_sn_idx) = sn_idx; 14302 14303 prev_sn_idx = sn_idx; 14304 14305 /* integer (8) :: bias(128) */ 14306 14307 CREATE_ID(TOKEN_ID(token), "bias", 4); 14308 TOKEN_LEN(token) = 4; 14309 TOKEN_VALUE(token) = Tok_Id; 14310 TOKEN_LINE(token) = stmt_start_line; 14311 TOKEN_COLUMN(token) = stmt_start_col; 14312 14313 NTR_SN_TBL(sn_idx); 14314 NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx); 14315 NTR_ATTR_TBL(attr_idx); 14316 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14317 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token); 14318 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token); 14319 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token); 14320 AT_NAME_IDX(attr_idx) = np_idx; 14321 SN_NAME_LEN(sn_idx) = TOKEN_LEN(token); 14322 SN_NAME_IDX(sn_idx) = np_idx; 14323 SN_ATTR_IDX(sn_idx) = attr_idx; 14324 14325 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14326 ATD_CLASS(attr_idx) = Struct_Component; 14327 ATD_DERIVED_TYPE_IDX(attr_idx) = dt_idx; 14328 AT_TYPED(attr_idx) = TRUE; 14329 14330 ATD_TYPE_IDX(attr_idx) = Integer_8; 14331 14332 exp_desc = init_exp_desc; 14333 exp_desc.type_idx = Integer_8; 14334 exp_desc.linear_type = Integer_8; 14335 exp_desc.type = Integer; 14336 exp_desc.shape[0].fld = CN_Tbl_Idx; 14337 14338 exp_desc.rank = 1; 14339 14340 exp_desc.shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, BIAS_SIZE); 14341 14342 ATD_ARRAY_IDX(attr_idx) = create_bd_ntry_for_const(&exp_desc, 14343 stmt_start_line, 14344 stmt_start_col); 14345 14346 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14347 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14348 ATD_CPNT_OFFSET_IDX(attr_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, offset); 14349 14350 offset += BIAS_SIZE * 14351 storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))]; 14352 14353 ATT_NUM_CPNTS(dt_idx) += 1; 14354 SN_SIBLING_LINK(prev_sn_idx) = sn_idx; 14355 14356 prev_sn_idx = sn_idx; 14357 14358 /* integer (SA_INTEGER_DEFAULT_TYPE) :: shheapbase */ 14359 14360 CREATE_ID(TOKEN_ID(token), "shheapbase", 10); 14361 TOKEN_LEN(token) = 10; 14362 TOKEN_VALUE(token) = Tok_Id; 14363 TOKEN_LINE(token) = stmt_start_line; 14364 TOKEN_COLUMN(token) = stmt_start_col; 14365 14366 NTR_SN_TBL(sn_idx); 14367 NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx); 14368 NTR_ATTR_TBL(attr_idx); 14369 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14370 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token); 14371 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token); 14372 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token); 14373 AT_NAME_IDX(attr_idx) = np_idx; 14374 SN_NAME_LEN(sn_idx) = TOKEN_LEN(token); 14375 SN_NAME_IDX(sn_idx) = np_idx; 14376 SN_ATTR_IDX(sn_idx) = attr_idx; 14377 14378 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14379 ATD_CLASS(attr_idx) = Struct_Component; 14380 ATD_DERIVED_TYPE_IDX(attr_idx) = dt_idx; 14381 AT_TYPED(attr_idx) = TRUE; 14382 14383 ATD_TYPE_IDX(attr_idx) = SA_INTEGER_DEFAULT_TYPE; 14384 14385 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14386 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14387 ATD_CPNT_OFFSET_IDX(attr_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,offset); 14388 14389 offset += storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))]; 14390 14391 ATT_NUM_CPNTS(dt_idx) += 1; 14392 SN_SIBLING_LINK(prev_sn_idx) = sn_idx; 14393 14394 prev_sn_idx = sn_idx; 14395 14396 /* integer (SA_INTEGER_DEFAULT_TYPE) :: shheapend */ 14397 14398 CREATE_ID(TOKEN_ID(token), "shheapend", 9); 14399 TOKEN_LEN(token) = 9; 14400 TOKEN_VALUE(token) = Tok_Id; 14401 TOKEN_LINE(token) = stmt_start_line; 14402 TOKEN_COLUMN(token) = stmt_start_col; 14403 14404 NTR_SN_TBL(sn_idx); 14405 NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx); 14406 NTR_ATTR_TBL(attr_idx); 14407 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14408 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token); 14409 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token); 14410 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token); 14411 AT_NAME_IDX(attr_idx) = np_idx; 14412 SN_NAME_LEN(sn_idx) = TOKEN_LEN(token); 14413 SN_NAME_IDX(sn_idx) = np_idx; 14414 SN_ATTR_IDX(sn_idx) = attr_idx; 14415 14416 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14417 ATD_CLASS(attr_idx) = Struct_Component; 14418 ATD_DERIVED_TYPE_IDX(attr_idx) = dt_idx; 14419 AT_TYPED(attr_idx) = TRUE; 14420 14421 ATD_TYPE_IDX(attr_idx) = SA_INTEGER_DEFAULT_TYPE; 14422 14423 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14424 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14425 ATD_CPNT_OFFSET_IDX(attr_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, offset); 14426 14427 offset += storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))]; 14428 14429 ATT_NUM_CPNTS(dt_idx) += 1; 14430 SN_SIBLING_LINK(prev_sn_idx) = sn_idx; 14431 14432 14433 ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx; 14434 ATT_STRUCT_BIT_LEN_IDX(attr_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 14435 offset); 14436 14437 /*****************************************\ 14438 |* Gen the data obj of this derived type *| 14439 \*****************************************/ 14440 14441 CREATE_ID(TOKEN_ID(token), "_shmem_local_info", 17); 14442 TOKEN_LEN(token) = 17; 14443 TOKEN_VALUE(token) = Tok_Id; 14444 TOKEN_LINE(token) = stmt_start_line; 14445 TOKEN_COLUMN(token) = stmt_start_col; 14446 14447 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 14448 14449 if (attr_idx == NULL_IDX) { 14450 attr_idx = ntr_sym_tbl(&token, name_idx); 14451 14452 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14453 AT_REFERENCED(attr_idx) = Referenced; 14454 AT_LOCKED_IN(attr_idx) = TRUE; 14455 AT_TYPED(attr_idx) = TRUE; 14456 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14457 ATD_CLASS(attr_idx) = Variable; 14458 ATD_IN_COMMON(attr_idx) = TRUE; 14459 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14460 14461 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 14462 TYP_TYPE(TYP_WORK_IDX) = Structure; 14463 TYP_LINEAR(TYP_WORK_IDX) = Structure_Type; 14464 TYP_IDX(TYP_WORK_IDX) = dt_idx; 14465 14466 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 14467 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 14468 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14469 ATD_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX; 14470 } 14471 else { 14472 /* error */ 14473 } 14474 14475 SB_FIRST_ATTR_IDX(sb_idx) = attr_idx; 14476 SB_LEN_FLD(sb_idx) = CN_Tbl_Idx; 14477 SB_LEN_IDX(sb_idx) = ATT_STRUCT_BIT_LEN_IDX(dt_idx); 14478 14479 # else 14480 14481 /*****************************************\ 14482 |* Gen the data obj of this derived type *| 14483 \*****************************************/ 14484 14485 CREATE_ID(TOKEN_ID(token), "__fmm_pe_bias", 13); 14486 TOKEN_LEN(token) = 13; 14487 TOKEN_VALUE(token) = Tok_Id; 14488 TOKEN_LINE(token) = stmt_start_line; 14489 TOKEN_COLUMN(token) = stmt_start_col; 14490 14491 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 14492 14493 if (attr_idx == NULL_IDX) { 14494 attr_idx = ntr_sym_tbl(&token, name_idx); 14495 14496 AT_OBJ_CLASS(attr_idx) = Data_Obj; 14497 AT_REFERENCED(attr_idx) = Referenced; 14498 AT_LOCKED_IN(attr_idx) = TRUE; 14499 AT_TYPED(attr_idx) = TRUE; 14500 AT_SEMANTICS_DONE(attr_idx) = TRUE; 14501 ATD_CLASS(attr_idx) = Variable; 14502 ATD_IN_COMMON(attr_idx) = TRUE; 14503 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 14504 14505 ATD_TYPE_IDX(attr_idx) = Integer_8; 14506 14507 exp_desc = init_exp_desc; 14508 exp_desc.type_idx = Integer_8; 14509 exp_desc.linear_type = Integer_8; 14510 exp_desc.type = Integer; 14511 exp_desc.shape[0].fld = CN_Tbl_Idx; 14512 14513 exp_desc.rank = 1; 14514 14515 exp_desc.shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, BIAS_SIZE); 14516 14517 ATD_ARRAY_IDX(attr_idx) = create_bd_ntry_for_const(&exp_desc, 14518 stmt_start_line, 14519 stmt_start_col); 14520 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 14521 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 14522 ATD_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX; 14523 } 14524 else { 14525 /* error */ 14526 } 14527 14528 SB_FIRST_ATTR_IDX(sb_idx) = attr_idx; 14529 SB_LEN_FLD(sb_idx) = CN_Tbl_Idx; 14530 14531 SB_LEN_IDX(sb_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, (BIAS_SIZE * 64)); 14532 14533 # endif 14534 14535 TRACE (Func_Exit, "set_up_pe_offset_attr", NULL); 14536 14537 return(attr_idx); 14538 14539 } /* set_up_pe_offset_attr */ 14540 14541 /******************************************************************************\ 14542 |* *| 14543 |* Description: *| 14544 |* <description> *| 14545 |* *| 14546 |* Input parameters: *| 14547 |* NONE *| 14548 |* *| 14549 |* Output parameters: *| 14550 |* NONE *| 14551 |* *| 14552 |* Returns: *| 14553 |* NOTHING *| 14554 |* *| 14555 \******************************************************************************/ 14556 14557 static void gen_bias_ref(opnd_type *opnd) 14558 14559 { 14560 int col; 14561 int line; 14562 int list_idx; 14563 int sub_idx; 14564 14565 # if ! defined(_TARGET_OS_UNICOS) 14566 int bias_idx; 14567 int struct_idx; 14568 # endif 14569 14570 14571 14572 TRACE (Func_Entry, "gen_bias_ref", NULL); 14573 14574 find_opnd_line_and_column(opnd, &line, &col); 14575 14576 if (glb_tbl_idx[Pe_Offset_Attr_Idx] == NULL_IDX) { 14577 glb_tbl_idx[Pe_Offset_Attr_Idx] = set_up_pe_offset_attr(); 14578 } 14579 14580 # if ! defined(_TARGET_OS_UNICOS) 14581 bias_idx = SN_ATTR_IDX(SN_SIBLING_LINK(SN_SIBLING_LINK(SN_SIBLING_LINK( 14582 ATT_FIRST_CPNT_IDX(TYP_IDX(ATD_TYPE_IDX( 14583 glb_tbl_idx[Pe_Offset_Attr_Idx]))))))); 14584 14585 NTR_IR_TBL(sub_idx); 14586 IR_OPR(sub_idx) = Subscript_Opr; 14587 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(bias_idx); 14588 IR_LINE_NUM(sub_idx) = line; 14589 IR_COL_NUM(sub_idx) = col; 14590 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 14591 IR_LIST_CNT_R(sub_idx) = 1; 14592 14593 NTR_IR_LIST_TBL(list_idx); 14594 14595 IR_IDX_R(sub_idx) = list_idx; 14596 14597 COPY_OPND(IL_OPND(list_idx), (*opnd)); 14598 14599 NTR_IR_TBL(struct_idx); 14600 IR_OPR(struct_idx) = Struct_Opr; 14601 IR_TYPE_IDX(struct_idx) = ATD_TYPE_IDX(bias_idx); 14602 IR_LINE_NUM(struct_idx) = line; 14603 IR_COL_NUM(struct_idx) = col; 14604 IR_LINE_NUM_L(struct_idx) = line; 14605 IR_COL_NUM_L(struct_idx) = col; 14606 IR_LINE_NUM_R(struct_idx) = line; 14607 IR_COL_NUM_R(struct_idx) = col; 14608 14609 IR_FLD_L(struct_idx) = AT_Tbl_Idx; 14610 IR_IDX_L(struct_idx) = glb_tbl_idx[Pe_Offset_Attr_Idx]; 14611 IR_FLD_R(struct_idx) = AT_Tbl_Idx; 14612 IR_IDX_R(struct_idx) = bias_idx; 14613 14614 IR_FLD_L(sub_idx) = IR_Tbl_Idx; 14615 IR_IDX_L(sub_idx) = struct_idx; 14616 14617 OPND_FLD((*opnd)) = IR_Tbl_Idx; 14618 OPND_IDX((*opnd)) = sub_idx; 14619 14620 # else 14621 14622 NTR_IR_TBL(sub_idx); 14623 IR_OPR(sub_idx) = Subscript_Opr; 14624 IR_TYPE_IDX(sub_idx) = Integer_8; 14625 IR_LINE_NUM(sub_idx) = line; 14626 IR_COL_NUM(sub_idx) = col; 14627 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 14628 IR_LIST_CNT_R(sub_idx) = 1; 14629 14630 NTR_IR_LIST_TBL(list_idx); 14631 14632 IR_IDX_R(sub_idx) = list_idx; 14633 14634 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 14635 IR_IDX_L(sub_idx) = glb_tbl_idx[Pe_Offset_Attr_Idx]; 14636 IR_LINE_NUM_L(sub_idx) = line; 14637 IR_COL_NUM_L(sub_idx) = col; 14638 14639 COPY_OPND(IL_OPND(list_idx), (*opnd)); 14640 14641 OPND_FLD((*opnd)) = IR_Tbl_Idx; 14642 OPND_IDX((*opnd)) = sub_idx; 14643 # endif 14644 14645 TRACE (Func_Exit, "gen_bias_ref", NULL); 14646 14647 return; 14648 14649 } /* gen_bias_ref */ 14650 # endif 14651 14652 /******************************************************************************\ 14653 |* *| 14654 |* Description: *| 14655 |* When a cri char pointer is assigned an integer/ptr value by assignment*| 14656 |* or data initialization, it must be treated as an integer. This routine*| 14657 |* either creates an equivalenced integer temp, or, if it is a dummy arg,*| 14658 |* an access through a pointer/pointee pair to set the bits correctly. *| 14659 |* The things we do to sell a machine. *| 14660 |* *| 14661 |* Input parameters: *| 14662 |* NONE *| 14663 |* *| 14664 |* Output parameters: *| 14665 |* NONE *| 14666 |* *| 14667 |* Returns: *| 14668 |* NOTHING *| 14669 |* *| 14670 \******************************************************************************/ 14671 14672 void transform_cri_ch_ptr(opnd_type *result_opnd) 14673 14674 { 14675 int asg_idx; 14676 int attr_idx; 14677 int col; 14678 int eq_idx; 14679 int eq_tmp_idx; 14680 int line; 14681 int loc_idx; 14682 int overlay_attr_idx; 14683 int ptee_idx; 14684 int ptr_idx; 14685 int sb_idx; 14686 14687 TRACE (Func_Entry, "transform_cri_ch_ptr", NULL); 14688 14689 find_opnd_line_and_column(result_opnd, &line, &col); 14690 attr_idx = find_left_attr(result_opnd); 14691 14692 # ifdef _DEBUG 14693 if (AT_OBJ_CLASS(attr_idx) != Data_Obj) { 14694 PRINTMSG(line, 626, Internal, col, 14695 "Data_Obj", "transform_cri_ch_ptr"); 14696 } 14697 else if (OPND_FLD((*result_opnd)) != AT_Tbl_Idx) { 14698 PRINTMSG(line, 626, Internal, col, 14699 "AT_Tbl_Idx", "transform_cri_ch_ptr"); 14700 } 14701 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != CRI_Ch_Ptr) { 14702 PRINTMSG(line, 626, Internal, col, 14703 "CRI_Ch_Ptr", "transform_cri_ch_ptr"); 14704 } 14705 else if (defer_stmt_expansion) { 14706 PRINTMSG(line, 626, Internal, col, 14707 "not defer_stmt_expansion", "transform_cri_ch_ptr"); 14708 } 14709 # endif 14710 14711 if (ATD_CLASS(attr_idx) == Variable) { 14712 14713 if (ATD_VARIABLE_TMP_IDX(attr_idx) != NULL_IDX) { 14714 overlay_attr_idx = ATD_VARIABLE_TMP_IDX(attr_idx); 14715 goto FOUND; 14716 } 14717 14718 overlay_attr_idx = gen_compiler_tmp(line, col, Shared, TRUE); 14719 ATD_CLASS(overlay_attr_idx) = Variable; 14720 14721 ATD_TYPE_IDX(overlay_attr_idx) = INTEGER_DEFAULT_TYPE; 14722 ATD_STOR_BLK_IDX(overlay_attr_idx) = ATD_STOR_BLK_IDX(attr_idx); 14723 ATD_EQUIV(overlay_attr_idx) = TRUE; 14724 AT_REFERENCED(overlay_attr_idx) = Referenced; 14725 AT_SEMANTICS_DONE(overlay_attr_idx) = TRUE; 14726 AT_DEFINED(overlay_attr_idx) = TRUE; 14727 14728 ATD_OFFSET_FLD(overlay_attr_idx) = ATD_OFFSET_FLD(attr_idx); 14729 ATD_OFFSET_IDX(overlay_attr_idx) = ATD_OFFSET_IDX(attr_idx); 14730 ATD_OFFSET_ASSIGNED(overlay_attr_idx) = ATD_OFFSET_ASSIGNED(attr_idx); 14731 14732 /* The overlay tmp and the variable must have the same offset. */ 14733 /* Find the equivalence group for the variable and add the tmp to */ 14734 /* the equivalence group. To do this, create a new equivalence */ 14735 /* table entry, add it to the group and make ATD_OFFSET be the */ 14736 /* same for both. (ATD_OFFSET can be set, even if ATD_OFFSET */ 14737 /* ASSIGNED is FALSE because this is the equivalence group */ 14738 /* offset). */ 14739 14740 if (ATD_EQUIV(attr_idx)) { 14741 eq_idx = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 14742 14743 while (eq_idx != NULL_IDX) { 14744 eq_tmp_idx = eq_idx; 14745 eq_idx = EQ_NEXT_EQUIV_GRP(eq_idx); 14746 14747 while (eq_tmp_idx != NULL_IDX) { 14748 14749 if (EQ_ATTR_IDX(eq_tmp_idx) == attr_idx) { /* Found */ 14750 NTR_EQ_TBL(eq_idx); 14751 COPY_TBL_NTRY(equiv_tbl, eq_idx, eq_tmp_idx); 14752 EQ_NEXT_EQUIV_OBJ(eq_tmp_idx) = eq_idx; 14753 EQ_ATTR_IDX(eq_idx) = overlay_attr_idx; 14754 ATD_OFFSET_FLD(overlay_attr_idx)= 14755 ATD_OFFSET_FLD(attr_idx); 14756 ATD_OFFSET_IDX(overlay_attr_idx)= 14757 ATD_OFFSET_IDX(attr_idx); 14758 ATD_EQUIV(attr_idx) = TRUE; 14759 goto FOUND; 14760 } 14761 eq_tmp_idx = EQ_NEXT_EQUIV_OBJ(eq_tmp_idx); 14762 } 14763 } 14764 } 14765 14766 /* It is not in an equivalence group or it is not */ 14767 /* equivalenced, so make its own equivalence group. */ 14768 14769 NTR_EQ_TBL(eq_idx); 14770 NTR_EQ_TBL(eq_tmp_idx); 14771 14772 EQ_NEXT_EQUIV_GRP(eq_idx) = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 14773 SCP_FIRST_EQUIV_GRP(curr_scp_idx) = eq_idx; 14774 EQ_ATTR_IDX(eq_idx) = attr_idx; 14775 EQ_ATTR_IDX(eq_tmp_idx) = overlay_attr_idx; 14776 EQ_NEXT_EQUIV_OBJ(eq_idx) = eq_tmp_idx; 14777 ATD_EQUIV(attr_idx) = TRUE; 14778 ATD_VARIABLE_TMP_IDX(attr_idx) = overlay_attr_idx; 14779 ATD_FLD(attr_idx) = AT_Tbl_Idx; 14780 14781 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 14782 14783 if (SB_BLK_TYPE(sb_idx) == Stack) { 14784 sb_idx = create_equiv_stor_blk(attr_idx, Stack); 14785 SB_EQUIVALENCED(sb_idx) = TRUE; 14786 ATD_STOR_BLK_IDX(overlay_attr_idx) = sb_idx; 14787 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 14788 } 14789 14790 # if defined(_SEPARATE_NONCOMMON_EQUIV_GROUPS) 14791 14792 14793 if (sb_idx == NULL_IDX || 14794 (!SB_MODULE(sb_idx) && !SB_IS_COMMON(sb_idx))) { 14795 14796 if (SB_HOSTED_STATIC(sb_idx)) { 14797 sb_idx = create_equiv_stor_blk(attr_idx, SB_BLK_TYPE(sb_idx)); 14798 SB_HOSTED_STATIC(sb_idx) = TRUE; 14799 } 14800 else { 14801 sb_idx = create_equiv_stor_blk(attr_idx, SB_BLK_TYPE(sb_idx)); 14802 } 14803 14804 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 14805 ATD_STOR_BLK_IDX(overlay_attr_idx) = sb_idx; 14806 } 14807 # endif 14808 14809 FOUND: 14810 14811 OPND_IDX((*result_opnd)) = overlay_attr_idx; 14812 14813 } 14814 else if (ATD_CLASS(attr_idx) == Dummy_Argument) { 14815 /* create pointer/pointee pair and set pointer to loc(attr_idx) */ 14816 ptr_idx = gen_compiler_tmp(line, col, Shared, TRUE); 14817 ATD_TYPE_IDX(ptr_idx) = CRI_Ptr_8; 14818 AT_SEMANTICS_DONE(ptr_idx) = TRUE; 14819 ATD_STOR_BLK_IDX(ptr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 14820 14821 ptee_idx = gen_compiler_tmp(line, col, Shared, TRUE); 14822 ATD_CLASS(ptee_idx) = CRI__Pointee; 14823 AT_SEMANTICS_DONE(ptee_idx) = TRUE; 14824 ATD_STOR_BLK_IDX(ptee_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 14825 ATD_TYPE_IDX(ptee_idx) = INTEGER_DEFAULT_TYPE; 14826 ATD_PTR_IDX(ptee_idx) = ptr_idx; 14827 14828 /* generate assignment to ptr */ 14829 14830 NTR_IR_TBL(asg_idx); 14831 IR_OPR(asg_idx) = Asg_Opr; 14832 IR_TYPE_IDX(asg_idx) = CRI_Ptr_8; 14833 IR_LINE_NUM(asg_idx) = line; 14834 IR_COL_NUM(asg_idx) = col; 14835 14836 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 14837 IR_IDX_L(asg_idx) = ptr_idx; 14838 IR_LINE_NUM_L(asg_idx) = line; 14839 IR_COL_NUM_L(asg_idx) = col; 14840 14841 NTR_IR_TBL(loc_idx); 14842 IR_OPR(loc_idx) = Loc_Opr; 14843 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 14844 IR_LINE_NUM(loc_idx) = line; 14845 IR_COL_NUM(loc_idx) = col; 14846 14847 /* do I need to worry about a proper reference tree for loc? BHJ */ 14848 14849 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 14850 IR_IDX_L(loc_idx) = attr_idx; 14851 IR_LINE_NUM_L(loc_idx) = line; 14852 IR_COL_NUM_L(loc_idx) = col; 14853 14854 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 14855 IR_IDX_R(asg_idx) = loc_idx; 14856 14857 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 14858 FALSE, FALSE, TRUE); 14859 14860 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 14861 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 14862 14863 OPND_IDX((*result_opnd)) = ptee_idx;; 14864 } 14865 else { 14866 PRINTMSG(line, 626, Internal, col, 14867 "variable or dummy arg", "transform_cri_ch_ptr"); 14868 } 14869 14870 TRACE (Func_Exit, "transform_cri_ch_ptr", NULL); 14871 14872 return; 14873 14874 } /* transform_cri_ch_ptr */
1.7.6.1 
