00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
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"
00040
00041 # include "host.m"
00042 # include "host.h"
00043 # include "target.m"
00044 # include "target.h"
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
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
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
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
00185
00186
00187
00188
00189
00190
00191
00192
00193
00194
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
00240
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
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
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
00300 ok &= expr_semantics_d(&r_opnd, &exp_desc_r,
00301 (exp_desc_l.type == Structure));
00302 #else
00303 ok &= expr_semantics(&r_opnd, &exp_desc_r);
00304 #endif
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
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
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
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
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
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
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
00491
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
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
00581
00582
00583
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
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
00673
00674
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
00729
00730 if (exp_desc_r.vector_subscript) {
00731
00732
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 {
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 {
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
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 }
00907
00908
00909
00910
00911
00912
00913
00914
00915
00916
00917
00918
00919
00920
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
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
00967
00968
00969
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
00986
00987
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 }
01017
01018
01019
01020
01021
01022
01023
01024
01025
01026
01027
01028
01029
01030
01031
01032
01033
01034
01035 boolean expr_semantics (opnd_type *result_opnd,
01036 expr_arg_type *exp_desc)
01037 #ifdef KEY
01038 {
01039 return expr_semantics_d(result_opnd, exp_desc, FALSE);
01040 }
01041
01042
01043
01044
01045
01046 static boolean expr_semantics_d (opnd_type *result_opnd,
01047 expr_arg_type *exp_desc,
01048 boolean derived_assign)
01049 #endif
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
01079 ok = expr_sem_d(result_opnd, exp_desc, derived_assign);
01080 #else
01081 ok = expr_sem(result_opnd, exp_desc);
01082 #endif
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));
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 )
01113 ok = fold_aggragate_expression(&opnd, exp_desc, FALSE) && ok;
01114
01115
01116
01117 COPY_OPND((*result_opnd), opnd);
01118 }
01119
01120
01121 TRACE (Func_Exit, "expr_semantics", NULL);
01122
01123 return(ok);
01124
01125 }
01126
01127
01128
01129
01130
01131
01132
01133
01134
01135
01136
01137
01138
01139
01140
01141
01142
01143
01144
01145
01146
01147
01148
01149
01150
01151
01152
01153
01154
01155
01156
01157
01158
01159
01160
01161
01162
01163
01164
01165
01166
01167
01168
01169
01170
01171
01172
01173
01174
01175
01176
01177
01178
01179
01180
01181
01182
01183
01184
01185
01186
01187
01188
01189
01190
01191
01192
01193
01194
01195
01196
01197
01198
01199
01200
01201
01202
01203
01204
01205
01206
01207
01208
01209
01210
01211
01212
01213
01214
01215
01216
01217
01218
01219
01220
01221
01222
01223
01224
01225
01226
01227
01228
01229
01230
01231
01232
01233
01234
01235
01236
01237
01238 boolean expr_sem (opnd_type *result_opnd,
01239 expr_arg_type *exp_desc)
01240 #ifdef KEY
01241 {
01242 return expr_sem_d(result_opnd, exp_desc, FALSE);
01243 }
01244
01245
01246
01247
01248
01249 static boolean expr_sem_d(opnd_type *result_opnd,
01250 expr_arg_type *exp_desc,
01251 boolean derived_assign)
01252 #endif
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
01279
01280
01281 rank_in = exp_desc->rank;
01282 (*exp_desc) = init_exp_desc;
01283 #ifdef KEY
01284 exp_desc->derived_assign = derived_assign;
01285 #endif
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) {
01452 cif_usage_rec(attr_idx, AT_Tbl_Idx, line, col,
01453 CIF_Symbol_Is_Actual_Arg);
01454 }
01455 else {
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)) {
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
01501
01502
01503
01504 exp_desc->derived_assign &&
01505 #endif
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
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
01598
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
01608
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
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
01631
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
01638
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
01666
01667
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
01682
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
01755
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 {
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
01817
01818
01819
01820
01821
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
01849
01850
01851
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) {
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 }
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,
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
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
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
02048
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
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
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
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
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;
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
02362 #if 0
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
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
02428
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 }
02510
02511
02512
02513
02514
02515
02516
02517
02518
02519
02520
02521
02522
02523
02524
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(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
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
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(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
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
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
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
02717
02718 gen_dv_access_low_bound(&opnd2, &dv_opnd, i);
02719
02720 COPY_OPND(IL_OPND(tlst1_idx), opnd2);
02721
02722
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
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
02791
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
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
02825
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
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
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 }
02909
02910
02911
02912
02913
02914
02915
02916
02917
02918
02919
02920
02921
02922
02923
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
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
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 }
03055
03056
03057
03058
03059
03060
03061
03062
03063
03064
03065
03066
03067
03068
03069
03070
03071
03072
03073
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
03110 intrinsic = FALSE;
03111 goto EXIT;
03112 }
03113 }
03114 else {
03115
03116 if (rank_l != rank_r &&
03117 rank_l * rank_r != 0) {
03118
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 }
03242
03243
03244
03245
03246
03247
03248
03249
03250
03251
03252
03253
03254
03255
03256
03257
03258
03259
03260
03261
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 }
03312
03313
03314
03315
03316
03317
03318
03319
03320
03321
03322
03323
03324
03325
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
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
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
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 }
03467
03468
03469
03470
03471
03472
03473
03474
03475
03476
03477
03478
03479
03480
03481
03482
03483
03484
03485
03486
03487
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 }
03535
03536
03537
03538
03539
03540
03541
03542
03543
03544
03545
03546
03547
03548
03549
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
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
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 }
03652
03653
03654
03655
03656
03657
03658
03659
03660
03661
03662
03663
03664
03665
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
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 }
03795
03796
03797
03798
03799