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_utils.c 5.12 10/19/99 17:14:30\n";
00038
00039
00040 # include "defines.h"
00041
00042 # include "host.m"
00043 # include "host.h"
00044 # include "target.m"
00045 # include "target.h"
00046
00047 # include "globals.m"
00048 # include "tokens.m"
00049 # include "sytb.m"
00050 # include "s_globals.m"
00051 # include "debug.m"
00052 # include "s_utils.m"
00053
00054 # include "globals.h"
00055 # include "tokens.h"
00056 # include "sytb.h"
00057 # include "s_globals.h"
00058
00059 # if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS)
00060 # include <fortran.h>
00061 # endif
00062
00063
00064
00065
00066
00067
00068 static int opr_to_str(operator_type, char *);
00069 static int create_dv_type_code(int);
00070 static long64 create_imp_do_loops(opnd_type *);
00071 static void just_find_dope_and_rank(opnd_type *, int *, int *);
00072 static void compute_char_element_len(opnd_type *,
00073 opnd_type *, opnd_type *);
00074 static void gen_conform_check_call(opnd_type *, opnd_type *, int, int, int);
00075 static void gen_bounds_check_call(char *, opnd_type *, opnd_type *,
00076 opnd_type *, int, int, int);
00077 static void gen_rbounds_check_call(char *, opnd_type *, opnd_type *,
00078 opnd_type *, opnd_type *,
00079 opnd_type *, int, int, int);
00080 static void gen_sbounds_check_call(char *, opnd_type *, opnd_type *,
00081 opnd_type *, int, int);
00082 static void gen_ptr_chk_call(char *, int, opnd_type *, int, int);
00083 static int put_file_name_in_cn(int);
00084 static int put_c_str_in_cn(char *);
00085 static void gen_dv_def_loops(opnd_type *);
00086 static void gen_init_stmt(opnd_type *, int, sh_position_type);
00087 static void reshape_reference_subscripts(opnd_type *);
00088 static void gen_dv_stride_mult(opnd_type *, int, opnd_type *,
00089 expr_arg_type *, int, int, int);
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107 boolean resolve_ext_opr(opnd_type *opnd,
00108 boolean issue_msg,
00109 boolean save_in_call_list,
00110 boolean err_res,
00111 boolean *semantically_correct,
00112 expr_arg_type *exp_desc_l,
00113 expr_arg_type *exp_desc_r)
00114
00115 {
00116 opnd_type arg_1_opnd;
00117 opnd_type arg_2_opnd;
00118 int arg_idx;
00119 int attr_idx;
00120 int col;
00121 int darg_idx;
00122
00123 # if defined(GENERATE_WHIRL)
00124 int false_list_idx = NULL_IDX;
00125 # endif
00126
00127 boolean found = FALSE;
00128 int gen_idx = NULL_IDX;
00129 int i;
00130 int idx;
00131 int info_idx;
00132 int ir_idx;
00133 boolean is_function = TRUE;
00134 int len;
00135 int line;
00136 int list_idx;
00137 int list1_idx;
00138 int list2_idx;
00139 int loc_idx;
00140 int name_idx;
00141 int num_args;
00142 boolean ok = TRUE;
00143 int opnd_column;
00144 int opnd_line;
00145 int rslt_idx;
00146 int save_arg_info_list_base;
00147 int save_curr_stmt_sh_idx;
00148 int save_defer_stmt_expansion;
00149 int spec_idx = NULL_IDX;
00150 int sn_idx = NULL_IDX;
00151 char str_word[32];
00152 opnd_type tmp_opnd;
00153 char type_str_l[45];
00154 char type_str_r[45];
00155
00156
00157 TRACE (Func_Entry, "resolve_ext_opr", NULL);
00158
00159
00160
00161 if (max_call_list_size >= arg_list_size) {
00162 enlarge_call_list_tables();
00163 }
00164
00165 save_arg_info_list_base = arg_info_list_base;
00166 arg_info_list_base = arg_info_list_top;
00167 arg_info_list_top = arg_info_list_base + 2;
00168
00169 if (arg_info_list_top >= arg_info_list_size) {
00170 enlarge_info_list_table();
00171 }
00172
00173 ir_idx = OPND_IDX((*opnd));
00174 line = IR_LINE_NUM(ir_idx);
00175 col = IR_COL_NUM(ir_idx);
00176
00177 if (IR_OPR(ir_idx) == Defined_Bin_Opr) {
00178
00179 gen_idx = IR_IDX_L(ir_idx);
00180 strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx));
00181 str_word[AT_NAME_LEN(gen_idx)] = '\0';
00182 num_args = 2;
00183 COPY_OPND(arg_1_opnd, IL_OPND(IR_IDX_R(ir_idx)));
00184 COPY_OPND(arg_2_opnd, IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))));
00185
00186 if (cif_flags & XREF_RECS) {
00187 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00188 }
00189 }
00190 else if (IR_OPR(ir_idx) == Defined_Un_Opr) {
00191 gen_idx = IR_IDX_L(ir_idx);
00192 strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx));
00193 str_word[AT_NAME_LEN(gen_idx)] = '\0';
00194 num_args = 1;
00195 COPY_OPND(arg_1_opnd, IR_OPND_R(ir_idx));
00196
00197 if (cif_flags & XREF_RECS) {
00198 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00199 }
00200 }
00201 else {
00202 len = opr_to_str(IR_OPR(ir_idx), str_word);
00203 gen_idx = srch_sym_tbl(str_word, len, &name_idx);
00204
00205 if (gen_idx == NULL_IDX) {
00206 gen_idx = srch_host_sym_tbl(str_word, len, &name_idx, TRUE);
00207 }
00208
00209 COPY_OPND(arg_1_opnd, IR_OPND_L(ir_idx));
00210
00211 if (IR_FLD_R(ir_idx) == NO_Tbl_Idx) {
00212 num_args = 1;
00213 }
00214 else {
00215 num_args = 2;
00216 COPY_OPND(arg_2_opnd, IR_OPND_R(ir_idx));
00217 }
00218 }
00219
00220 if (IR_OPR(ir_idx) == Asg_Opr) {
00221 is_function = FALSE;
00222 }
00223
00224 if (gen_idx == NULL_IDX ||
00225 AT_OBJ_CLASS(gen_idx) != Interface) {
00226 gen_idx = NULL_IDX;
00227 goto EXIT;
00228 }
00229
00230 for (i = 0; i < ATI_NUM_SPECIFICS(gen_idx); i++) {
00231
00232 sn_idx = (sn_idx == NULL_IDX) ? ATI_FIRST_SPECIFIC_IDX(gen_idx) :
00233 SN_SIBLING_LINK(sn_idx);
00234 spec_idx = SN_ATTR_IDX(sn_idx);
00235
00236
00237
00238 if (ATP_EXTRA_DARG(spec_idx)) {
00239
00240 if (num_args != ATP_NUM_DARGS(spec_idx) - 1) {
00241 continue;
00242 }
00243
00244 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1);
00245 }
00246 else {
00247
00248 if (num_args != ATP_NUM_DARGS(spec_idx)) {
00249 continue;
00250 }
00251
00252 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx));
00253 }
00254
00255
00256
00257 if (darg_idx == NULL_IDX) {
00258 continue;
00259 }
00260
00261 if (AT_OBJ_CLASS(darg_idx) == Data_Obj) {
00262
00263 if (ATD_IGNORE_TKR(darg_idx)) {
00264
00265
00266
00267 }
00268 else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx &&
00269 IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) {
00270
00271
00272 }
00273 else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->type) {
00274 continue;
00275 }
00276 else if (exp_desc_l->type == Structure) {
00277
00278 if (!compare_derived_types(exp_desc_l->type_idx,
00279 ATD_TYPE_IDX(darg_idx))) {
00280 continue;
00281 }
00282 }
00283 else if (exp_desc_l->type != Character &&
00284 TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->linear_type) {
00285 continue;
00286 }
00287
00288 if (ATD_IGNORE_TKR(darg_idx)) {
00289
00290
00291
00292 }
00293 else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx &&
00294 IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) {
00295
00296
00297 }
00298 else if (ATP_ELEMENTAL(spec_idx)) {
00299
00300 }
00301 else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) {
00302
00303 if (exp_desc_l->rank) {
00304 continue;
00305 }
00306 }
00307 else {
00308
00309 if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_l->rank) {
00310 continue;
00311 }
00312 }
00313 }
00314 else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {
00315
00316 }
00317
00318 if (num_args == 2) {
00319 if (ATP_EXTRA_DARG(spec_idx)) {
00320 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 2);
00321 }
00322 else {
00323 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1);
00324 }
00325
00326
00327 if (darg_idx == NULL_IDX) {
00328 continue;
00329 }
00330
00331 if (AT_OBJ_CLASS(darg_idx) == Data_Obj) {
00332
00333 if (ATD_IGNORE_TKR(darg_idx)) {
00334
00335
00336
00337 }
00338 else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx &&
00339 IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) {
00340
00341
00342 }
00343 else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->type) {
00344 continue;
00345 }
00346 else if (exp_desc_r->type == Structure) {
00347
00348 if (!compare_derived_types(exp_desc_r->type_idx,
00349 ATD_TYPE_IDX(darg_idx))) {
00350 continue;
00351 }
00352 }
00353 else if (exp_desc_r->type != Character &&
00354 TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->linear_type) {
00355 continue;
00356 }
00357
00358 if (ATD_IGNORE_TKR(darg_idx)) {
00359
00360
00361
00362 }
00363 else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx &&
00364 IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) {
00365
00366
00367 }
00368 else if (ATP_ELEMENTAL(spec_idx)) {
00369
00370 }
00371 else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) {
00372
00373 if (exp_desc_r->rank) {
00374 continue;
00375 }
00376 }
00377 else {
00378
00379 if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_r->rank) {
00380 continue;
00381 }
00382 }
00383 }
00384 else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {
00385
00386 }
00387 }
00388
00389
00390
00391
00392
00393
00394 if (cif_flags & XREF_RECS &&
00395 IR_OPR(ir_idx) != Defined_Bin_Opr &&
00396 IR_OPR(ir_idx) != Defined_Un_Opr) {
00397
00398 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00399 }
00400
00401 if (ATP_SCP_IDX(spec_idx) != curr_scp_idx || AT_NOT_VISIBLE(spec_idx)) {
00402
00403
00404
00405
00406
00407 attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(spec_idx),
00408 AT_NAME_LEN(spec_idx),
00409 &name_idx);
00410
00411 if (attr_idx != spec_idx) {
00412
00413
00414
00415
00416
00417 ADD_ATTR_TO_LOCAL_LIST(spec_idx);
00418 }
00419 }
00420
00421 AT_REFERENCED(spec_idx) = Referenced;
00422
00423 if (exp_desc_l->reference &&
00424 (cif_flags & XREF_RECS) != 0 &&
00425 xref_state != CIF_No_Usage_Rec) {
00426
00427 COPY_OPND(tmp_opnd, arg_1_opnd);
00428
00429 while (OPND_FLD(tmp_opnd) == IR_Tbl_Idx &&
00430 IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) {
00431
00432 COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd)));
00433 }
00434
00435 find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column);
00436
00437 cif_usage_rec(OPND_IDX(tmp_opnd),
00438 OPND_FLD(tmp_opnd),
00439 opnd_line,
00440 opnd_column,
00441 CIF_Symbol_Defined_Opr_Actual_Arg);
00442 }
00443
00444 NTR_IR_LIST_TBL(list1_idx);
00445 IL_ARG_DESC_VARIANT(list1_idx) = TRUE;
00446 COPY_OPND(IL_OPND(list1_idx), arg_1_opnd);
00447
00448 info_idx = arg_info_list_base + 1;
00449 arg_info_list[info_idx] = init_arg_info;
00450 arg_info_list[info_idx].ed = *exp_desc_l;
00451 arg_info_list[info_idx].maybe_modified = TRUE;
00452 IL_ARG_DESC_IDX(list1_idx) = info_idx;
00453
00454 if (num_args == 2) {
00455
00456 if (exp_desc_r->reference &&
00457 (cif_flags & XREF_RECS) != 0 &&
00458 xref_state != CIF_No_Usage_Rec) {
00459
00460 COPY_OPND(tmp_opnd, arg_2_opnd);
00461
00462 while (OPND_FLD(tmp_opnd) == IR_Tbl_Idx &&
00463 IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) {
00464
00465 COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd)));
00466 }
00467
00468 find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column);
00469
00470 cif_usage_rec(OPND_IDX(tmp_opnd),
00471 OPND_FLD(tmp_opnd),
00472 opnd_line,
00473 opnd_column,
00474 CIF_Symbol_Defined_Opr_Actual_Arg);
00475 }
00476
00477
00478 NTR_IR_LIST_TBL(list2_idx);
00479 IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
00480 COPY_OPND(IL_OPND(list2_idx), arg_2_opnd);
00481 IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
00482
00483 info_idx++;
00484
00485 arg_info_list[info_idx] = init_arg_info;
00486 arg_info_list[info_idx].ed = *exp_desc_r;
00487 arg_info_list[info_idx].maybe_modified = TRUE;
00488 IL_ARG_DESC_IDX(list2_idx) = info_idx;
00489 }
00490
00491 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
00492 IR_IDX_L(ir_idx) = spec_idx;
00493 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx);
00494 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx);
00495 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
00496 IR_IDX_R(ir_idx) = list1_idx;
00497 IR_LIST_CNT_R(ir_idx) = num_args;
00498 IR_OPR(ir_idx) = Call_Opr;
00499
00500
00501 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
00502
00503 if (defer_stmt_expansion) {
00504 number_of_functions++;
00505 }
00506
00507 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00508
00509 SCP_HAS_CALLS(curr_scp_idx) = TRUE;
00510
00511
00512
00513
00514
00515
00516
00517
00518
00519
00520
00521
00522
00523
00524
00525
00526
00527
00528
00529
00530
00531 if ((cif_flags & MISC_RECS) != 0 && xref_state != CIF_No_Usage_Rec) {
00532 cif_call_site_rec(ir_idx, gen_idx);
00533 }
00534
00535 if (AT_OBJ_CLASS(spec_idx) == Pgm_Unit &&
00536 ATP_SCP_ALIVE(spec_idx)) {
00537
00538 if (ATP_PGM_UNIT(spec_idx) == Function &&
00539 !ATP_RSLT_NAME(spec_idx)) {
00540 PRINTMSG(IR_LINE_NUM(ir_idx), 344, Ansi, IR_COL_NUM(ir_idx));
00541 }
00542 if (!ATP_RECURSIVE(spec_idx) && !AT_DCL_ERR(spec_idx) &&
00543 !on_off_flags.recursive) {
00544 PRINTMSG(IR_LINE_NUM(ir_idx), 343, Error, IR_COL_NUM(ir_idx));
00545 *semantically_correct = FALSE;
00546 }
00547 }
00548
00549 if (AT_DCL_ERR(spec_idx)) {
00550
00551
00552 *semantically_correct = FALSE;
00553 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00554 found = TRUE;
00555 goto EXIT;
00556 }
00557
00558 stmt_expansion_control_start();
00559 save_defer_stmt_expansion = defer_stmt_expansion;
00560 defer_stmt_expansion = FALSE;
00561
00562 if (is_function) {
00563
00564
00565
00566 in_call_list = save_in_call_list;
00567 rslt_idx = ATP_RSLT_IDX(spec_idx);
00568 (*exp_desc_l) = init_exp_desc;
00569
00570 exp_desc_l->type_idx = ATD_TYPE_IDX(rslt_idx);
00571 exp_desc_l->type = TYP_TYPE(exp_desc_l->type_idx);
00572 exp_desc_l->linear_type = TYP_LINEAR(exp_desc_l->type_idx);
00573 exp_desc_l->pointer = ATD_POINTER(rslt_idx);
00574 exp_desc_l->target = ATD_TARGET(rslt_idx);
00575 exp_desc_l->allocatable = ATD_ALLOCATABLE(rslt_idx);
00576 exp_desc_l->dope_vector = ATD_IM_A_DOPE(rslt_idx);
00577
00578 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(rslt_idx);
00579
00580 if (ATD_ARRAY_IDX(ATP_RSLT_IDX(spec_idx))) {
00581 exp_desc_l->assumed_shape =
00582 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Shape);
00583 exp_desc_l->assumed_size =
00584 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Size);
00585 exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(rslt_idx));
00586 }
00587
00588
00589 if (!no_func_expansion) {
00590
00591
00592 if (ATP_ELEMENTAL(spec_idx)) {
00593
00594 attr_idx = find_base_attr(opnd, &line, &col);
00595 exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx));
00596 }
00597
00598
00599
00600
00601
00602
00603 if ((cif_flags & MISC_RECS) != 0 &&
00604 xref_state != CIF_No_Usage_Rec) {
00605 cif_object_rec_for_func_result(spec_idx);
00606 }
00607
00608 exp_desc_l->tmp_reference = TRUE;
00609
00610 if (exp_desc_l->type == Character ||
00611 exp_desc_l->rank) {
00612
00613 attr_idx = find_base_attr(opnd, &line, &col);
00614
00615 if (exp_desc_l->type == Character) {
00616 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
00617 exp_desc_l->type_idx = ATD_TYPE_IDX(attr_idx);
00618 exp_desc_l->type = TYP_TYPE(exp_desc_l->type_idx);
00619 exp_desc_l->linear_type = TYP_LINEAR(exp_desc_l->type_idx);
00620 get_char_len(opnd, &(exp_desc_l->char_len));
00621 }
00622
00623 if (exp_desc_l->rank) {
00624 get_shape_from_attr(exp_desc_l,
00625 attr_idx,
00626 exp_desc_l->rank,
00627 line,
00628 col);
00629
00630 exp_desc_l->contig_array = TRUE;
00631 }
00632 }
00633 }
00634 else {
00635 set_shape_for_deferred_funcs(exp_desc_l, ir_idx);
00636 }
00637
00638 IR_TYPE_IDX(ir_idx) = exp_desc_l->type_idx;
00639 IR_RANK(ir_idx) = exp_desc_l->rank;
00640 }
00641
00642 if (!no_func_expansion) {
00643
00644 if (! is_function) {
00645
00646
00647 COPY_OPND(tmp_opnd, IR_OPND_R(ir_idx));
00648 ok = final_arg_work(&tmp_opnd, spec_idx, num_args, NULL) && ok;
00649 COPY_OPND(IR_OPND_R(ir_idx), tmp_opnd);
00650 }
00651
00652 if (ATP_PROC(spec_idx) != Dummy_Proc &&
00653 ATP_PROC(spec_idx) != Intrin_Proc &&
00654 ! ATP_VFUNCTION(spec_idx) &&
00655 (cmd_line_flags.runtime_argument ||
00656 cmd_line_flags.runtime_arg_call)) {
00657
00658 # if defined(GENERATE_WHIRL)
00659 list1_idx = IR_IDX_R(ir_idx);
00660 list2_idx = NULL_IDX;
00661
00662 idx = 0;
00663
00664 while (list1_idx) {
00665 if (IL_FLD(list1_idx) == IR_Tbl_Idx &&
00666 IR_OPR(IL_IDX(list1_idx)) == False_Parm_Opr) {
00667
00668 false_list_idx = list1_idx;
00669
00670 IL_NEXT_LIST_IDX(list2_idx) = NULL_IDX;
00671 break;
00672 }
00673
00674 list2_idx = list1_idx;
00675 list1_idx = IL_NEXT_LIST_IDX(list1_idx);
00676 idx++;
00677 }
00678
00679 IR_LIST_CNT_R(ir_idx) = idx;
00680 # endif
00681
00682 ATP_ARGCHCK_CALL(spec_idx) = TRUE;
00683
00684 NTR_IR_TBL(loc_idx);
00685 IR_OPR(loc_idx) = Aloc_Opr;
00686 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
00687 IR_LINE_NUM(loc_idx) = line;
00688 IR_COL_NUM(loc_idx) = col;
00689 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
00690
00691 OPND_FLD(tmp_opnd) = IR_Tbl_Idx;
00692 OPND_IDX(tmp_opnd) = ir_idx;
00693 idx = create_argchck_descriptor(&tmp_opnd);
00694 IR_IDX_L(loc_idx) = idx;
00695 IR_LINE_NUM_L(loc_idx) = line;
00696 IR_COL_NUM_L(loc_idx) = col;
00697
00698 NTR_IR_LIST_TBL(list2_idx);
00699 IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
00700 IL_FLD(list2_idx) = IR_Tbl_Idx;
00701 IL_IDX(list2_idx) = loc_idx;
00702
00703 if (IR_LIST_CNT_R(ir_idx) == 0) {
00704 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
00705 IR_IDX_R(ir_idx) = list2_idx;
00706 IR_LIST_CNT_R(ir_idx) = 1;
00707 }
00708 else {
00709 list1_idx = IR_IDX_R(ir_idx);
00710 while (IL_NEXT_LIST_IDX(list1_idx)) {
00711 list1_idx = IL_NEXT_LIST_IDX(list1_idx);
00712 }
00713
00714 IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
00715 (IR_LIST_CNT_R(ir_idx))++;
00716 }
00717
00718 # if defined(GENERATE_WHIRL)
00719 if (false_list_idx != NULL_IDX) {
00720 IL_NEXT_LIST_IDX(list2_idx) = false_list_idx;
00721 list1_idx = false_list_idx;
00722 while (list1_idx) {
00723 (IR_LIST_CNT_R(ir_idx))++;
00724 list1_idx = IL_NEXT_LIST_IDX(list1_idx);
00725 }
00726 }
00727 # endif
00728 }
00729 }
00730
00731 defer_stmt_expansion = save_defer_stmt_expansion;
00732 stmt_expansion_control_end(opnd);
00733
00734 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00735
00736 found = TRUE;
00737 break;
00738 }
00739
00740 EXIT:
00741
00742 if (ok && found && (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
00743 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) {
00744
00745 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))) {
00746
00747 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
00748 PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx),
00749 AT_OBJ_NAME_PTR(spec_idx),
00750 "pure or elemental",
00751 "pure");
00752
00753 }
00754 }
00755 else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
00756
00757 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
00758 PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx),
00759 AT_OBJ_NAME_PTR(spec_idx),
00760 "pure or elemental",
00761 "elemental");
00762
00763 }
00764 }
00765
00766
00767
00768
00769 list_idx = IR_IDX_R(ir_idx);
00770
00771 if (ATP_EXTRA_DARG(spec_idx)) {
00772 arg_idx = ATP_FIRST_IDX(spec_idx) + 1;
00773 idx = ATP_NUM_DARGS(spec_idx) - 1;
00774 }
00775 else {
00776 arg_idx = ATP_FIRST_IDX(spec_idx);
00777 idx = ATP_NUM_DARGS(spec_idx);
00778 }
00779 for (;idx > 0; idx--) {
00780
00781 if (AT_OBJ_CLASS(SN_ATTR_IDX(arg_idx)) == Data_Obj &&
00782 (ATD_POINTER(SN_ATTR_IDX(arg_idx)) ||
00783 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Inout ||
00784 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Out)) {
00785 COPY_OPND(tmp_opnd, IL_OPND(list_idx));
00786 attr_idx = find_left_attr(&tmp_opnd);
00787
00788 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)) {
00789 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
00790 &opnd_line,
00791 &opnd_column);
00792 PRINTMSG(opnd_line, 1273, Error, opnd_column,
00793 AT_OBJ_NAME_PTR(attr_idx),
00794 AT_OBJ_NAME_PTR(SN_ATTR_IDX(arg_idx)),
00795 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))?"pure":"elemental");
00796 ok = FALSE;
00797
00798
00799 }
00800 }
00801 arg_idx++;
00802 list_idx = IL_NEXT_LIST_IDX(list_idx);
00803 }
00804 }
00805
00806 if (found) {
00807
00808
00809
00810
00811
00812 if (spec_idx == gen_idx && AT_NOT_VISIBLE(spec_idx)) {
00813 PRINTMSG(IR_LINE_NUM(ir_idx), 486, Error,
00814 IR_COL_NUM(ir_idx),
00815 AT_OBJ_NAME_PTR(spec_idx),
00816 AT_OBJ_NAME_PTR(AT_MODULE_IDX((spec_idx))));
00817 *semantically_correct = FALSE;
00818 }
00819
00820 switch (expr_mode) {
00821 case Restricted_Imp_Do_Expr:
00822 case Data_Stmt_Target_Expr:
00823 PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error,
00824 IR_COL_NUM(ir_idx),
00825 str_word);
00826 *semantically_correct = FALSE;
00827 break;
00828
00829 case Specification_Expr:
00830 PRINTMSG(IR_LINE_NUM(ir_idx), 880, Error,
00831 IR_COL_NUM(ir_idx),
00832 str_word);
00833 *semantically_correct = FALSE;
00834 break;
00835
00836 case Stmt_Func_Expr:
00837 PRINTMSG(IR_LINE_NUM(ir_idx), 757, Error,
00838 IR_COL_NUM(ir_idx),
00839 str_word);
00840 *semantically_correct = FALSE;
00841 break;
00842 }
00843 }
00844 else if (issue_msg ) {
00845
00846 if (gen_idx != NULL_IDX) {
00847 PRINTMSG(IR_LINE_NUM(ir_idx), 380, Error,
00848 IR_COL_NUM(ir_idx), str_word);
00849 *semantically_correct = FALSE;
00850 }
00851 else {
00852
00853 if (exp_desc_l->linear_type == Long_Typeless ||
00854 (num_args == 2 && exp_desc_r->linear_type == Long_Typeless)) {
00855
00856 if (exp_desc_l->linear_type == Long_Typeless) {
00857 find_opnd_line_and_column((opnd_type *) &IR_OPND_L(ir_idx),
00858 &opnd_line,
00859 &opnd_column);
00860 PRINTMSG(opnd_line, 1133, Error, opnd_column);
00861 *semantically_correct = FALSE;
00862 }
00863
00864 if (num_args == 2 &&
00865 exp_desc_r->linear_type == Long_Typeless) {
00866 find_opnd_line_and_column((opnd_type *) &IR_OPND_R(ir_idx),
00867 &opnd_line,
00868 &opnd_column);
00869 PRINTMSG(opnd_line, 1133, Error, opnd_column);
00870 *semantically_correct = FALSE;
00871 }
00872 }
00873 else if (! is_function) {
00874
00875 if (exp_desc_r->rank != exp_desc_l->rank && exp_desc_r->rank != 0) {
00876
00877
00878
00879 PRINTMSG(IR_LINE_NUM(ir_idx), 324, Error, IR_COL_NUM(ir_idx),
00880 exp_desc_r->rank, exp_desc_l->rank);
00881 *semantically_correct = FALSE;
00882 }
00883
00884 if (err_res) {
00885 strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx));
00886 strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx));
00887 PRINTMSG(IR_LINE_NUM(ir_idx), 356, Error,
00888 IR_COL_NUM(ir_idx),
00889 type_str_r,
00890 type_str_l);
00891 *semantically_correct = FALSE;
00892 }
00893 }
00894 else if (expr_mode == Restricted_Imp_Do_Expr ||
00895 expr_mode == Data_Stmt_Target_Expr) {
00896
00897 PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error,
00898 IR_COL_NUM(ir_idx), str_word);
00899 *semantically_correct = FALSE;
00900 }
00901 else if (num_args == 1) {
00902
00903 PRINTMSG(IR_LINE_NUM(ir_idx), 392, Error,
00904 IR_COL_NUM(ir_idx),
00905 get_basic_type_str(exp_desc_l->type_idx),
00906 str_word);
00907 *semantically_correct = FALSE;
00908 }
00909 else {
00910
00911
00912 if (exp_desc_r->rank != exp_desc_l->rank &&
00913 exp_desc_r->rank * exp_desc_l->rank != 0) {
00914
00915
00916
00917 PRINTMSG(IR_LINE_NUM(ir_idx), 302, Error, IR_COL_NUM(ir_idx),
00918 exp_desc_l->rank, exp_desc_r->rank, str_word);
00919 *semantically_correct = FALSE;
00920 }
00921
00922 if (err_res) {
00923 strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx));
00924 strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx));
00925
00926 PRINTMSG(IR_LINE_NUM(ir_idx), 303, Error,
00927 IR_COL_NUM(ir_idx),
00928 type_str_l,
00929 type_str_r,
00930 str_word);
00931 *semantically_correct = FALSE;
00932 }
00933 }
00934 }
00935 }
00936
00937 if (*semantically_correct &&
00938 found &&
00939 ATP_PROC(spec_idx) != Intrin_Proc) {
00940
00941 if (! ATP_PURE(spec_idx)) {
00942 if (within_forall_mask_expr) {
00943 PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx),
00944 AT_OBJ_NAME_PTR(spec_idx),
00945 "forall scalar-mask-expr");
00946 *semantically_correct = FALSE;
00947 }
00948 else if (within_forall_construct) {
00949 PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx),
00950 AT_OBJ_NAME_PTR(spec_idx),
00951 "forall-body-construct");
00952 *semantically_correct = FALSE;
00953 }
00954 }
00955 }
00956
00957 if (found) {
00958 PRINTMSG(IR_LINE_NUM(ir_idx), 399, Comment, IR_COL_NUM(ir_idx),
00959 str_word, AT_OBJ_NAME_PTR(spec_idx));
00960 }
00961
00962
00963
00964 arg_info_list_top = arg_info_list_base;
00965 arg_info_list_base = save_arg_info_list_base;
00966
00967 TRACE (Func_Exit, "resolve_ext_opr", NULL);
00968
00969 return(found);
00970
00971 }
00972
00973
00974
00975
00976
00977
00978
00979
00980
00981
00982
00983
00984
00985
00986
00987
00988
00989 static int opr_to_str(operator_type opr,
00990 char *str)
00991
00992 {
00993 int i;
00994 int len = 0;
00995
00996 TRACE (Func_Entry, "opr_to_str", NULL);
00997
00998 for (i = 0; i < 8; i++) {
00999 str[i] = '\0';
01000 }
01001
01002 switch (opr) {
01003 case Uplus_Opr :
01004 strncpy(str, "+", 1);
01005 len = 1;
01006 break;
01007 case Uminus_Opr :
01008 strncpy(str, "-", 1);
01009 len = 1;
01010 break;
01011 case Power_Opr :
01012 strncpy(str, "**", 2);
01013 len = 2;
01014 break;
01015 case Mult_Opr :
01016 strncpy(str, "*", 1);
01017 len = 1;
01018 break;
01019 case Div_Opr :
01020 strncpy(str, "/", 1);
01021 len = 1;
01022 break;
01023 case Plus_Opr :
01024 strncpy(str, "+", 1);
01025 len = 1;
01026 break;
01027 case Minus_Opr :
01028 strncpy(str, "-", 1);
01029 len = 1;
01030 break;
01031 case Concat_Opr :
01032 strncpy(str, "//", 2);
01033 len = 2;
01034 break;
01035 case Eq_Opr :
01036 strncpy(str, "eq", 2);
01037 len = 2;
01038 break;
01039 case Ne_Opr :
01040 strncpy(str, "ne", 2);
01041 len = 2;
01042 break;
01043 case Lg_Opr :
01044 strncpy(str, "lg", 2);
01045 len = 2;
01046 break;
01047 case Lt_Opr :
01048 strncpy(str, "lt", 2);
01049 len = 2;
01050 break;
01051 case Le_Opr :
01052 strncpy(str, "le", 2);
01053 len = 2;
01054 break;
01055 case Gt_Opr :
01056 strncpy(str, "gt", 2);
01057 len = 2;
01058 break;
01059 case Ge_Opr :
01060 strncpy(str, "ge", 2);
01061 len = 2;
01062 break;
01063 case Not_Opr :
01064 strncpy(str, "not", 3);
01065 len = 3;
01066 break;
01067 case And_Opr :
01068 strncpy(str, "and", 3);
01069 len = 3;
01070 break;
01071 case Or_Opr :
01072 strncpy(str, "or", 2);
01073 len = 2;
01074 break;
01075 case Eqv_Opr :
01076 strncpy(str, "eqv", 3);
01077 len = 3;
01078 break;
01079 case Neqv_Opr :
01080 strncpy(str, "neqv", 4);
01081 len = 4;
01082 break;
01083 case Asg_Opr :
01084 strncpy(str, "=", 1);
01085 len = 1;
01086 break;
01087 }
01088
01089 TRACE (Func_Exit, "opr_to_str", NULL);
01090
01091 return(len);
01092
01093 }
01094
01095
01096
01097
01098
01099
01100
01101
01102
01103
01104
01105
01106
01107
01108
01109
01110
01111
01112
01113
01114
01115
01116
01117 int find_base_attr(opnd_type *root_opnd,
01118 int *line,
01119 int *col)
01120
01121 {
01122 int attr_idx = NULL_IDX;
01123 opnd_type opnd;
01124
01125 TRACE (Func_Entry, "find_base_attr", NULL);
01126
01127 *line = 0;
01128 *col = 0;
01129
01130 COPY_OPND(opnd, (*root_opnd));
01131
01132 while (attr_idx == NULL_IDX) {
01133 switch (OPND_FLD(opnd)) {
01134 case AT_Tbl_Idx :
01135 attr_idx = OPND_IDX(opnd);
01136 *line = OPND_LINE_NUM(opnd);
01137 *col = OPND_COL_NUM(opnd);
01138 goto EXIT;
01139
01140 case IR_Tbl_Idx :
01141
01142 if (IR_OPR(OPND_IDX(opnd)) == Struct_Opr) {
01143 COPY_OPND(opnd, IR_OPND_R(OPND_IDX(opnd)));
01144 }
01145 else {
01146 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
01147 }
01148 break;
01149
01150 case CN_Tbl_Idx :
01151 *line = OPND_LINE_NUM(opnd);
01152 *col = OPND_COL_NUM(opnd);
01153 goto EXIT;
01154
01155 default :
01156 goto EXIT;
01157 }
01158 }
01159
01160 EXIT:
01161
01162 TRACE (Func_Exit, "find_base_attr", ((attr_idx == NULL_IDX) ? NULL :
01163 AT_OBJ_NAME_PTR(attr_idx)));
01164
01165 return(attr_idx);
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 int find_left_attr(opnd_type *root_opnd)
01193
01194 {
01195 int attr_idx = NULL_IDX;
01196 opnd_type opnd;
01197
01198
01199 TRACE (Func_Entry, "find_left_attr", NULL);
01200
01201 COPY_OPND(opnd, (*root_opnd));
01202
01203 while (attr_idx == NULL_IDX) {
01204 switch (OPND_FLD(opnd)) {
01205 case AT_Tbl_Idx :
01206 attr_idx = OPND_IDX(opnd);
01207 goto EXIT;
01208
01209 case IR_Tbl_Idx :
01210
01211 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
01212 break;
01213
01214 default :
01215 goto EXIT;
01216 }
01217 }
01218
01219 EXIT:
01220
01221 TRACE (Func_Exit, "find_left_attr", NULL);
01222
01223 return(attr_idx);
01224
01225 }
01226
01227
01228
01229
01230
01231
01232
01233
01234
01235
01236
01237
01238
01239
01240
01241
01242
01243 boolean cmp_ref_trees(opnd_type *opnd1,
01244 opnd_type *opnd2)
01245
01246 {
01247 int column;
01248 int line;
01249 int list1_idx;
01250 int list2_idx;
01251 boolean match = TRUE;
01252
01253
01254 TRACE (Func_Entry, "cmp_ref_trees", NULL);
01255
01256 if (OPND_FLD((*opnd1)) != OPND_FLD((*opnd2))) {
01257 match = FALSE;
01258 }
01259 else {
01260 switch(OPND_FLD((*opnd1))) {
01261 case NO_Tbl_Idx :
01262 match = TRUE;
01263 break;
01264
01265 case CN_Tbl_Idx :
01266 case AT_Tbl_Idx :
01267
01268 if (OPND_IDX((*opnd1)) == OPND_IDX((*opnd2))) {
01269 match = TRUE;
01270 }
01271 else {
01272 match = FALSE;
01273 }
01274 break;
01275
01276 case IL_Tbl_Idx :
01277
01278 if (OPND_LIST_CNT((*opnd1)) == OPND_LIST_CNT((*opnd2))) {
01279 list1_idx = OPND_IDX((*opnd1));
01280 list2_idx = OPND_IDX((*opnd2));
01281
01282 while (list1_idx != NULL_IDX && match) {
01283 match = cmp_ref_trees((opnd_type *)&IL_OPND(list1_idx),
01284 (opnd_type *)&IL_OPND(list2_idx));
01285 list1_idx = IL_NEXT_LIST_IDX(list1_idx);
01286 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
01287 }
01288 }
01289 else {
01290 match = FALSE;
01291 }
01292 break;
01293
01294 case SH_Tbl_Idx :
01295 find_opnd_line_and_column(opnd1, &line, &column);
01296 PRINTMSG(line, 963, Internal, column);
01297 break;
01298
01299 case IR_Tbl_Idx :
01300
01301 if (IR_OPR(OPND_IDX((*opnd1))) == IR_OPR(OPND_IDX((*opnd2)))) {
01302 match = cmp_ref_trees((opnd_type*)&IR_OPND_L(OPND_IDX((*opnd1))),
01303 (opnd_type*)&IR_OPND_L(OPND_IDX((*opnd2))));
01304 match = match &&
01305 cmp_ref_trees((opnd_type *)&IR_OPND_R(OPND_IDX((*opnd1))),
01306 (opnd_type *)&IR_OPND_R(OPND_IDX((*opnd2))));
01307 }
01308 else {
01309 match = FALSE;
01310 }
01311 break;
01312 }
01313 }
01314
01315 TRACE (Func_Exit, "cmp_ref_trees", NULL);
01316
01317 return(match);
01318
01319 }
01320
01321
01322
01323
01324
01325
01326
01327
01328
01329
01330
01331
01332
01333
01334
01335
01336
01337 void enlarge_call_list_tables(void)
01338
01339 {
01340 int new_size;
01341
01342 TRACE (Func_Entry, "enlarge_call_list_tables", NULL);
01343
01344
01345 new_size = ((max_call_list_size/CALL_LIST_TBL_INC) + 1)
01346 * CALL_LIST_TBL_INC;
01347
01348 if (arg_list_size == 0) {
01349
01350
01351
01352 MEM_ALLOC(arg_list, int, new_size);
01353
01354 }
01355 else {
01356
01357 MEM_REALLOC(arg_list, int, new_size);
01358
01359 }
01360
01361 arg_list_size = new_size;
01362
01363 TRACE (Func_Exit, "enlarge_call_list_tables", NULL);
01364
01365 return;
01366
01367 }
01368
01369
01370
01371
01372
01373
01374
01375
01376
01377
01378
01379
01380
01381
01382
01383
01384
01385 void enlarge_info_list_table(void)
01386
01387 {
01388 int new_size;
01389
01390 TRACE (Func_Entry, "enlarge_info_list_table", NULL);
01391
01392
01393 new_size = arg_info_list_size + ((max_call_list_size/CALL_LIST_TBL_INC) + 1)
01394 * CALL_LIST_TBL_INC;
01395
01396 if (arg_info_list_size == 0) {
01397
01398
01399
01400 MEM_ALLOC(arg_info_list, arg_strct_type, new_size);
01401
01402 }
01403 else {
01404
01405 MEM_REALLOC(arg_info_list, arg_strct_type, new_size);
01406
01407 }
01408
01409 arg_info_list_size = new_size;
01410
01411 TRACE (Func_Exit, "enlarge_info_list_table", NULL);
01412
01413 return;
01414
01415 }
01416
01417
01418
01419
01420
01421
01422
01423
01424
01425
01426
01427
01428
01429
01430
01431
01432
01433 void dope_vector_setup(opnd_type *r_opnd,
01434 expr_arg_type *exp_desc,
01435 opnd_type *l_opnd,
01436 boolean ptr_assign)
01437
01438 {
01439 act_arg_type a_type;
01440 int attr_idx = NULL_IDX;
01441 opnd_type base_opnd;
01442 int col;
01443 int dim = 1;
01444 int dope_idx = NULL_IDX;
01445 int dv_idx;
01446 int dv2_idx;
01447 int i;
01448 int line;
01449 int list_idx;
01450 int loc_idx;
01451 int max_idx;
01452 int mult_idx;
01453 opnd_type opnd;
01454 int opnd_column;
01455 int opnd_line;
01456 opnd_type r_dv_opnd;
01457 int rank_idx = NULL_IDX;
01458 int stride_idx;
01459 opnd_type stride_opnd;
01460 int subscript_idx;
01461 boolean whole_array;
01462
01463
01464 TRACE (Func_Entry, "dope_vector_setup", NULL);
01465
01466
01467
01468
01469 find_opnd_line_and_column(l_opnd, &opnd_line, &opnd_column);
01470
01471 # ifdef _DEBUG
01472
01473 if (OPND_FLD((*l_opnd)) != AT_Tbl_Idx &&
01474 (OPND_FLD((*l_opnd)) != IR_Tbl_Idx ||
01475 IR_OPR(OPND_IDX((*l_opnd))) != Struct_Opr)) {
01476 PRINTMSG(opnd_line, 624, Internal, opnd_column);
01477 }
01478 # endif
01479
01480
01481
01482
01483
01484 if (! ptr_assign) {
01485 NTR_IR_TBL(dv_idx);
01486 IR_OPR(dv_idx) = Dv_Set_Base_Addr;
01487 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01488 IR_LINE_NUM(dv_idx) = opnd_line;
01489 IR_COL_NUM(dv_idx) = opnd_column;
01490 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01491 NTR_IR_TBL(loc_idx);
01492 IR_OPR(loc_idx) = Loc_Opr;
01493
01494 if (exp_desc->type == Character) {
01495 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
01496 }
01497 else {
01498 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
01499 }
01500
01501 IR_LINE_NUM(loc_idx) = opnd_line;
01502 IR_COL_NUM(loc_idx) = opnd_column;
01503
01504 IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01505 IR_IDX_R(dv_idx) = loc_idx;
01506
01507 if (exp_desc->rank == 0) {
01508 COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd));
01509 just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
01510 }
01511 else {
01512 make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx);
01513 COPY_OPND(IR_OPND_L(loc_idx), base_opnd);
01514 }
01515
01516 # ifdef _TRANSFORM_CHAR_SEQUENCE
01517 # ifdef _TARGET_OS_UNICOS
01518 if (exp_desc->type == Structure &&
01519 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
01520
01521 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
01522 COPY_OPND(opnd, IR_OPND_L(loc_idx));
01523 transform_char_sequence_ref(&opnd, exp_desc->type_idx);
01524 COPY_OPND(IR_OPND_L(loc_idx), opnd);
01525 }
01526 # endif
01527 # endif
01528
01529 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01530 FALSE, FALSE, TRUE);
01531
01532 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01533 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01534
01535 }
01536 else {
01537 just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
01538 }
01539
01540
01541
01542
01543
01544
01545 if (rank_idx != NULL_IDX) {
01546 attr_idx = find_base_attr(&IR_OPND_L(rank_idx), &line, &col);
01547
01548 if (ATD_IM_A_DOPE(attr_idx)) {
01549 COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx)));
01550 }
01551 subscript_idx = IR_IDX_R(rank_idx);
01552 }
01553 else if (exp_desc->rank != 0) {
01554 attr_idx = find_base_attr(r_opnd, &line, &col);
01555
01556 if (ATD_IM_A_DOPE(attr_idx)) {
01557 COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd))));
01558 }
01559 }
01560 else {
01561 find_opnd_line_and_column(r_opnd, &line, &col);
01562 }
01563
01564 if (exp_desc->rank > 0 &&
01565 ! exp_desc->section) {
01566
01567 whole_array = TRUE;
01568 }
01569 else {
01570 whole_array = FALSE;
01571 }
01572
01573
01574
01575
01576
01577 a_type = get_act_arg_type(exp_desc);
01578
01579 if (a_type == Array_Ptr ||
01580 a_type == Array_Tmp_Ptr ||
01581 a_type == Whole_Ass_Shape ||
01582 a_type == Dv_Contig_Section) {
01583
01584 NTR_IR_TBL(dv_idx);
01585 IR_OPR(dv_idx) = Dv_Set_A_Contig;
01586 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01587 IR_LINE_NUM(dv_idx) = opnd_line;
01588 IR_COL_NUM(dv_idx) = opnd_column;
01589 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01590
01591 NTR_IR_TBL(dv2_idx);
01592 IR_OPR(dv2_idx) = Dv_Access_A_Contig;
01593 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE;
01594 IR_LINE_NUM(dv2_idx) = opnd_line;
01595 IR_COL_NUM(dv2_idx) = opnd_column;
01596 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01597 IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01598 IR_IDX_R(dv_idx) = dv2_idx;
01599
01600 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01601 FALSE, FALSE, TRUE);
01602
01603 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01604 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01605
01606 }
01607 else if (a_type == Whole_Allocatable ||
01608 a_type == Whole_Tmp_Allocatable ||
01609 a_type == Whole_Sequence ||
01610 a_type == Whole_Tmp_Sequence ||
01611 a_type == Whole_Array_Constant ||
01612 a_type == Contig_Section) {
01613
01614 NTR_IR_TBL(dv_idx);
01615 IR_OPR(dv_idx) = Dv_Set_A_Contig;
01616 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01617 IR_LINE_NUM(dv_idx) = opnd_line;
01618 IR_COL_NUM(dv_idx) = opnd_column;
01619 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01620 IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01621 IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
01622 IR_LINE_NUM_R(dv_idx) = opnd_line;
01623 IR_COL_NUM_R(dv_idx) = opnd_column;
01624
01625 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01626 FALSE, FALSE, TRUE);
01627
01628 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01629 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01630 }
01631 else {
01632 NTR_IR_TBL(dv_idx);
01633 IR_OPR(dv_idx) = Dv_Set_A_Contig;
01634 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01635 IR_LINE_NUM(dv_idx) = opnd_line;
01636 IR_COL_NUM(dv_idx) = opnd_column;
01637 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01638 IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01639 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01640 IR_LINE_NUM_R(dv_idx) = opnd_line;
01641 IR_COL_NUM_R(dv_idx) = opnd_column;
01642
01643 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01644 FALSE, FALSE, TRUE);
01645
01646 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01647 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01648 }
01649
01650
01651
01652
01653
01654 NTR_IR_TBL(dv_idx);
01655 IR_OPR(dv_idx) = Dv_Set_Assoc;
01656 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01657 IR_LINE_NUM(dv_idx) = opnd_line;
01658 IR_COL_NUM(dv_idx) = opnd_column;
01659 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01660 IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01661 IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
01662 IR_LINE_NUM_R(dv_idx) = opnd_line;
01663 IR_COL_NUM_R(dv_idx) = opnd_column;
01664
01665 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01666 FALSE, FALSE, TRUE);
01667
01668 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01669 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01670
01671
01672 for (i = 1; i <= exp_desc->rank; i++) {
01673
01674
01675
01676
01677
01678 NTR_IR_TBL(dv_idx);
01679 IR_OPR(dv_idx) = Dv_Set_Low_Bound;
01680 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01681 IR_LINE_NUM(dv_idx) = opnd_line;
01682 IR_COL_NUM(dv_idx) = opnd_column;
01683 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01684
01685 if (whole_array) {
01686
01687 if (ATD_IM_A_DOPE(attr_idx) &&
01688 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Assumed_Shape) {
01689 NTR_IR_TBL(dv2_idx);
01690 IR_OPR(dv2_idx) = Dv_Access_Low_Bound;
01691 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
01692 IR_LINE_NUM(dv2_idx) = opnd_line;
01693 IR_COL_NUM(dv2_idx) = opnd_column;
01694 COPY_OPND(IR_OPND_L(dv2_idx), r_dv_opnd);
01695 IR_DV_DIM(dv2_idx) = i;
01696 IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01697 IR_IDX_R(dv_idx) = dv2_idx;
01698 }
01699 else {
01700 IR_FLD_R(dv_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i);
01701 IR_IDX_R(dv_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i);
01702 IR_LINE_NUM_R(dv_idx) = opnd_line;
01703 IR_COL_NUM_R(dv_idx) = opnd_column;
01704
01705 if (IR_FLD_R(dv_idx) == AT_Tbl_Idx) {
01706 ADD_TMP_TO_SHARED_LIST(IR_IDX_R(dv_idx));
01707 }
01708 }
01709 }
01710 else {
01711
01712 IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01713 IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
01714 IR_LINE_NUM_R(dv_idx) = opnd_line;
01715 IR_COL_NUM_R(dv_idx) = opnd_column;
01716 }
01717
01718 IR_DV_DIM(dv_idx) = i;
01719
01720 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01721 FALSE, FALSE, TRUE);
01722
01723 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01724 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01725
01726
01727
01728
01729
01730
01731 NTR_IR_TBL(dv_idx);
01732 IR_OPR(dv_idx) = Dv_Set_Extent;
01733 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01734 IR_LINE_NUM(dv_idx) = opnd_line;
01735 IR_COL_NUM(dv_idx) = opnd_column;
01736 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01737
01738 NTR_IR_TBL(max_idx);
01739 IR_OPR(max_idx) = Max_Opr;
01740 IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE;
01741 IR_LINE_NUM(max_idx) = opnd_line;
01742 IR_COL_NUM(max_idx) = opnd_column;
01743
01744 NTR_IR_LIST_TBL(list_idx);
01745 IR_FLD_L(max_idx) = IL_Tbl_Idx;
01746 IR_LIST_CNT_L(max_idx) = 2;
01747 IR_IDX_L(max_idx) = list_idx;
01748
01749 IL_FLD(list_idx) = CN_Tbl_Idx;
01750 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
01751 IL_LINE_NUM(list_idx) = opnd_line;
01752 IL_COL_NUM(list_idx) = opnd_column;
01753
01754 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01755 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01756 list_idx = IL_NEXT_LIST_IDX(list_idx);
01757
01758 COPY_OPND(IL_OPND(list_idx), exp_desc->shape[i-1]);
01759 IL_LINE_NUM(list_idx) = opnd_line;
01760 IL_COL_NUM(list_idx) = opnd_column;
01761
01762 IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01763 IR_IDX_R(dv_idx) = max_idx;
01764
01765 IR_DV_DIM(dv_idx) = i;
01766
01767 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01768 FALSE, FALSE, TRUE);
01769
01770 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01771 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01772
01773
01774
01775
01776
01777 NTR_IR_TBL(dv_idx);
01778 IR_OPR(dv_idx) = Dv_Set_Stride_Mult;
01779 IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE;
01780 IR_LINE_NUM(dv_idx) = opnd_line;
01781 IR_COL_NUM(dv_idx) = opnd_column;
01782 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01783
01784 if (whole_array) {
01785
01786 gen_dv_stride_mult(&stride_opnd,
01787 attr_idx,
01788 &r_dv_opnd,
01789 exp_desc,
01790 i,
01791 opnd_line,
01792 opnd_column);
01793
01794 COPY_OPND(IR_OPND_R(dv_idx), stride_opnd);
01795 }
01796 else {
01797 while (IL_FLD(subscript_idx) != IR_Tbl_Idx ||
01798 IR_OPR(IL_IDX(subscript_idx)) != Triplet_Opr) {
01799 subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
01800 dim++;
01801 }
01802
01803 gen_dv_stride_mult(&stride_opnd,
01804 attr_idx,
01805 &r_dv_opnd,
01806 exp_desc,
01807 dim,
01808 opnd_line,
01809 opnd_column);
01810
01811 stride_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(
01812 IL_IDX(subscript_idx))));
01813 mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd),
01814 Mult_Opr, CG_INTEGER_DEFAULT_TYPE, opnd_line, opnd_column,
01815 IL_FLD(stride_idx), IL_IDX(stride_idx));
01816
01817 IR_FLD_R(dv_idx) = IR_Tbl_Idx;;
01818 IR_IDX_R(dv_idx) = mult_idx;
01819
01820 subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
01821 dim++;
01822 }
01823
01824 IR_DV_DIM(dv_idx) = i;
01825
01826 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01827 FALSE, FALSE, TRUE);
01828
01829 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01830 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01831
01832 }
01833
01834
01835
01836
01837
01838 NTR_IR_TBL(dv_idx);
01839 IR_OPR(dv_idx) = Dv_Set_Ptr_Alloc;
01840 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01841 IR_LINE_NUM(dv_idx) = opnd_line;
01842 IR_COL_NUM(dv_idx) = opnd_column;
01843 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01844
01845 if (dope_idx != NULL_IDX) {
01846 NTR_IR_TBL(dv2_idx);
01847 IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc;
01848 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE;
01849 IR_LINE_NUM(dv2_idx) = opnd_line;
01850 IR_COL_NUM(dv2_idx) = opnd_column;
01851 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01852 IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01853 IR_IDX_R(dv_idx) = dv2_idx;
01854 }
01855 else {
01856 IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01857 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01858 IR_LINE_NUM_R(dv_idx) = opnd_line;
01859 IR_COL_NUM_R(dv_idx) = opnd_column;
01860 }
01861
01862 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01863 FALSE, FALSE, TRUE);
01864
01865 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01866 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01867
01868
01869
01870
01871
01872 NTR_IR_TBL(dv_idx);
01873 IR_OPR(dv_idx) = Dv_Set_Orig_Base;
01874 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01875 IR_LINE_NUM(dv_idx) = opnd_line;
01876 IR_COL_NUM(dv_idx) = opnd_column;
01877 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01878
01879 if (dope_idx != NULL_IDX) {
01880 NTR_IR_TBL(dv2_idx);
01881 IR_OPR(dv2_idx) = Dv_Access_Orig_Base;
01882 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
01883 IR_LINE_NUM(dv2_idx) = opnd_line;
01884 IR_COL_NUM(dv2_idx) = opnd_column;
01885 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01886 IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01887 IR_IDX_R(dv_idx) = dv2_idx;
01888 }
01889 else {
01890 IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01891 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01892 IR_LINE_NUM_R(dv_idx) = opnd_line;
01893 IR_COL_NUM_R(dv_idx) = opnd_column;
01894 }
01895
01896 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01897 FALSE, FALSE, TRUE);
01898
01899 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01900 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01901
01902
01903
01904
01905
01906 NTR_IR_TBL(dv_idx);
01907 IR_OPR(dv_idx) = Dv_Set_Orig_Size;
01908 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01909 IR_LINE_NUM(dv_idx) = opnd_line;
01910 IR_COL_NUM(dv_idx) = opnd_column;
01911 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01912
01913 if (dope_idx != NULL_IDX) {
01914 NTR_IR_TBL(dv2_idx);
01915 IR_OPR(dv2_idx) = Dv_Access_Orig_Size;
01916 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
01917 IR_LINE_NUM(dv2_idx) = opnd_line;
01918 IR_COL_NUM(dv2_idx) = opnd_column;
01919 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01920 IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01921 IR_IDX_R(dv_idx) = dv2_idx;
01922 }
01923 else {
01924 IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01925 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01926 IR_LINE_NUM_R(dv_idx) = opnd_line;
01927 IR_COL_NUM_R(dv_idx) = opnd_column;
01928 }
01929
01930 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01931 FALSE, FALSE, TRUE);
01932
01933 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01934 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01935
01936 TRACE (Func_Exit, "dope_vector_setup", NULL);
01937
01938 return;
01939
01940 }
01941
01942
01943
01944
01945
01946
01947
01948
01949
01950
01951
01952
01953
01954
01955
01956
01957
01958 void make_io_type_code(int type_idx,
01959 long_type *value)
01960
01961 {
01962 long_type dec_len = 0;
01963 int dp_flag = 0;
01964 int dv_type;
01965 long_type int_len = 0;
01966 int kind_star = 0;
01967
01968 f90_type_t *type_code;
01969
01970
01971 TRACE (Func_Entry, "make_io_type_code", NULL);
01972
01973 switch(TYP_DESC(type_idx)) {
01974 case Default_Typed:
01975 kind_star = DV_DEFAULT_TYPED;
01976 break;
01977
01978 case Star_Typed:
01979 kind_star = DV_STAR_TYPED;
01980 break;
01981
01982 case Kind_Typed:
01983 if (TYP_TYPE(type_idx) == Real &&
01984 TYP_KIND_DOUBLE(type_idx)) {
01985 kind_star = DV_KIND_DOUBLE;
01986 }
01987 else if (TYP_KIND_CONST(type_idx)) {
01988 kind_star = DV_KIND_CONST;
01989 }
01990 else {
01991 kind_star = DV_KIND_TYPED;
01992 }
01993 break;
01994 }
01995
01996 # ifndef _TARGET_OS_MAX
01997 if (TYP_DECLARED_DBL(type_idx) &&
01998 kind_star == DV_DEFAULT_TYPED) {
01999
02000 dp_flag = 1;
02001 }
02002 # endif
02003
02004 switch (TYP_TYPE(type_idx)) {
02005 case Typeless:
02006
02007
02008
02009 dec_len = (long) TYP_BIT_LEN(type_idx) / TARGET_BYTES_PER_WORD;
02010 int_len = (long) TYP_BIT_LEN(type_idx);
02011 dv_type = DV_TYPELESS;
02012
02013 break;
02014
02015 case Integer:
02016
02017 dec_len = (long) TYP_DCL_VALUE(type_idx);
02018 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02019 dv_type = DV_INTEGER;
02020
02021 break;
02022
02023 case Logical:
02024
02025 dec_len = (long) TYP_DCL_VALUE(type_idx);
02026 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02027 dv_type = DV_LOGICAL;
02028
02029 break;
02030
02031 case Real:
02032
02033 dec_len = (long) TYP_DCL_VALUE(type_idx);
02034 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02035 dv_type = DV_REAL;
02036
02037 break;
02038
02039 case Complex:
02040
02041 dec_len = (long) TYP_DCL_VALUE(type_idx);
02042 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02043 dv_type = DV_COMPLEX;
02044
02045 break;
02046
02047 case Character:
02048
02049 if (kind_star == DV_DEFAULT_TYPED) {
02050 dec_len = 0;
02051 }
02052 else {
02053 dec_len = 1;
02054 }
02055 int_len = 8;
02056 dv_type = DV_ASCII_CHAR;
02057
02058 break;
02059
02060 case Structure:
02061
02062 if (ATT_CHAR_SEQ(TYP_IDX(type_idx))) {
02063 dv_type = DV_ASCII_CHAR_SEQUENCE_STRUCT;
02064 }
02065 else {
02066 dv_type = DV_STRUCT;
02067 }
02068
02069 break;
02070
02071 case CRI_Ptr:
02072 case CRI_Ch_Ptr:
02073
02074 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02075 dv_type = DV_INTEGER;
02076
02077 break;
02078 }
02079
02080 # ifdef _TYPE_CODE_64_BIT
02081 type_code = (f90_type_t *)value;
02082
02083 type_code->unused = 0;
02084 type_code->type = dv_type;
02085 type_code->dpflag = dp_flag;
02086 type_code->kind_or_star = kind_star;
02087 type_code->int_len = int_len;
02088 type_code->dec_len = dec_len;
02089 # else
02090
02091 *value = ((dv_type << DV_TYPE_SHIFT) |
02092 (dp_flag << DV_DP_SHIFT) |
02093 (kind_star << DV_KIND_STAR_SHIFT) |
02094 (int_len << DV_INT_LEN_SHIFT) |
02095 (dec_len << DV_DEC_LEN_SHIFT));
02096 # endif
02097
02098 TRACE (Func_Exit, "make_io_type_code", NULL);
02099
02100 return;
02101
02102 }
02103
02104
02105
02106
02107
02108
02109
02110
02111
02112
02113
02114
02115
02116
02117
02118
02119
02120
02121 static int create_dv_type_code(int attr_idx)
02122
02123 {
02124 int constant_idx = NULL_IDX;
02125 long_type constant[2];
02126
02127 TRACE (Func_Entry, "create_dv_type_code", NULL);
02128
02129 make_io_type_code(ATD_TYPE_IDX(attr_idx), constant);
02130
02131 constant_idx = ntr_const_tbl(IO_TYPE_CODE_TYPE, FALSE, constant);
02132
02133 TRACE (Func_Exit, "create_dv_type_code", NULL);
02134
02135 return(constant_idx);
02136
02137 }
02138
02139
02140
02141
02142
02143
02144
02145
02146
02147
02148
02149
02150
02151
02152
02153
02154
02155 void gen_common_dv_init(opnd_type *dv_opnd,
02156 int dv_attr_idx,
02157 sh_position_type position)
02158
02159 {
02160 int col;
02161 int ir_idx;
02162 size_offset_type length;
02163 int line;
02164 int mult_idx;
02165 size_offset_type result;
02166 int type_idx;
02167
02168
02169 TRACE (Func_Entry, "gen_common_dv_init", NULL);
02170
02171 find_opnd_line_and_column(dv_opnd, &line, &col);
02172
02173
02174
02175
02176
02177
02178
02179
02180
02181
02182
02183 NTR_IR_TBL(ir_idx);
02184 IR_OPR(ir_idx) = Dv_Set_El_Len;
02185 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02186 IR_LINE_NUM(ir_idx) = line;
02187 IR_COL_NUM(ir_idx) = col;
02188
02189 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02190
02191 type_idx = ATD_TYPE_IDX(dv_attr_idx);
02192
02193 if (TYP_TYPE(type_idx) == Structure) {
02194 IR_FLD_R(ir_idx) = (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
02195 IR_IDX_R(ir_idx) = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
02196 IR_LINE_NUM_R(ir_idx) = line;
02197 IR_COL_NUM_R(ir_idx) = col;
02198 }
02199 else if (TYP_TYPE(type_idx) == Character) {
02200
02201 IR_FLD_R(ir_idx) = TYP_FLD(type_idx);
02202 IR_IDX_R(ir_idx) = TYP_IDX(type_idx);
02203 IR_LINE_NUM_R(ir_idx) = line;
02204 IR_COL_NUM_R(ir_idx) = col;
02205
02206 if (IR_FLD_R(ir_idx) == AT_Tbl_Idx) {
02207 ADD_TMP_TO_SHARED_LIST(IR_IDX_R(ir_idx));
02208 }
02209
02210 if (! char_len_in_bytes) {
02211
02212
02213
02214
02215 if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
02216 result.fld = CN_Tbl_Idx;
02217 result.idx = CN_INTEGER_CHAR_BIT_IDX;
02218 length.fld = TYP_FLD(type_idx);
02219 length.idx = TYP_IDX(type_idx);
02220
02221 size_offset_binary_calc(&length,
02222 &result,
02223 Mult_Opr,
02224 &result);
02225
02226 if (result.fld == NO_Tbl_Idx) {
02227 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02228 IR_IDX_R(ir_idx) = ntr_const_tbl(result.type_idx,
02229 FALSE,
02230 result.constant);
02231 }
02232 else {
02233 IR_FLD_R(ir_idx) = result.fld;
02234 IR_IDX_R(ir_idx) = result.idx;
02235 }
02236
02237 IR_LINE_NUM_R(ir_idx) = line;
02238 IR_COL_NUM_R(ir_idx) = col;
02239 }
02240 else {
02241 NTR_IR_TBL(mult_idx);
02242 IR_OPR(mult_idx) = Mult_Opr;
02243 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
02244 IR_LINE_NUM(mult_idx) = line;
02245 IR_COL_NUM(mult_idx) = col;
02246 IR_FLD_L(mult_idx) = CN_Tbl_Idx;
02247 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
02248 IR_LINE_NUM_L(mult_idx) = line;
02249 IR_COL_NUM_L(mult_idx) = col;
02250
02251 IR_FLD_R(mult_idx) = TYP_FLD(type_idx);
02252 IR_IDX_R(mult_idx) = TYP_IDX(type_idx);
02253 IR_LINE_NUM_R(mult_idx) = line;
02254 IR_COL_NUM_R(mult_idx) = col;
02255
02256 IR_FLD_R(ir_idx) = IR_Tbl_Idx;
02257 IR_IDX_R(ir_idx) = mult_idx;
02258 }
02259 }
02260 }
02261 else {
02262 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02263 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
02264 storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
02265 IR_LINE_NUM_R(ir_idx) = line;
02266 IR_COL_NUM_R(ir_idx) = col;
02267 }
02268
02269 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02270
02271 if (position == After) {
02272 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02273 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02274 }
02275 else {
02276 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02277 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02278 }
02279
02280
02281
02282
02283
02284
02285
02286
02287
02288
02289
02290
02291
02292
02293
02294
02295
02296
02297
02298 NTR_IR_TBL(ir_idx);
02299 IR_OPR(ir_idx) = Dv_Set_P_Or_A;
02300 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02301 IR_LINE_NUM(ir_idx) = line;
02302 IR_COL_NUM(ir_idx) = col;
02303
02304 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02305
02306 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02307
02308 if (ATD_ALLOCATABLE(dv_attr_idx)) {
02309 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2);
02310 }
02311 else if (ATD_POINTER(dv_attr_idx)) {
02312 IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX;
02313 }
02314 else {
02315 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
02316 }
02317 IR_LINE_NUM_R(ir_idx) = line;
02318 IR_COL_NUM_R(ir_idx) = col;
02319
02320 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02321
02322 if (position == After) {
02323 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02324 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02325 }
02326 else {
02327 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02328 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02329 }
02330
02331
02332
02333
02334
02335
02336
02337 if (!ATD_IN_COMMON(dv_attr_idx))
02338 {
02339 NTR_IR_TBL(ir_idx);
02340 IR_OPR(ir_idx) = Dv_Set_A_Contig;
02341 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02342 IR_LINE_NUM(ir_idx) = line;
02343 IR_COL_NUM(ir_idx) = col;
02344
02345 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02346
02347 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02348
02349 if (ATD_ALLOCATABLE(dv_attr_idx)) {
02350 IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX;
02351 }
02352 else {
02353 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
02354 }
02355 IR_LINE_NUM_R(ir_idx) = line;
02356 IR_COL_NUM_R(ir_idx) = col;
02357
02358 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02359
02360 if (position == After) {
02361 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02362 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02363 }
02364 else {
02365 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02366 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02367 }
02368 }
02369
02370
02371
02372
02373
02374
02375 NTR_IR_TBL(ir_idx);
02376 IR_OPR(ir_idx) =Dv_Set_N_Dim ;
02377 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02378 IR_LINE_NUM(ir_idx) = line;
02379 IR_COL_NUM(ir_idx) = col;
02380
02381 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02382
02383 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02384 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
02385 (ATD_ARRAY_IDX(dv_attr_idx) ?
02386 BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0));
02387 IR_LINE_NUM_R(ir_idx) = line;
02388 IR_COL_NUM_R(ir_idx) = col;
02389
02390 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02391
02392 if (position == After) {
02393 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02394 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02395 }
02396 else {
02397 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02398 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02399 }
02400
02401
02402
02403
02404
02405
02406 NTR_IR_TBL(ir_idx);
02407 IR_OPR(ir_idx) = Dv_Set_Typ_Code;
02408 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02409 IR_LINE_NUM(ir_idx) = line;
02410 IR_COL_NUM(ir_idx) = col;
02411
02412 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02413
02414 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02415 IR_IDX_R(ir_idx) = create_dv_type_code(dv_attr_idx);
02416 IR_LINE_NUM_R(ir_idx) = line;
02417 IR_COL_NUM_R(ir_idx) = col;
02418
02419 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02420
02421 if (position == After) {
02422 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02423 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02424 }
02425 else {
02426 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02427 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02428 }
02429
02430
02431
02432
02433
02434
02435
02436
02437
02438
02439
02440
02441
02442
02443 TRACE (Func_Exit, "gen_common_dv_init", NULL);
02444
02445 return;
02446
02447 }
02448
02449
02450
02451
02452
02453
02454
02455
02456
02457
02458
02459
02460
02461
02462
02463
02464
02465 void gen_static_dv_whole_def(opnd_type *dv_opnd,
02466 int attr_idx,
02467 sh_position_type position)
02468
02469 {
02470 int col;
02471 long_type constant[2];
02472 int const_idx;
02473 ext_dope_type *dv_ptr;
02474 int ir_idx;
02475 int i;
02476 int line;
02477 int mult_idx;
02478 int num_words;
02479 long_type rank;
02480 int type_idx;
02481
02482
02483 TRACE (Func_Entry, "gen_static_dv_whole_def", NULL);
02484
02485 find_opnd_line_and_column(dv_opnd, &line, &col);
02486
02487 rank = (ATD_ARRAY_IDX(attr_idx) ? (long)BD_RANK(ATD_ARRAY_IDX(attr_idx)) :0);
02488
02489 num_words = DV_HD_WORD_SIZE + (rank * DV_DIM_WORD_SIZE);
02490
02491 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
02492 TYP_TYPE(TYP_WORK_IDX) = Typeless;
02493 TYP_BIT_LEN(TYP_WORK_IDX) = num_words * TARGET_BITS_PER_WORD;
02494 type_idx = ntr_type_tbl();
02495
02496 const_idx = ntr_const_tbl(type_idx, FALSE, NULL);
02497
02498
02499 if (ATD_CLASS(attr_idx) == Compiler_Tmp) {
02500 ATD_FLD(attr_idx) = CN_Tbl_Idx;
02501 ATD_TMP_IDX(attr_idx) = const_idx;
02502 ATD_TMP_INIT_NOT_DONE(attr_idx) = TRUE;
02503 }
02504 else {
02505 gen_init_stmt(dv_opnd,
02506 const_idx,
02507 position);
02508 }
02509
02510 dv_ptr = (ext_dope_type *)&CN_CONST(const_idx);
02511 type_idx = ATD_TYPE_IDX(attr_idx);
02512
02513
02514
02515
02516
02517
02518
02519
02520 if (TYP_TYPE(type_idx) == Structure) {
02521
02522 if (compare_cn_and_value(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)),
02523 MAX_DV_EL_LEN,
02524 Ge_Opr)) {
02525 PRINTMSG(line, 1174, Error, col,
02526 CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))),
02527 MAX_DV_EL_LEN);
02528 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
02529 }
02530 else {
02531 DV_SET_EL_LEN(*dv_ptr,
02532 CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))));
02533 }
02534 }
02535 else if (TYP_TYPE(type_idx) == Character) {
02536
02537 if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
02538
02539 if (char_len_in_bytes) {
02540
02541 if (compare_cn_and_value(TYP_IDX(type_idx),
02542 MAX_DV_EL_LEN,
02543 Ge_Opr)) {
02544 PRINTMSG(line, 1174, Error, col,
02545 CN_INT_TO_C(TYP_IDX(type_idx)),
02546 MAX_DV_EL_LEN);
02547 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
02548 }
02549 else {
02550 DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx)));
02551 }
02552 }
02553 else {
02554
02555 if (compare_cn_and_value(TYP_IDX(type_idx),
02556 MAX_DV_EL_LEN/8,
02557 Ge_Opr)) {
02558 PRINTMSG(line, 1174, Error, col,
02559 CN_INT_TO_C(TYP_IDX(type_idx)),
02560 MAX_DV_EL_LEN/8);
02561 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
02562 }
02563 else {
02564 DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx)) * 8);
02565 }
02566 }
02567 }
02568 else {
02569
02570
02571
02572
02573 NTR_IR_TBL(ir_idx);
02574 IR_OPR(ir_idx) = Dv_Set_El_Len;
02575 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02576 IR_LINE_NUM(ir_idx) = line;
02577 IR_COL_NUM(ir_idx) = col;
02578
02579 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02580
02581 if (char_len_in_bytes) {
02582
02583
02584 IR_FLD_R(ir_idx) = TYP_FLD(type_idx);
02585 IR_IDX_R(ir_idx) = TYP_IDX(type_idx);
02586 IR_LINE_NUM_R(ir_idx) = line;
02587 IR_COL_NUM_R(ir_idx) = col;
02588 }
02589 else {
02590 NTR_IR_TBL(mult_idx);
02591 IR_OPR(mult_idx) = Mult_Opr;
02592 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
02593 IR_LINE_NUM(mult_idx) = line;
02594 IR_COL_NUM(mult_idx) = col;
02595 IR_FLD_L(mult_idx) = CN_Tbl_Idx;
02596 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
02597 IR_LINE_NUM_L(mult_idx) = line;
02598 IR_COL_NUM_L(mult_idx) = col;
02599
02600 IR_FLD_R(mult_idx) = TYP_FLD(type_idx);
02601 IR_IDX_R(mult_idx) = TYP_IDX(type_idx);
02602 IR_LINE_NUM_R(mult_idx) = line;
02603 IR_COL_NUM_R(mult_idx) = col;
02604
02605 IR_FLD_R(ir_idx) = IR_Tbl_Idx;
02606 IR_IDX_R(ir_idx) = mult_idx;
02607 }
02608
02609 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02610
02611 if (position == After) {
02612 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02613 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02614 }
02615 else {
02616 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02617 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02618 }
02619 }
02620 }
02621 else {
02622 DV_SET_EL_LEN(*dv_ptr, storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
02623 }
02624
02625
02626
02627
02628
02629 if (ATD_ALLOCATABLE(attr_idx)) {
02630 DV_SET_P_OR_A(*dv_ptr, 2);
02631 }
02632 else if (ATD_POINTER(attr_idx)) {
02633 DV_SET_P_OR_A(*dv_ptr, 1);
02634 }
02635
02636
02637
02638
02639
02640 DV_SET_NUM_DIMS(*dv_ptr, rank);
02641
02642
02643
02644
02645
02646 make_io_type_code(type_idx, constant);
02647 # ifdef _TYPE_CODE_64_BIT
02648 DV_SET_TYPE_CODE(*dv_ptr, *(f90_type_t *)constant);
02649 # else
02650 DV_SET_TYPE_CODE(*dv_ptr, *constant);
02651 # endif
02652
02653 if (cmd_line_flags.runtime_bounds &&
02654 ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
02655
02656 for (i = 0; i < BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) {
02657
02658
02659
02660
02661
02662 DV_SET_LOW_BOUND(*dv_ptr, i, 1);
02663
02664
02665
02666
02667
02668
02669
02670
02671
02672
02673
02674 DV_SET_STRIDE_MULT(*dv_ptr, i, 1);
02675
02676 }
02677 }
02678
02679 TRACE (Func_Exit, "gen_static_dv_whole_def", NULL);
02680
02681 return;
02682
02683 }
02684
02685
02686
02687
02688
02689
02690
02691
02692
02693
02694
02695
02696
02697
02698
02699
02700
02701 static long64 create_imp_do_loops(opnd_type *top_opnd)
02702
02703 {
02704
02705 int col;
02706 long64 count = 1;
02707 long64 end;
02708 int i;
02709 int imp_idx;
02710 int line;
02711 int list_idx;
02712 opnd_type opnd;
02713 long64 start;
02714 int tmp_idx;
02715 int trip_list_idx;
02716
02717
02718 TRACE (Func_Entry, "create_imp_do_loops", NULL);
02719
02720 COPY_OPND(opnd, (*top_opnd));
02721 find_opnd_line_and_column(&opnd, &line, &col);
02722
02723 while (OPND_FLD(opnd) == IR_Tbl_Idx) {
02724
02725 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
02726
02727 trip_list_idx = IR_IDX_R(OPND_IDX(opnd));
02728
02729 for (i = 0; i < IR_LIST_CNT_R(OPND_IDX(opnd)); i++) {
02730
02731 NTR_IR_TBL(imp_idx);
02732 IR_OPR(imp_idx) = Implied_Do_Opr;
02733 IR_TYPE_IDX(imp_idx) = TYPELESS_DEFAULT_TYPE;
02734 IR_LINE_NUM(imp_idx) = line;
02735 IR_COL_NUM(imp_idx) = col;
02736
02737 NTR_IR_LIST_TBL(list_idx);
02738 IR_FLD_L(imp_idx) = IL_Tbl_Idx;
02739 IR_LIST_CNT_L(imp_idx) = 1;
02740 IR_IDX_L(imp_idx) = list_idx;
02741
02742 COPY_OPND(IL_OPND(list_idx), (*top_opnd));
02743 OPND_FLD((*top_opnd)) = IR_Tbl_Idx;
02744 OPND_IDX((*top_opnd)) = imp_idx;
02745
02746
02747
02748 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
02749 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE;
02750 AT_SEMANTICS_DONE(tmp_idx)= TRUE;
02751 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
02752 ATD_IMP_DO_LCV(tmp_idx) = TRUE;
02753 ATD_LCV_IS_CONST(tmp_idx) = TRUE;
02754
02755
02756
02757 NTR_IR_LIST_TBL(list_idx);
02758 IR_FLD_R(imp_idx) = IL_Tbl_Idx;
02759 IR_LIST_CNT_R(imp_idx) = 4;
02760 IR_IDX_R(imp_idx) = list_idx;
02761
02762 IL_FLD(list_idx) = AT_Tbl_Idx;
02763 IL_IDX(list_idx) = tmp_idx;
02764 IL_LINE_NUM(list_idx) = line;
02765 IL_COL_NUM(list_idx) = col;
02766
02767
02768
02769 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02770 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02771 list_idx = IL_NEXT_LIST_IDX(list_idx);
02772
02773 COPY_OPND(IL_OPND(list_idx),
02774 IL_OPND(IR_IDX_L(IL_IDX(trip_list_idx))));
02775
02776 start = CN_INT_TO_C(IL_IDX(list_idx));
02777
02778
02779
02780 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02781 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02782 list_idx = IL_NEXT_LIST_IDX(list_idx);
02783
02784 COPY_OPND(IL_OPND(list_idx),
02785 IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L(
02786 IL_IDX(trip_list_idx)))));
02787
02788 end = CN_INT_TO_C(IL_IDX(list_idx));
02789
02790 count = count * ((end - start) + 1);
02791
02792
02793
02794 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02795 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02796 list_idx = IL_NEXT_LIST_IDX(list_idx);
02797
02798 COPY_OPND(IL_OPND(list_idx),
02799 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
02800 IR_IDX_L(IL_IDX(trip_list_idx))))));
02801
02802
02803
02804
02805 IL_FLD(trip_list_idx) = AT_Tbl_Idx;
02806 IL_IDX(trip_list_idx) = tmp_idx;
02807 IL_LINE_NUM(trip_list_idx) = line;
02808 IL_COL_NUM(trip_list_idx) = col;
02809
02810 trip_list_idx = IL_NEXT_LIST_IDX(trip_list_idx);
02811 }
02812 }
02813
02814 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
02815 }
02816
02817
02818 TRACE (Func_Exit, "create_imp_do_loops", NULL);
02819
02820 return(count);
02821
02822 }
02823
02824
02825
02826
02827
02828
02829
02830
02831
02832
02833
02834
02835
02836
02837
02838
02839
02840
02841 void gen_entry_dope_code(int attr_idx)
02842
02843 {
02844 expr_arg_type exp_desc;
02845 void (*func)();
02846 opnd_type opnd;
02847 int opr;
02848
02849
02850 TRACE (Func_Entry, "gen_entry_dope_code", NULL);
02851
02852 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
02853 func = gen_static_dv_whole_def;
02854 opr = Init_Opr;
02855 }
02856 else if (ATD_AUTOMATIC(attr_idx) ||
02857 ATD_CLASS(attr_idx) == Function_Result) {
02858 func = gen_dv_whole_def_init;
02859 opr = Asg_Opr;
02860 }
02861 else if (ATD_IN_COMMON(attr_idx)) {
02862
02863 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
02864 func = gen_common_dv_init;
02865 opr = Init_Opr;
02866 # else
02867 func = gen_static_dv_whole_def;
02868 opr = Init_Opr;
02869 # endif
02870 }
02871 else if (ATD_SAVED(attr_idx) ||
02872 ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx))) {
02873 func = gen_static_dv_whole_def;
02874 opr = Init_Opr;
02875 }
02876 else {
02877 func = gen_dv_whole_def_init;
02878 opr = Asg_Opr;
02879 }
02880
02881 if (AT_DCL_ERR(attr_idx)) {
02882 goto EXIT;
02883 }
02884
02885 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
02886
02887 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module &&
02888 ATD_IN_COMMON(attr_idx)) {
02889
02890
02891
02892 }
02893 else
02894 # endif
02895
02896
02897 if (ATD_IM_A_DOPE(attr_idx)) {
02898 OPND_FLD(opnd) = AT_Tbl_Idx;
02899 OPND_IDX(opnd) = attr_idx;
02900 OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx);
02901 OPND_COL_NUM(opnd) = SH_COL_NUM(curr_stmt_sh_idx);
02902 (*func)(&opnd, attr_idx, After);
02903 }
02904 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
02905 (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
02906 ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) &&
02907 ! AT_DCL_ERR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
02908
02909 OPND_FLD(opnd) = AT_Tbl_Idx;
02910 OPND_IDX(opnd) = attr_idx;
02911 OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx);
02912 OPND_COL_NUM(opnd) = SH_COL_NUM(curr_stmt_sh_idx);
02913
02914 # if defined(_TARGET_OS_MAX)
02915 if (ATD_ARRAY_IDX(attr_idx) ||
02916 ATD_PE_ARRAY_IDX(attr_idx))
02917 # else
02918 if (ATD_ARRAY_IDX(attr_idx))
02919 # endif
02920 {
02921 gen_whole_subscript(&opnd, &exp_desc);
02922 }
02923
02924 process_cpnt_inits(&opnd,
02925 TYP_IDX(ATD_TYPE_IDX(attr_idx)),
02926 func,
02927 opr,
02928 After);
02929 }
02930
02931
02932 EXIT:
02933
02934 TRACE (Func_Exit, "gen_entry_dope_code", NULL);
02935
02936 return;
02937
02938 }
02939
02940
02941
02942
02943
02944
02945
02946
02947
02948
02949
02950
02951
02952
02953
02954
02955
02956
02957
02958
02959
02960 void process_cpnt_inits(opnd_type *left_opnd,
02961 int type_idx,
02962 void (*func)(),
02963 int opr,
02964 sh_position_type position)
02965
02966 {
02967 int attr_idx;
02968 opnd_type cn_opnd;
02969 int col;
02970 int const_idx;
02971 expr_arg_type exp_desc;
02972 int i;
02973 int init_idx;
02974 int ir_idx;
02975 int line;
02976 int list_idx;
02977 boolean need_loops = FALSE;
02978 opnd_type opnd;
02979 int placeholder_sh_idx = NULL_IDX;
02980 int save_curr_stmt_sh_idx;
02981 int save_target_array_idx;
02982 int sub_idx;
02983 int sn_idx;
02984 int tmp_idx;
02985 opnd_type tmp_opnd;
02986
02987 TRACE (Func_Entry, "process_cpnt_inits", NULL);
02988
02989 find_opnd_line_and_column(left_opnd, &line, &col);
02990
02991 # ifdef _DEBUG
02992 if (opr != Asg_Opr &&
02993 opr != Init_Opr) {
02994 PRINTMSG(line, 626, Internal, col,
02995 "Asg_Opr or Init_Opr", "process_cpnt_inits");
02996 }
02997 # endif
02998
02999 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
03000
03001 if (position == After) {
03002 save_curr_stmt_sh_idx = SH_NEXT_IDX(save_curr_stmt_sh_idx);
03003 }
03004
03005 # if defined(_GEN_LOOPS_FOR_DV_WHOLE_DEF)
03006 if (func == (void (*)())gen_dv_whole_def_init ||
03007 func == (void (*)())gen_dv_whole_def ||
03008 func == (void (*)())gen_sf_dv_whole_def) {
03009
03010 need_loops = TRUE;
03011 }
03012 # endif
03013
03014 if (ATT_DEFAULT_INITIALIZED(type_idx) &&
03015 opr == Asg_Opr) {
03016 need_loops = TRUE;
03017 }
03018
03019 if (need_loops) {
03020 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03021
03022 if (position == Before) {
03023 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03024 }
03025 placeholder_sh_idx = curr_stmt_sh_idx;
03026
03027 gen_dv_def_loops(left_opnd);
03028
03029 # ifdef _DEBUG
03030 if (placeholder_sh_idx != curr_stmt_sh_idx) {
03031 PRINTMSG(line, 626, Internal, col,
03032 "placeholder_sh_idx == curr_stmt_sh_idx",
03033 "process_cpnt_inits");
03034 }
03035 # endif
03036 }
03037
03038 sn_idx = ATT_FIRST_CPNT_IDX(type_idx);
03039
03040 while (sn_idx != NULL_IDX) {
03041 attr_idx = SN_ATTR_IDX(sn_idx);
03042
03043 if (ATD_POINTER(attr_idx)) {
03044 NTR_IR_TBL(ir_idx);
03045 IR_OPR(ir_idx) = Struct_Opr;
03046 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
03047 IR_LINE_NUM(ir_idx) = line;
03048 IR_COL_NUM(ir_idx) = col;
03049 COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
03050 IR_FLD_R(ir_idx) = AT_Tbl_Idx;
03051 IR_IDX_R(ir_idx) = attr_idx;
03052 IR_LINE_NUM_R(ir_idx) = line;
03053 IR_COL_NUM_R(ir_idx) = col;
03054 OPND_FLD(opnd) = IR_Tbl_Idx;
03055 OPND_IDX(opnd) = ir_idx;
03056
03057 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
03058 IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
03059 }
03060
03061 (*func)(&opnd, attr_idx, position);
03062 }
03063 else if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) {
03064
03065 NTR_IR_TBL(ir_idx);
03066
03067 IR_OPR(ir_idx) = Struct_Opr;
03068 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
03069 IR_LINE_NUM(ir_idx) = line;
03070 IR_COL_NUM(ir_idx) = col;
03071
03072 COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
03073
03074 IR_FLD_R(ir_idx) = AT_Tbl_Idx;
03075 IR_IDX_R(ir_idx) = attr_idx;
03076 IR_LINE_NUM_R(ir_idx) = line;
03077 IR_COL_NUM_R(ir_idx) = col;
03078
03079 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
03080 IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
03081 }
03082
03083 gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, line, col);
03084
03085 if (opr == Asg_Opr) {
03086
03087 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
03088 exp_desc = init_exp_desc;
03089 gen_whole_subscript(&opnd, &exp_desc);
03090 }
03091 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
03092 gen_whole_substring(&opnd, 0);
03093 }
03094
03095 NTR_IR_TBL(init_idx);
03096
03097 IR_OPR(init_idx) = Asg_Opr;
03098 IR_LINE_NUM(init_idx) = line;
03099 IR_COL_NUM(init_idx) = col;
03100 IR_TYPE_IDX(init_idx) = ATD_TYPE_IDX(attr_idx);
03101 COPY_OPND(IR_OPND_L(init_idx), opnd);
03102 IR_LINE_NUM_L(init_idx)= line;
03103 IR_COL_NUM_L(init_idx) = col;
03104
03105
03106 IR_IDX_R(init_idx) = ATD_CPNT_INIT_IDX(attr_idx);
03107 IR_FLD_R(init_idx) = (fld_type) ATD_FLD(attr_idx);
03108 IR_LINE_NUM_R(init_idx) = line;
03109 IR_COL_NUM_R(init_idx) = col;
03110
03111 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03112
03113 if (position == After) {
03114 SH_IR_IDX(curr_stmt_sh_idx) = init_idx;
03115 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
03116 }
03117 else {
03118 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx;
03119 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03120 }
03121 }
03122 else {
03123
03124
03125 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
03126 NTR_IR_TBL(sub_idx);
03127 IR_OPR(sub_idx) = Subscript_Opr;
03128 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx);
03129 IR_LINE_NUM(sub_idx) = line;
03130 IR_COL_NUM(sub_idx) = col;
03131
03132 COPY_OPND(IR_OPND_L(sub_idx), opnd);
03133
03134 NTR_IR_LIST_TBL(list_idx);
03135 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
03136 IR_IDX_R(sub_idx) = list_idx;
03137 IR_LIST_CNT_R(sub_idx) = 1;
03138
03139 IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),1);
03140 IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),1);
03141 IL_LINE_NUM(list_idx) = line;
03142 IL_COL_NUM(list_idx) = col;
03143
03144 for (i = 2; i<= BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) {
03145 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03146 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03147 list_idx = IL_NEXT_LIST_IDX(list_idx);
03148
03149 IR_LIST_CNT_R(sub_idx) += 1;
03150
03151 IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),i);
03152 IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),i);
03153 IL_LINE_NUM(list_idx) = line;
03154 IL_COL_NUM(list_idx) = col;
03155 }
03156
03157 gen_opnd(&opnd, sub_idx, IR_Tbl_Idx, line, col);
03158 }
03159
03160 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
03161 gen_whole_substring(&opnd, 0);
03162 }
03163
03164 if (ATD_FLD(attr_idx) != CN_Tbl_Idx) {
03165
03166 gen_opnd(&tmp_opnd, ATD_CPNT_INIT_IDX(attr_idx),
03167 (fld_type) ATD_FLD(attr_idx), line, col);
03168
03169 tmp_idx = find_left_attr(&tmp_opnd);
03170
03171 if (ATD_FLD(tmp_idx) == CN_Tbl_Idx) {
03172 const_idx = ATD_TMP_IDX(tmp_idx);
03173 }
03174 else if (ATD_FLD(tmp_idx) == IR_Tbl_Idx &&
03175 IR_OPR(ATD_TMP_IDX(tmp_idx)) == Mult_Opr) {
03176
03177
03178
03179
03180 const_idx = IR_IDX_R(ATD_TMP_IDX(tmp_idx));
03181
03182 save_target_array_idx = target_array_idx;
03183 target_array_idx = ATD_ARRAY_IDX(attr_idx);
03184
03185 exp_desc = init_exp_desc;
03186 exp_desc.type_idx = CN_TYPE_IDX(const_idx);
03187 exp_desc.type = TYP_TYPE(exp_desc.type_idx);
03188 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
03189 exp_desc.constant = TRUE;
03190 exp_desc.foldable = TRUE;
03191
03192 gen_opnd(&cn_opnd, const_idx, CN_Tbl_Idx, line, col);
03193 fold_aggragate_expression(&cn_opnd,
03194 &exp_desc,
03195 TRUE);
03196 target_array_idx = save_target_array_idx;
03197
03198 const_idx = OPND_IDX(cn_opnd);
03199 }
03200 }
03201 else {
03202 const_idx = ATD_CPNT_INIT_IDX(attr_idx);
03203 }
03204
03205 gen_init_stmt(&opnd,
03206 const_idx,
03207 position);
03208 }
03209 }
03210 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
03211 (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
03212 ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))))) {
03213
03214 NTR_IR_TBL(ir_idx);
03215 IR_OPR(ir_idx) = Struct_Opr;
03216 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
03217 IR_LINE_NUM(ir_idx) = line;
03218 IR_COL_NUM(ir_idx) = col;
03219 COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
03220 IR_FLD_R(ir_idx) = AT_Tbl_Idx;
03221 IR_IDX_R(ir_idx) = attr_idx;
03222 IR_LINE_NUM_R(ir_idx) = line;
03223 IR_COL_NUM_R(ir_idx) = col;
03224 OPND_FLD(opnd) = IR_Tbl_Idx;
03225 OPND_IDX(opnd) = ir_idx;
03226
03227 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
03228 IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
03229 }
03230
03231 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
03232 exp_desc = init_exp_desc;
03233 gen_whole_subscript(&opnd, &exp_desc);
03234 }
03235
03236 process_cpnt_inits(&opnd,
03237 TYP_IDX(ATD_TYPE_IDX(attr_idx)),
03238 func,
03239 opr,
03240 position);
03241
03242 }
03243
03244 sn_idx = SN_SIBLING_LINK(sn_idx);
03245 }
03246
03247
03248
03249 if (placeholder_sh_idx != NULL_IDX) {
03250 remove_sh(placeholder_sh_idx);
03251 FREE_SH_NODE(placeholder_sh_idx);
03252 }
03253
03254 if (position == Before) {
03255 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
03256 }
03257 else {
03258 if (save_curr_stmt_sh_idx != NULL_IDX) {
03259 curr_stmt_sh_idx = SH_PREV_IDX(save_curr_stmt_sh_idx);
03260 }
03261 else {
03262
03263 while (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) {
03264 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
03265 }
03266 }
03267 }
03268
03269 TRACE (Func_Exit, "process_cpnt_inits", NULL);
03270
03271 return;
03272
03273 }
03274
03275
03276
03277
03278
03279
03280
03281
03282
03283
03284
03285
03286
03287
03288
03289
03290
03291 static void gen_init_stmt(opnd_type *left_opnd,
03292 int const_idx,
03293 sh_position_type position)
03294
03295 {
03296 int array_attr_idx;
03297 opnd_type base_opnd;
03298 int bd_idx;
03299 int col;
03300 long64 count = 0;
03301 int init_idx;
03302 int line;
03303 int list_idx;
03304 int mult_idx;
03305 int num_loops = 0;
03306 opnd_type opnd;
03307 int rank_idx = NULL_IDX;
03308 long_type result[MAX_WORDS_FOR_INTEGER];
03309 long64 sm_bits;
03310 int type_idx;
03311 int unused = NULL_IDX;
03312 int unused2;
03313 long_type the_constant[MAX_WORDS_FOR_INTEGER];
03314
03315
03316 TRACE (Func_Entry, "gen_init_stmt", NULL);
03317
03318 find_opnd_line_and_column(left_opnd, &line, &col);
03319
03320 NTR_IR_TBL(init_idx);
03321 IR_OPR(init_idx) = Init_Opr;
03322 IR_TYPE_IDX(init_idx) = TYPELESS_DEFAULT_TYPE;
03323 IR_LINE_NUM(init_idx) = line;
03324 IR_COL_NUM(init_idx) = col;
03325
03326 COPY_OPND(IR_OPND_L(init_idx), (*left_opnd));
03327
03328 COPY_OPND(opnd, (*left_opnd));
03329 while (OPND_FLD(opnd) == IR_Tbl_Idx) {
03330 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
03331 num_loops++;
03332 }
03333 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
03334 }
03335
03336 if (num_loops > 0) {
03337
03338 if (num_loops == 1) {
03339
03340 COPY_OPND(opnd, (*left_opnd));
03341 make_base_subtree(&opnd, &base_opnd, &rank_idx, &unused);
03342
03343 # ifdef _DEBUG
03344 if (rank_idx == NULL_IDX) {
03345 PRINTMSG(line, 626, Internal, col,
03346 "whole array subscript",
03347 "gen_init_stmt");
03348 }
03349 # endif
03350 array_attr_idx = find_base_attr(&IR_OPND_L(rank_idx),
03351 &unused,
03352 &unused2);
03353
03354 bd_idx = ATD_ARRAY_IDX(array_attr_idx);
03355
03356 COPY_OPND(IR_OPND_L(init_idx), base_opnd);
03357
03358 NTR_IR_LIST_TBL(list_idx);
03359 IR_FLD_R(init_idx) = IL_Tbl_Idx;
03360 IR_IDX_R(init_idx) = list_idx;
03361 IR_LIST_CNT_R(init_idx) = 3;
03362
03363
03364
03365 IL_FLD(list_idx) = CN_Tbl_Idx;
03366 IL_IDX(list_idx) = const_idx;
03367 IL_LINE_NUM(list_idx) = line;
03368 IL_COL_NUM(list_idx) = col;
03369
03370
03371
03372 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03373 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03374 list_idx = IL_NEXT_LIST_IDX(list_idx);
03375
03376 # ifdef _DEBUG
03377 if (BD_LEN_FLD(bd_idx) != CN_Tbl_Idx) {
03378 PRINTMSG(line, 626, Internal, col,
03379 "constant array length",
03380 "gen_init_stmt");
03381 }
03382 # endif
03383 IL_FLD(list_idx) = CN_Tbl_Idx;
03384 IL_IDX(list_idx) = BD_LEN_IDX(bd_idx);
03385 IL_LINE_NUM(list_idx) = line;
03386 IL_COL_NUM(list_idx) = col;
03387
03388
03389
03390 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03391 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03392 list_idx = IL_NEXT_LIST_IDX(list_idx);
03393
03394 # ifdef _SM_UNIT_IS_ELEMENT
03395 sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx));
03396 C_TO_F_INT(the_constant, sm_bits, Integer_8);
03397 # else
03398 if (TYP_TYPE(ATD_TYPE_IDX(array_attr_idx)) == Structure &&
03399 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(array_attr_idx)))) {
03400 C_TO_F_INT(the_constant, 8, CG_INTEGER_DEFAULT_TYPE);
03401 }
03402 else {
03403 sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx));
03404 C_TO_F_INT(the_constant, sm_bits, Integer_8);
03405 }
03406 # endif
03407
03408 type_idx = (CG_INTEGER_DEFAULT_TYPE >
03409 TYP_LINEAR(CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1))) ?
03410 CG_INTEGER_DEFAULT_TYPE :
03411 CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1)));
03412
03413
03414 if (folder_driver((char *)&CN_CONST(BD_SM_IDX(bd_idx, 1)),
03415 CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1)),
03416 (char *) the_constant,
03417 CG_INTEGER_DEFAULT_TYPE,
03418 result,
03419 &type_idx,
03420 line,
03421 col,
03422 2,
03423 Mult_Opr)) {
03424
03425 IL_FLD(list_idx) = CN_Tbl_Idx;
03426 IL_IDX(list_idx) = ntr_const_tbl(type_idx,
03427 FALSE,
03428 result);
03429 IL_LINE_NUM(list_idx) = line;
03430 IL_COL_NUM(list_idx) = col;
03431 }
03432 }
03433 else {
03434
03435
03436 copy_subtree(left_opnd, &opnd);
03437 count = create_imp_do_loops(&opnd);
03438 COPY_OPND(IR_OPND_L(init_idx), opnd);
03439
03440 NTR_IR_LIST_TBL(list_idx);
03441 IR_FLD_R(init_idx) = IL_Tbl_Idx;
03442 IR_IDX_R(init_idx) = list_idx;
03443 IR_LIST_CNT_R(init_idx) = 1;
03444
03445 NTR_IR_TBL(mult_idx);
03446 IR_OPR(mult_idx) = Mult_Opr;
03447 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
03448 IR_LINE_NUM(mult_idx) = line;
03449 IR_COL_NUM(mult_idx) = col;
03450 IR_FLD_L(mult_idx) = CN_Tbl_Idx;
03451 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, count);
03452
03453 IR_LINE_NUM_L(mult_idx) = line;
03454 IR_COL_NUM_L(mult_idx) = col;
03455 IR_FLD_R(mult_idx) = CN_Tbl_Idx;
03456 IR_IDX_R(mult_idx) = const_idx;
03457 IR_LINE_NUM_R(mult_idx) = line;
03458 IR_COL_NUM_R(mult_idx) = col;
03459
03460 IL_FLD(list_idx) = IR_Tbl_Idx;
03461 IL_IDX(list_idx) = mult_idx;
03462 }
03463 }
03464 else {
03465
03466 NTR_IR_LIST_TBL(list_idx);
03467 IR_FLD_R(init_idx) = IL_Tbl_Idx;
03468 IR_IDX_R(init_idx) = list_idx;
03469 IR_LIST_CNT_R(init_idx) = 3;
03470
03471 IL_FLD(list_idx) = CN_Tbl_Idx;
03472 IL_IDX(list_idx) = const_idx;
03473 IL_LINE_NUM(list_idx) = line;
03474 IL_COL_NUM(list_idx) = col;
03475
03476 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03477 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03478 list_idx = IL_NEXT_LIST_IDX(list_idx);
03479
03480 IL_FLD(list_idx) = CN_Tbl_Idx;
03481 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
03482 IL_LINE_NUM(list_idx) = line;
03483 IL_COL_NUM(list_idx) = col;
03484
03485 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03486 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03487 list_idx = IL_NEXT_LIST_IDX(list_idx);
03488
03489 IL_FLD(list_idx) = CN_Tbl_Idx;
03490 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03491 IL_LINE_NUM(list_idx) = line;
03492 IL_COL_NUM(list_idx) = col;
03493 }
03494
03495 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03496
03497 if (position == After) {
03498 SH_IR_IDX(curr_stmt_sh_idx) = init_idx;
03499 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
03500 }
03501 else {
03502 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx;
03503 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03504 }
03505
03506
03507 TRACE (Func_Exit, "gen_init_stmt", NULL);
03508
03509 return;
03510
03511 }
03512
03513
03514
03515
03516
03517
03518
03519
03520
03521
03522
03523
03524
03525
03526
03527
03528
03529 void gen_dv_whole_def(opnd_type *dv_opnd,
03530 opnd_type *r_opnd,
03531 expr_arg_type *exp_desc)
03532
03533 {
03534 act_arg_type a_type;
03535 int asg_idx;
03536 int attr_idx;
03537 opnd_type base_opnd;
03538 int col;
03539 int dim = 1;
03540 int dope_idx = NULL_IDX;
03541 int dv_attr_idx;
03542 int dv2_idx;
03543 int i;
03544 int ir_idx;
03545 opnd_type len_opnd;
03546 int line;
03547 int list_idx;
03548 int list2_idx;
03549 int loc_idx;
03550 int max_idx;
03551 int mult_idx;
03552 opnd_type opnd;
03553 long rank;
03554 int rank_idx = NULL_IDX;
03555 opnd_type r_dv_opnd;
03556 int stride_idx;
03557 opnd_type stride_opnd;
03558 int subscript_idx;
03559 int type_idx;
03560 boolean whole_array;
03561
03562
03563 TRACE (Func_Entry, "gen_dv_whole_def", NULL);
03564
03565 dv_attr_idx = find_base_attr(dv_opnd, &line, &col);
03566
03567 NTR_IR_TBL(asg_idx);
03568 IR_OPR(asg_idx) = Dv_Def_Asg_Opr;
03569 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
03570 IR_LINE_NUM(asg_idx) = line;
03571 IR_COL_NUM(asg_idx) = col;
03572
03573 NTR_IR_TBL(ir_idx);
03574 IR_OPR(ir_idx) = Dv_Whole_Def_Opr;
03575 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
03576 IR_LINE_NUM(ir_idx) = line;
03577 IR_COL_NUM(ir_idx) = col;
03578
03579 COPY_OPND(IR_OPND_L(asg_idx), (*dv_opnd));
03580 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
03581 IR_IDX_R(asg_idx) = ir_idx;
03582
03583 NTR_IR_LIST_TBL(list_idx);
03584 IR_FLD_L(ir_idx) = IL_Tbl_Idx;
03585 IR_IDX_L(ir_idx) = list_idx;
03586
03587 rank = (ATD_ARRAY_IDX(dv_attr_idx) ?
03588 (long) BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0);
03589 IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank);
03590 IR_DV_DIM(ir_idx) = rank;
03591
03592
03593
03594
03595
03596 NTR_IR_TBL(loc_idx);
03597 IR_OPR(loc_idx) = Loc_Opr;
03598 IR_LINE_NUM(loc_idx) = line;
03599 IR_COL_NUM(loc_idx) = col;
03600
03601 if (exp_desc->type == Character) {
03602 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
03603 }
03604 else {
03605 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
03606 }
03607
03608 IL_FLD(list_idx) = IR_Tbl_Idx;
03609 IL_IDX(list_idx) = loc_idx;
03610
03611 if (exp_desc->rank == 0) {
03612 COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd));
03613 just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
03614 }
03615 else {
03616 make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx);
03617 COPY_OPND(IR_OPND_L(loc_idx), base_opnd);
03618 }
03619
03620 # ifdef _TRANSFORM_CHAR_SEQUENCE
03621 # ifdef _TARGET_OS_UNICOS
03622 if (exp_desc->type == Structure &&
03623 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
03624
03625 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
03626 COPY_OPND(opnd, IR_OPND_L(loc_idx));
03627 transform_char_sequence_ref(&opnd, exp_desc->type_idx);
03628 COPY_OPND(IR_OPND_L(loc_idx), opnd);
03629 }
03630 # endif
03631 # endif
03632
03633
03634
03635
03636
03637
03638 if (rank_idx != NULL_IDX) {
03639 attr_idx = find_base_attr(&IR_OPND_L(rank_idx), &line, &col);
03640
03641 if (ATD_IM_A_DOPE(attr_idx)) {
03642 COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx)));
03643 }
03644 subscript_idx = IR_IDX_R(rank_idx);
03645 }
03646 else if (exp_desc->rank != 0) {
03647 attr_idx = find_base_attr(r_opnd, &line, &col);
03648
03649 if (ATD_IM_A_DOPE(attr_idx)) {
03650 COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd))));
03651 }
03652 }
03653 else {
03654 find_opnd_line_and_column(r_opnd, &line, &col);
03655 }
03656
03657 if (exp_desc->rank > 0 &&
03658 ! exp_desc->section) {
03659
03660 whole_array = TRUE;
03661 }
03662 else {
03663 whole_array = FALSE;
03664 }
03665
03666
03667
03668
03669
03670 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03671 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03672 list_idx = IL_NEXT_LIST_IDX(list_idx);
03673 type_idx = ATD_TYPE_IDX(dv_attr_idx);
03674
03675 if (TYP_TYPE(type_idx) == Structure) {
03676 IL_FLD(list_idx) = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
03677 IL_IDX(list_idx) = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
03678 IL_LINE_NUM(list_idx) = line;
03679 IL_COL_NUM(list_idx) = col;
03680 }
03681 else if (TYP_TYPE(type_idx) == Character) {
03682
03683 COPY_OPND(opnd, exp_desc->char_len);
03684 OPND_LINE_NUM(opnd) = line;
03685 OPND_COL_NUM(opnd) = col;
03686 compute_char_element_len(&opnd, r_opnd, &len_opnd);
03687
03688 COPY_OPND(IL_OPND(list_idx), len_opnd);
03689 IL_LINE_NUM(list_idx) = line;
03690 IL_COL_NUM(list_idx) = col;
03691 }
03692 else {
03693 IL_FLD(list_idx) = CN_Tbl_Idx;
03694 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
03695 storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
03696 IL_LINE_NUM(list_idx) = line;
03697 IL_COL_NUM(list_idx) = col;
03698 }
03699
03700
03701
03702
03703
03704 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03705 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03706 list_idx = IL_NEXT_LIST_IDX(list_idx);
03707
03708 IL_FLD(list_idx) = CN_Tbl_Idx;
03709 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
03710 IL_LINE_NUM(list_idx) = line;
03711 IL_COL_NUM(list_idx) = col;
03712
03713
03714
03715
03716
03717 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03718 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03719 list_idx = IL_NEXT_LIST_IDX(list_idx);
03720
03721 if (dope_idx != NULL_IDX) {
03722
03723 NTR_IR_TBL(dv2_idx);
03724 IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc;
03725 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE;
03726 IR_LINE_NUM(dv2_idx) = line;
03727 IR_COL_NUM(dv2_idx) = col;
03728 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
03729 IL_FLD(list_idx) = IR_Tbl_Idx;
03730 IL_IDX(list_idx) = dv2_idx;
03731 }
03732 else {
03733 IL_FLD(list_idx) = CN_Tbl_Idx;
03734 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03735 IL_LINE_NUM(list_idx) = line;
03736 IL_COL_NUM(list_idx) = col;
03737 }
03738
03739
03740
03741
03742
03743
03744 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03745 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03746 list_idx = IL_NEXT_LIST_IDX(list_idx);
03747
03748 IL_FLD(list_idx) = CN_Tbl_Idx;
03749
03750 if (ATD_ALLOCATABLE(dv_attr_idx)) {
03751 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2);
03752 }
03753 else if (ATD_POINTER(dv_attr_idx)) {
03754 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
03755 }
03756 else {
03757 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03758 }
03759 IL_LINE_NUM(list_idx) = line;
03760 IL_COL_NUM(list_idx) = col;
03761
03762
03763
03764
03765
03766
03767
03768 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03769 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03770 list_idx = IL_NEXT_LIST_IDX(list_idx);
03771
03772 a_type = get_act_arg_type(exp_desc);
03773
03774 if (a_type == Array_Ptr ||
03775 a_type == Array_Tmp_Ptr ||
03776 a_type == Whole_Ass_Shape ||
03777 a_type == Dv_Contig_Section) {
03778
03779 NTR_IR_TBL(dv2_idx);
03780 IR_OPR(dv2_idx) = Dv_Access_A_Contig;
03781 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE;
03782 IR_LINE_NUM(dv2_idx) = line;
03783 IR_COL_NUM(dv2_idx) = col;
03784 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
03785 IL_FLD(list_idx) = IR_Tbl_Idx;
03786 IL_IDX(list_idx) = dv2_idx;
03787
03788 }
03789 else if (a_type == Whole_Allocatable ||
03790 a_type == Whole_Tmp_Allocatable ||
03791 a_type == Whole_Sequence ||
03792 a_type == Whole_Tmp_Sequence ||
03793 a_type == Whole_Array_Constant ||
03794 a_type == Contig_Section) {
03795
03796 IL_FLD(list_idx) = CN_Tbl_Idx;
03797 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
03798 IL_LINE_NUM(list_idx) = line;
03799 IL_COL_NUM(list_idx) = col;
03800 }
03801 else {
03802 IL_FLD(list_idx) = CN_Tbl_Idx;
03803 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03804 IL_LINE_NUM(list_idx) = line;
03805 IL_COL_NUM(list_idx) = col;
03806 }
03807
03808
03809
03810
03811
03812
03813 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03814 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03815 list_idx = IL_NEXT_LIST_IDX(list_idx);
03816
03817 IL_FLD(list_idx) = CN_Tbl_Idx;
03818 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank);
03819 IL_LINE_NUM(list_idx) = line;
03820 IL_COL_NUM(list_idx) = col;
03821
03822
03823
03824
03825
03826
03827 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03828 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03829 list_idx = IL_NEXT_LIST_IDX(list_idx);
03830
03831 IL_FLD(list_idx) = CN_Tbl_Idx;
03832 IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx);
03833 IL_LINE_NUM(list_idx) = line;
03834 IL_COL_NUM(list_idx) = col;
03835
03836
03837
03838
03839
03840 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03841 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03842 list_idx = IL_NEXT_LIST_IDX(list_idx);
03843
03844 if (dope_idx != NULL_IDX) {
03845
03846 NTR_IR_TBL(dv2_idx);
03847 IR_OPR(dv2_idx) = Dv_Access_Orig_Base;
03848 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
03849 IR_LINE_NUM(dv2_idx) = line;
03850 IR_COL_NUM(dv2_idx) = col;
03851 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
03852 IL_FLD(list_idx) = IR_Tbl_Idx;
03853 IL_IDX(list_idx) = dv2_idx;
03854 }
03855 else {
03856 IL_FLD(list_idx) = CN_Tbl_Idx;
03857 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03858 IL_LINE_NUM(list_idx) = line;
03859 IL_COL_NUM(list_idx) = col;
03860 }
03861
03862
03863
03864
03865
03866
03867 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03868 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03869 list_idx = IL_NEXT_LIST_IDX(list_idx);
03870
03871 if (dope_idx != NULL_IDX) {
03872
03873 NTR_IR_TBL(dv2_idx);
03874 IR_OPR(dv2_idx) = Dv_Access_Orig_Size;
03875 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
03876 IR_LINE_NUM(dv2_idx) = line;
03877 IR_COL_NUM(dv2_idx) = col;
03878 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
03879 IL_FLD(list_idx) = IR_Tbl_Idx;
03880 IL_IDX(list_idx) = dv2_idx;
03881 }