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
00038
00039
00040
00041
00042
00043
00044
00045 static char USMID[] = "\n@(#)5.0_pl/sources/s_io.c 5.8 10/04/99 17:44:33\n";
00046
00047 # include "defines.h"
00048
00049 # include "host.m"
00050 # include "host.h"
00051 # include "target.m"
00052 # include "target.h"
00053
00054 # include "globals.m"
00055 # include "tokens.m"
00056 # include "sytb.m"
00057 # include "s_globals.m"
00058 # include "debug.m"
00059 # include "p_io.m"
00060
00061 # include "globals.h"
00062 # include "tokens.h"
00063 # include "sytb.h"
00064 # include "s_globals.h"
00065 # include "s_io.h"
00066
00067
00068
00069
00070
00071
00072 static boolean io_ctl_list_semantics(opnd_type *, io_stmt_type, boolean);
00073 static boolean io_list_semantics(opnd_type *, io_stmt_type);
00074 static void namelist_static_dv_whole_def(opnd_type *, opnd_type *);
00075 static void put_string_in_tmp(char *, int, opnd_type *);
00076
00077 # ifdef _INIT_RELOC_BASE_OFFSET
00078 static int change_to_base_and_offset(opnd_type *, opnd_type *);
00079 # endif
00080 static int create_scalar_type_tbl(opnd_type *, boolean);
00081 static int create_strct_tbl(opnd_type *, boolean);
00082 static boolean do_read_namelist_semantics(opnd_type *);
00083 static void do_write_namelist_semantics(opnd_type *);
00084 static int discombobulate_structure_ref(opnd_type *, int, int *);
00085 static int change_section_to_do(int *);
00086 static void process_deferred_io_list(void);
00087 static void expand_io_list(void);
00088 static void expand_imp_do(int, int);
00089 static int copy_text_for_expansion(int);
00090 static void create_io_call_descriptor(int, io_descriptor_type);
00091 # ifdef _NO_IO_ALTERNATE_RETURN
00092 static void add_alt_return_lbl(int, int);
00093 # endif
00094 static boolean item_has_bounds_chk(opnd_type *);
00095 static void gen_array_element_init(int, long_type *, opnd_type *, int, int);
00096
00097 static int err_attr_idx;
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116 void backspace_stmt_semantics (void)
00117
00118 {
00119 # ifndef _NO_IO_ALTERNATE_RETURN
00120 int alt_return_tmp;
00121 int asg_idx;
00122 int br_true_idx;
00123 int col;
00124 int eq_idx;
00125 int line;
00126 int save_next_sh_idx;
00127 # endif
00128
00129 int ir_idx;
00130 opnd_type opnd;
00131 int save_arg_info_list_base;
00132 int save_curr_stmt_sh_idx;
00133 boolean semantically_correct;
00134
00135
00136 TRACE (Func_Entry, "backspace_stmt_semantics", NULL);
00137
00138 SCP_DOES_IO(curr_scp_idx) = TRUE;
00139
00140 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00141
00142
00143
00144 if (max_call_list_size >= arg_list_size) {
00145 enlarge_call_list_tables();
00146 }
00147
00148 save_arg_info_list_base = arg_info_list_base;
00149
00150 arg_info_list_base = arg_info_list_top;
00151
00152 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
00153
00154 if (arg_info_list_top >= arg_info_list_size) {
00155 enlarge_info_list_table();
00156 }
00157
00158 # ifndef _NO_IO_ALTERNATE_RETURN
00159 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
00160 # endif
00161
00162 COPY_OPND(opnd, IR_OPND_R(ir_idx));
00163 semantically_correct = io_ctl_list_semantics(&opnd, Backspace, TRUE);
00164 COPY_OPND(IR_OPND_R(ir_idx), opnd);
00165
00166 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00167
00168 # ifndef _NO_IO_ALTERNATE_RETURN
00169 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
00170
00171 line = IR_LINE_NUM(ir_idx);
00172 col = IR_COL_NUM(ir_idx);
00173
00174 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
00175 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
00176 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
00177 AT_REFERENCED(alt_return_tmp) = Referenced;
00178 AT_DEFINED(alt_return_tmp) = TRUE;
00179 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
00180
00181 NTR_IR_TBL(asg_idx);
00182 IR_OPR(asg_idx) = Alt_Return_Opr;
00183 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
00184 IR_LINE_NUM(asg_idx) = line;
00185 IR_COL_NUM(asg_idx) = col;
00186 IR_LINE_NUM_L(asg_idx) = line;
00187 IR_COL_NUM_L(asg_idx) = col;
00188 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
00189 IR_IDX_L(asg_idx) = alt_return_tmp;
00190 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
00191 IR_IDX_R(asg_idx) = ir_idx;
00192
00193 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
00194
00195 if (err_list_idx) {
00196 NTR_IR_TBL(br_true_idx);
00197 IR_OPR(br_true_idx) = Br_True_Opr;
00198 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
00199 IR_LINE_NUM(br_true_idx) = line;
00200 IR_COL_NUM(br_true_idx) = col;
00201
00202 NTR_IR_TBL(eq_idx);
00203 IR_OPR(eq_idx) = Eq_Opr;
00204 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE;
00205 IR_LINE_NUM(eq_idx) = line;
00206 IR_COL_NUM(eq_idx) = col;
00207 IR_FLD_L(eq_idx) = AT_Tbl_Idx;
00208 IR_IDX_L(eq_idx) = alt_return_tmp;
00209 IR_LINE_NUM_L(eq_idx) = line;
00210 IR_COL_NUM_L(eq_idx) = col;
00211
00212 IR_FLD_R(eq_idx) = CN_Tbl_Idx;
00213 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX;
00214 IR_LINE_NUM_R(eq_idx) = line;
00215 IR_COL_NUM_R(eq_idx) = col;
00216
00217 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
00218 IR_IDX_L(br_true_idx) = eq_idx;
00219
00220 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
00221
00222 curr_stmt_sh_idx = save_next_sh_idx;
00223
00224 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
00225
00226 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx;
00227 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
00228
00229 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00230 }
00231 }
00232 # endif
00233
00234 if (semantically_correct) {
00235 COPY_OPND(opnd, IR_OPND_R(ir_idx));
00236 semantically_correct = final_arg_work(&opnd,
00237 IR_IDX_L(ir_idx),
00238 IR_LIST_CNT_R(ir_idx),
00239 NULL);
00240 COPY_OPND(IR_OPND_R(ir_idx), opnd);
00241
00242 # if defined(_FILE_IO_OPRS)
00243 IR_OPR(ir_idx) = Backspace_Opr;
00244 # endif
00245 }
00246
00247 # ifdef _NO_IO_ALTERNATE_RETURN
00248 add_alt_return_lbl(ir_idx, err_attr_idx);
00249 # endif
00250
00251
00252
00253 arg_info_list_top = arg_info_list_base;
00254 arg_info_list_base = save_arg_info_list_base;
00255
00256 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00257
00258 TRACE (Func_Exit, "backspace_stmt_semantics", NULL);
00259
00260 return;
00261
00262 }
00263
00264
00265
00266
00267
00268
00269
00270
00271
00272
00273
00274
00275
00276
00277
00278
00279
00280
00281 void buffer_stmt_semantics (void)
00282
00283 {
00284 int base_attr;
00285 boolean buffer_in;
00286 int col;
00287 expr_arg_type exp_desc;
00288 expr_arg_type exp_desc2;
00289 int info_idx;
00290 int ir_idx;
00291 int line;
00292 int list_idx;
00293 opnd_type opnd;
00294 int save_arg_info_list_base;
00295 boolean semantically_correct;
00296 long_type the_constant[2];
00297 int type_idx;
00298
00299
00300 TRACE (Func_Entry, "buffer_stmt_semantics", NULL);
00301
00302 SCP_DOES_IO(curr_scp_idx) = TRUE;
00303
00304 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00305
00306
00307
00308 if (max_call_list_size >= arg_list_size) {
00309 enlarge_call_list_tables();
00310 }
00311
00312 save_arg_info_list_base = arg_info_list_base;
00313
00314 arg_info_list_base = arg_info_list_top;
00315
00316 arg_info_list_top = arg_info_list_base + 5;
00317
00318 if (arg_info_list_top >= arg_info_list_size) {
00319 enlarge_info_list_table();
00320 }
00321
00322 info_idx = arg_info_list_base;
00323
00324 if (IR_IDX_L(ir_idx) == glb_tbl_idx[Buffer_In_Attr_Idx]) {
00325 buffer_in = TRUE;
00326 }
00327 else {
00328 buffer_in = FALSE;
00329 }
00330
00331
00332
00333 list_idx = IR_IDX_R(ir_idx);
00334 COPY_OPND(opnd, IL_OPND(list_idx));
00335 exp_desc.rank = 0;
00336 xref_state = CIF_Symbol_Reference;
00337 semantically_correct = expr_semantics(&opnd, &exp_desc);
00338 COPY_OPND(IL_OPND(list_idx), opnd);
00339 find_opnd_line_and_column(&opnd, &line, &col);
00340
00341 if (exp_desc.linear_type == Long_Typeless) {
00342 PRINTMSG(line, 1133, Error, col);
00343 semantically_correct = FALSE;
00344 }
00345 else if (exp_desc.type != Integer &&
00346 exp_desc.type != Typeless &&
00347 exp_desc.type != Character) {
00348
00349
00350
00351 PRINTMSG(line, 229, Error, col);
00352 semantically_correct = FALSE;
00353 }
00354 else if (exp_desc.type != Character &&
00355 exp_desc.rank != 0) {
00356
00357
00358
00359 PRINTMSG(line, 229, Error, col);
00360 semantically_correct = FALSE;
00361 }
00362 else if (exp_desc.type == Character &&
00363 exp_desc.constant) {
00364
00365
00366
00367 if (compare_cn_and_value(TYP_IDX(CN_TYPE_IDX(OPND_IDX(opnd))),
00368 TARGET_BYTES_PER_WORD,
00369 Lt_Opr)) {
00370 CN_TYPE_IDX(OPND_IDX(opnd)) = TYPELESS_DEFAULT_TYPE;
00371 }
00372 else {
00373 PRINTMSG(line, 231, Error, col,
00374 TARGET_BYTES_PER_WORD - 1);
00375 semantically_correct = FALSE;
00376 }
00377 }
00378 else if (exp_desc.linear_type == Short_Typeless_Const) {
00379 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
00380 CG_INTEGER_DEFAULT_TYPE,
00381 line,
00382 col);
00383 exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
00384 exp_desc.type_idx = INTEGER_DEFAULT_TYPE;
00385 exp_desc.type = Integer;
00386 }
00387
00388 COPY_OPND(opnd, IL_OPND(list_idx));
00389 cast_to_cg_default(&opnd, &exp_desc);
00390 COPY_OPND(IL_OPND(list_idx), opnd);
00391
00392 info_idx++;
00393 arg_info_list[info_idx] = init_arg_info;
00394 arg_info_list[info_idx].ed = exp_desc;
00395 arg_info_list[info_idx].maybe_modified = TRUE;
00396 IL_ARG_DESC_IDX(list_idx) = info_idx;
00397
00398
00399
00400 list_idx = IL_NEXT_LIST_IDX(list_idx);
00401 COPY_OPND(opnd, IL_OPND(list_idx));
00402 exp_desc.rank = 0;
00403 xref_state = CIF_Symbol_Reference;
00404 semantically_correct = expr_semantics(&opnd, &exp_desc) &&
00405 semantically_correct;
00406 COPY_OPND(IL_OPND(list_idx), opnd);
00407
00408 if (exp_desc.type != Integer) {
00409
00410
00411
00412 find_opnd_line_and_column(&opnd, &line, &col);
00413 PRINTMSG(line, 228, Error, col);
00414 semantically_correct = FALSE;
00415 }
00416
00417 if (exp_desc.rank != 0) {
00418 find_opnd_line_and_column(&opnd, &line, &col);
00419 PRINTMSG(line, 230, Error, col);
00420 semantically_correct = FALSE;
00421 }
00422
00423 COPY_OPND(opnd, IL_OPND(list_idx));
00424 cast_to_cg_default(&opnd, &exp_desc);
00425 COPY_OPND(IL_OPND(list_idx), opnd);
00426
00427 info_idx++;
00428 arg_info_list[info_idx] = init_arg_info;
00429 arg_info_list[info_idx].ed = exp_desc;
00430 arg_info_list[info_idx].maybe_modified = TRUE;
00431 IL_ARG_DESC_IDX(list_idx) = info_idx;
00432
00433
00434
00435 list_idx = IL_NEXT_LIST_IDX(list_idx);
00436
00437 COPY_OPND(opnd, IL_OPND(list_idx));
00438 exp_desc.rank = 0;
00439
00440 if (buffer_in) {
00441 xref_state = CIF_Symbol_Modification;
00442 }
00443 else {
00444 xref_state = CIF_Symbol_Reference;
00445 }
00446 semantically_correct = expr_semantics(&opnd, &exp_desc) &&
00447 semantically_correct;
00448 COPY_OPND(IL_OPND(list_idx), opnd);
00449
00450 base_attr = find_base_attr(&opnd, &line, &col);
00451
00452 info_idx++;
00453 arg_info_list[info_idx] = init_arg_info;
00454 arg_info_list[info_idx].ed = exp_desc;
00455 arg_info_list[info_idx].maybe_modified = TRUE;
00456 IL_ARG_DESC_IDX(list_idx) = info_idx;
00457
00458 list_idx = IL_NEXT_LIST_IDX(list_idx);
00459
00460
00461
00462 COPY_OPND(opnd, IL_OPND(list_idx));
00463 exp_desc.rank = 0;
00464
00465 if (buffer_in) {
00466 xref_state = CIF_Symbol_Modification;
00467 }
00468 else {
00469 xref_state = CIF_Symbol_Reference;
00470 }
00471 semantically_correct = expr_semantics(&opnd, &exp_desc2) &&
00472 semantically_correct;
00473 COPY_OPND(IL_OPND(list_idx), opnd);
00474
00475 if (exp_desc.type == Structure) {
00476 find_opnd_line_and_column(&opnd, &line, &col);
00477 PRINTMSG(line, 879, Error, col);
00478 semantically_correct = FALSE;
00479 }
00480 else if ((exp_desc.type == Character &&
00481 exp_desc2.type != Character) ||
00482 (exp_desc2.type == Character &&
00483 exp_desc.type != Character)) {
00484
00485 find_opnd_line_and_column(&opnd, &line, &col);
00486 PRINTMSG(line, 896, Error, col);
00487 semantically_correct = FALSE;
00488 }
00489 else if (exp_desc.type != Character &&
00490 exp_desc2.type != Character &&
00491 storage_bit_size_tbl[exp_desc.linear_type] !=
00492 storage_bit_size_tbl[exp_desc2.linear_type]) {
00493
00494 find_opnd_line_and_column(&opnd, &line, &col);
00495 PRINTMSG(line, 896, Error, col);
00496 semantically_correct = FALSE;
00497 }
00498
00499 info_idx++;
00500 arg_info_list[info_idx] = init_arg_info;
00501 arg_info_list[info_idx].ed = exp_desc2;
00502 arg_info_list[info_idx].maybe_modified = TRUE;
00503 IL_ARG_DESC_IDX(list_idx) = info_idx;
00504
00505
00506
00507 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00508 list_idx = IL_NEXT_LIST_IDX(list_idx);
00509 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00510 IR_LIST_CNT_R(ir_idx) = 5;
00511
00512 make_io_type_code(ATD_TYPE_IDX(base_attr), the_constant);
00513 IL_FLD(list_idx) = CN_Tbl_Idx;
00514
00515 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN)) && ! defined(_TYPE_CODE_64_BIT)
00516
00517 the_constant[1] = the_constant[0];
00518 the_constant[0] = 0;
00519 type_idx = Integer_8;
00520 # else
00521 type_idx = IO_TYPE_CODE_TYPE;
00522 # endif
00523
00524
00525
00526 IL_IDX(list_idx) = ntr_const_tbl(type_idx,
00527 FALSE,
00528 the_constant);
00529 IL_LINE_NUM(list_idx) = line;
00530 IL_COL_NUM(list_idx) = col;
00531
00532 exp_desc = init_exp_desc;
00533 exp_desc.type = TYP_TYPE(type_idx);
00534 exp_desc.linear_type = TYP_LINEAR(type_idx);
00535 exp_desc.type_idx = type_idx;
00536 exp_desc.constant = TRUE;
00537 exp_desc.foldable = TRUE;
00538
00539 info_idx++;
00540 arg_info_list[info_idx] = init_arg_info;
00541 arg_info_list[info_idx].ed = exp_desc;
00542 arg_info_list[info_idx].maybe_modified = TRUE;
00543 IL_ARG_DESC_IDX(list_idx) = info_idx;
00544
00545 if (semantically_correct) {
00546 COPY_OPND(opnd, IR_OPND_R(ir_idx));
00547 semantically_correct = final_arg_work(&opnd,
00548 IR_IDX_L(ir_idx),
00549 IR_LIST_CNT_R(ir_idx),
00550 NULL);
00551 COPY_OPND(IR_OPND_R(ir_idx), opnd);
00552 create_io_call_descriptor(ir_idx, Buffer_Desc);
00553 # if 0
00554 # if defined(_FILE_IO_OPRS)
00555 if (buffer_in) {
00556 IR_OPR(ir_idx) = Buffer_In_Opr;
00557 }
00558 else {
00559 IR_OPR(ir_idx) = Buffer_Out_Opr;
00560 }
00561 # endif
00562 # endif
00563 }
00564
00565
00566
00567 arg_info_list_top = arg_info_list_base;
00568 arg_info_list_base = save_arg_info_list_base;
00569
00570 TRACE (Func_Exit, "buffer_stmt_semantics", NULL);
00571
00572 return;
00573
00574 }
00575
00576
00577
00578
00579
00580
00581
00582
00583
00584
00585
00586
00587
00588
00589
00590
00591
00592
00593 void close_stmt_semantics (void)
00594
00595 {
00596
00597 int ir_idx;
00598 opnd_type opnd;
00599 int save_arg_info_list_base;
00600 int save_curr_stmt_sh_idx;
00601 boolean semantically_correct;
00602
00603 # ifndef _NO_IO_ALTERNATE_RETURN
00604 int alt_return_tmp;
00605 int asg_idx;
00606 int br_true_idx;
00607 int col;
00608 int eq_idx;
00609 int line;
00610 int save_next_sh_idx;
00611 # endif
00612
00613
00614 TRACE (Func_Entry, "close_stmt_semantics", NULL);
00615
00616 SCP_DOES_IO(curr_scp_idx) = TRUE;
00617
00618 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00619
00620
00621
00622 if (max_call_list_size >= arg_list_size) {
00623 enlarge_call_list_tables();
00624 }
00625
00626 save_arg_info_list_base = arg_info_list_base;
00627
00628 arg_info_list_base = arg_info_list_top;
00629
00630 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
00631
00632 if (arg_info_list_top >= arg_info_list_size) {
00633 enlarge_info_list_table();
00634 }
00635
00636 # ifndef _NO_IO_ALTERNATE_RETURN
00637 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
00638 # endif
00639
00640 COPY_OPND(opnd, IR_OPND_R(ir_idx));
00641 semantically_correct = io_ctl_list_semantics(&opnd, Close, TRUE);
00642 COPY_OPND(IR_OPND_R(ir_idx), opnd);
00643
00644 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00645
00646 # ifndef _NO_IO_ALTERNATE_RETURN
00647 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
00648
00649 line = IR_LINE_NUM(ir_idx);
00650 col = IR_COL_NUM(ir_idx);
00651
00652 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
00653 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
00654 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
00655 AT_REFERENCED(alt_return_tmp) = Referenced;
00656 AT_DEFINED(alt_return_tmp) = TRUE;
00657 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
00658
00659 NTR_IR_TBL(asg_idx);
00660 IR_OPR(asg_idx) = Alt_Return_Opr;
00661 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
00662 IR_LINE_NUM(asg_idx) = line;
00663 IR_COL_NUM(asg_idx) = col;
00664 IR_LINE_NUM_L(asg_idx) = line;
00665 IR_COL_NUM_L(asg_idx) = col;
00666 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
00667 IR_IDX_L(asg_idx) = alt_return_tmp;
00668 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
00669 IR_IDX_R(asg_idx) = ir_idx;
00670
00671 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
00672
00673 if (err_list_idx) {
00674 NTR_IR_TBL(br_true_idx);
00675 IR_OPR(br_true_idx) = Br_True_Opr;
00676 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
00677 IR_LINE_NUM(br_true_idx) = line;
00678 IR_COL_NUM(br_true_idx) = col;
00679
00680 NTR_IR_TBL(eq_idx);
00681 IR_OPR(eq_idx) = Eq_Opr;
00682 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE;
00683 IR_LINE_NUM(eq_idx) = line;
00684 IR_COL_NUM(eq_idx) = col;
00685 IR_FLD_L(eq_idx) = AT_Tbl_Idx;
00686 IR_IDX_L(eq_idx) = alt_return_tmp;
00687 IR_LINE_NUM_L(eq_idx) = line;
00688 IR_COL_NUM_L(eq_idx) = col;
00689
00690 IR_FLD_R(eq_idx) = CN_Tbl_Idx;
00691 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX;
00692 IR_LINE_NUM_R(eq_idx) = line;
00693 IR_COL_NUM_R(eq_idx) = col;
00694
00695 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
00696 IR_IDX_L(br_true_idx) = eq_idx;
00697
00698 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
00699
00700 curr_stmt_sh_idx = save_next_sh_idx;
00701
00702 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
00703
00704 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx;
00705 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
00706
00707 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00708 }
00709 }
00710 # endif
00711
00712 if (semantically_correct) {
00713 COPY_OPND(opnd, IR_OPND_R(ir_idx));
00714 semantically_correct = final_arg_work(&opnd,
00715 IR_IDX_L(ir_idx),
00716 IR_LIST_CNT_R(ir_idx),
00717 NULL);
00718 COPY_OPND(IR_OPND_R(ir_idx), opnd);
00719 create_io_call_descriptor(ir_idx, Close_Desc);
00720 # if defined(_FILE_IO_OPRS)
00721 IR_OPR(ir_idx) = Close_Opr;
00722 # endif
00723 }
00724
00725 # ifdef _NO_IO_ALTERNATE_RETURN
00726 add_alt_return_lbl(ir_idx, err_attr_idx);
00727 # endif
00728
00729
00730
00731 arg_info_list_top = arg_info_list_base;
00732 arg_info_list_base = save_arg_info_list_base;
00733
00734 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00735
00736 TRACE (Func_Exit, "close_stmt_semantics", NULL);
00737
00738 return;
00739
00740 }
00741
00742
00743
00744
00745
00746
00747
00748
00749
00750
00751
00752
00753
00754
00755
00756
00757
00758
00759
00760 void encode_decode_stmt_semantics (void)
00761
00762 {
00763 int attr_idx;
00764 int cnt_list_idx;
00765 int col;
00766 expr_arg_type exp_desc;
00767 int free_list_idx;
00768 int fmt_list_idx;
00769 int intern_list_idx;
00770 int ir_idx;
00771 opnd_type left_opnd;
00772 int line;
00773 int list_idx;
00774 boolean ok;
00775 opnd_type opnd;
00776 int pp_tmp = NULL_IDX;
00777 int tmp_idx;
00778
00779
00780 TRACE (Func_Entry, "encode_decode_stmt_semantics", NULL);
00781
00782 SCP_DOES_IO(curr_scp_idx) = TRUE;
00783
00784 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00785
00786 cnt_list_idx = IR_IDX_L(ir_idx);
00787
00788 COPY_OPND(opnd, IL_OPND(cnt_list_idx));
00789 exp_desc.rank = 0;
00790 xref_state = CIF_Symbol_Reference;
00791 ok = expr_semantics(&opnd, &exp_desc);
00792 COPY_OPND(IL_OPND(cnt_list_idx), opnd);
00793 find_opnd_line_and_column(&opnd, &line, &col);
00794
00795 if (exp_desc.type != Integer) {
00796 PRINTMSG(line, 681, Error, col, stmt_type_str[stmt_type]);
00797 }
00798 else if (exp_desc.constant &&
00799 (CN_INT_TO_C(OPND_IDX(opnd)) <= 0 ||
00800 CN_INT_TO_C(OPND_IDX(opnd)) > 152)) {
00801
00802 PRINTMSG(line, 682, Error, col, stmt_type_str[stmt_type]);
00803 }
00804 else if (exp_desc.rank > 0) {
00805 PRINTMSG(line, 683, Error, col, stmt_type_str[stmt_type]);
00806 }
00807
00808
00809
00810 fmt_list_idx = IL_NEXT_LIST_IDX(cnt_list_idx);
00811
00812 if (IL_FLD(fmt_list_idx) == IL_Tbl_Idx) {
00813
00814
00815
00816
00817
00818
00819 pp_tmp = IL_IDX(IL_NEXT_LIST_IDX(IL_IDX(fmt_list_idx)));
00820 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(fmt_list_idx)));
00821 free_list_idx = IL_IDX(fmt_list_idx);
00822 COPY_OPND(IL_OPND(fmt_list_idx), IL_OPND(IL_IDX(fmt_list_idx)));
00823 FREE_IR_LIST_NODE(free_list_idx);
00824
00825 ADD_TMP_TO_SHARED_LIST(IL_IDX(fmt_list_idx));
00826 ADD_TMP_TO_SHARED_LIST(pp_tmp);
00827 }
00828 else if (IL_FLD(fmt_list_idx) == AT_Tbl_Idx &&
00829 AT_OBJ_CLASS(IL_IDX(fmt_list_idx)) == Label) {
00830
00831 if (ATL_CLASS(IL_IDX(fmt_list_idx)) == Lbl_Format) {
00832
00833 pp_tmp = ATL_PP_FORMAT_TMP(IL_IDX(fmt_list_idx));
00834
00835 IL_IDX(fmt_list_idx) = ATL_FORMAT_TMP(IL_IDX(fmt_list_idx));
00836 IL_FLD(fmt_list_idx) = AT_Tbl_Idx;
00837 IL_LINE_NUM(fmt_list_idx) = line;
00838 IL_COL_NUM(fmt_list_idx) = col;
00839
00840 ADD_TMP_TO_SHARED_LIST(ATL_FORMAT_TMP(IL_IDX(fmt_list_idx)));
00841
00842 ADD_TMP_TO_SHARED_LIST(ATL_PP_FORMAT_TMP(IL_IDX(fmt_list_idx)));
00843
00844 }
00845
00846
00847 }
00848 else {
00849
00850 COPY_OPND(opnd, IL_OPND(fmt_list_idx));
00851 exp_desc.rank = 0;
00852 xref_state = CIF_Symbol_Reference;
00853 io_item_must_flatten = FALSE;
00854 ok = expr_semantics(&opnd, &exp_desc);
00855 COPY_OPND(IL_OPND(fmt_list_idx), opnd);
00856
00857
00858
00859 find_opnd_line_and_column(&opnd, &line, &col);
00860
00861 if (exp_desc.type == Character) {
00862
00863 if (io_item_must_flatten ||
00864 exp_desc.dist_reshape_ref ||
00865 exp_desc.vector_subscript) {
00866
00867 tmp_idx = create_tmp_asg(&opnd, &exp_desc, &left_opnd,
00868 Intent_In, TRUE, FALSE);
00869 COPY_OPND(IL_OPND(fmt_list_idx), left_opnd);
00870 }
00871 }
00872 else if (exp_desc.rank > 0 &&
00873 (OPND_FLD(opnd) != IR_Tbl_Idx ||
00874 exp_desc.dope_vector ||
00875 IR_OPR(OPND_IDX(opnd)) != Whole_Subscript_Opr)) {
00876
00877
00878
00879
00880 PRINTMSG(line, 447, Error, col);
00881 }
00882 else if (exp_desc.type == Integer &&
00883 exp_desc.reference) {
00884
00885 if (exp_desc.rank == 0) {
00886
00887 if (!exp_desc.reference) {
00888 PRINTMSG(line, 447, Error, col);
00889 }
00890 else if (exp_desc.linear_type != INTEGER_DEFAULT_TYPE) {
00891
00892
00893
00894 PRINTMSG(line, 462, Error, col);
00895 }
00896 else {
00897
00898 attr_idx = find_base_attr(&opnd, &line, &col);
00899
00900 if (! ATD_IN_ASSIGN(attr_idx)) {
00901 PRINTMSG(line, 1099, Error, col);
00902 }
00903
00904 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00905 if (ATD_ASSIGN_TMP_IDX(attr_idx) != NULL_IDX) {
00906 OPND_FLD(opnd) = AT_Tbl_Idx;
00907 OPND_IDX(opnd) = ATD_ASSIGN_TMP_IDX(attr_idx);
00908 COPY_OPND(IL_OPND(fmt_list_idx), opnd);
00909 ADD_TMP_TO_SHARED_LIST(ATD_ASSIGN_TMP_IDX(attr_idx));
00910 }
00911 # endif
00912 }
00913 }
00914 else {
00915 PRINTMSG(line, 778, Ansi, col);
00916 }
00917 }
00918 else if ((exp_desc.linear_type == REAL_DEFAULT_TYPE ||
00919 exp_desc.type == Logical) &&
00920 exp_desc.reference &&
00921 exp_desc.rank > 0) {
00922 PRINTMSG(line, 778, Ansi, col);
00923 }
00924 else if (exp_desc.type == Typeless &&
00925 exp_desc.rank == 0) {
00926
00927
00928
00929 }
00930 else {
00931 PRINTMSG(line, 447, Error, col);
00932 }
00933 }
00934
00935 intern_list_idx = IL_NEXT_LIST_IDX(fmt_list_idx);
00936
00937 COPY_OPND(opnd, IL_OPND(intern_list_idx));
00938 exp_desc.rank = 0;
00939
00940 if (stmt_type == Encode_Stmt) {
00941 xref_state = CIF_Symbol_Modification;
00942 }
00943 else {
00944 xref_state = CIF_Symbol_Reference;
00945 }
00946 ok = expr_semantics(&opnd, &exp_desc);
00947 COPY_OPND(IL_OPND(intern_list_idx), opnd);
00948
00949
00950
00951 if (stmt_type == Encode_Stmt) {
00952
00953
00954
00955 if (! check_for_legal_define(&opnd)) {
00956 ok = FALSE;
00957 }
00958 }
00959
00960
00961
00962 COPY_OPND(opnd, IL_OPND(intern_list_idx));
00963 find_opnd_line_and_column(&opnd, &line, &col);
00964
00965 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
00966 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr) {
00967
00968 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
00969 }
00970
00971 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
00972 (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr ||
00973 IR_OPR(OPND_IDX(opnd)) == Subscript_Opr)) {
00974
00975 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
00976 }
00977
00978 if (OPND_FLD(opnd) != AT_Tbl_Idx) {
00979
00980
00981 PRINTMSG(line, 1112, Error, col,
00982 (stmt_type == Encode_Stmt ? "destination" : "source"),
00983 (stmt_type == Encode_Stmt ? "ENCODE" : "DECODE"));
00984
00985 ok = FALSE;
00986 }
00987 else if (AT_OBJ_CLASS(OPND_IDX(opnd)) != Data_Obj ||
00988 (ATD_CLASS(OPND_IDX(opnd)) != Variable &&
00989 ATD_CLASS(OPND_IDX(opnd)) != Dummy_Argument &&
00990 ATD_CLASS(OPND_IDX(opnd)) != Function_Result) ||
00991 ATD_POINTER(OPND_IDX(opnd)) ||
00992 ATD_ALLOCATABLE(OPND_IDX(opnd))) {
00993
00994
00995 PRINTMSG(line, 1112, Error, col,
00996 (stmt_type == Encode_Stmt ? "destination" : "source"),
00997 (stmt_type == Encode_Stmt ? "ENCODE" : "DECODE"));
00998 ok = FALSE;
00999 }
01000
01001
01002
01003
01004
01005
01006
01007
01008 IR_IDX_L(ir_idx) = cnt_list_idx;
01009 # ifdef _NO_IO_ALTERNATE_RETURN
01010 IR_LIST_CNT_L(ir_idx) = NUM_PDG_CONTROL_LIST_ITEMS + 3;
01011 # else
01012 IR_LIST_CNT_L(ir_idx) = NUM_PDG_CONTROL_LIST_ITEMS;
01013 # endif
01014
01015
01016
01017
01018
01019
01020 IL_PREV_LIST_IDX(cnt_list_idx) = NULL_IDX;
01021
01022
01023
01024
01025
01026 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(cnt_list_idx));
01027 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(cnt_list_idx)) = cnt_list_idx;
01028 list_idx = IL_NEXT_LIST_IDX(cnt_list_idx);
01029
01030 IL_FLD(list_idx) = CN_Tbl_Idx;
01031 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
01032 IL_LINE_NUM(list_idx) = line;
01033 IL_COL_NUM(list_idx) = col;
01034
01035
01036
01037
01038
01039 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01040 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01041 list_idx = IL_NEXT_LIST_IDX(list_idx);
01042
01043
01044
01045
01046 IL_FLD(list_idx) = CN_Tbl_Idx;
01047 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE);
01048 IL_LINE_NUM(list_idx) = line;
01049 IL_COL_NUM(list_idx) = col;
01050
01051
01052
01053
01054
01055
01056 IL_NEXT_LIST_IDX(list_idx) = intern_list_idx;
01057 IL_PREV_LIST_IDX(intern_list_idx) = list_idx;
01058 list_idx = IL_NEXT_LIST_IDX(list_idx);
01059
01060
01061
01062
01063
01064 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01065 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01066 list_idx = IL_NEXT_LIST_IDX(list_idx);
01067
01068
01069
01070
01071
01072 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01073 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01074 list_idx = IL_NEXT_LIST_IDX(list_idx);
01075
01076
01077
01078
01079
01080 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01081 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01082 list_idx = IL_NEXT_LIST_IDX(list_idx);
01083
01084
01085
01086 if (pp_tmp) {
01087 IL_FLD(list_idx) = AT_Tbl_Idx;
01088 IL_IDX(list_idx) = pp_tmp;
01089 IL_LINE_NUM(list_idx) = line;
01090 IL_COL_NUM(list_idx) = col;
01091 }
01092
01093
01094
01095
01096
01097 IL_NEXT_LIST_IDX(list_idx) = fmt_list_idx;
01098 IL_PREV_LIST_IDX(fmt_list_idx) = list_idx;
01099 list_idx = IL_NEXT_LIST_IDX(list_idx);
01100
01101
01102
01103
01104
01105 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01106 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01107 list_idx = IL_NEXT_LIST_IDX(list_idx);
01108
01109
01110
01111
01112
01113 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01114 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01115 list_idx = IL_NEXT_LIST_IDX(list_idx);
01116 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
01117
01118 # ifdef _NO_IO_ALTERNATE_RETURN
01119
01120
01121
01122
01123 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01124 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01125 list_idx = IL_NEXT_LIST_IDX(list_idx);
01126
01127
01128
01129
01130
01131 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01132 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01133 list_idx = IL_NEXT_LIST_IDX(list_idx);
01134
01135
01136
01137
01138
01139 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01140 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01141 list_idx = IL_NEXT_LIST_IDX(list_idx);
01142 # endif
01143
01144
01145
01146
01147
01148 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01149
01150 defer_stmt_expansion = TRUE;
01151 number_of_functions = 0;
01152 io_stmt_must_be_split = FALSE;
01153
01154 if (stmt_type == Decode_Stmt) {
01155 ok = io_list_semantics(&opnd, Decode);
01156 }
01157 else {
01158 ok = io_list_semantics(&opnd, Encode);
01159 }
01160
01161 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01162
01163 defer_stmt_expansion = FALSE;
01164
01165 if (ok &&
01166 (number_of_functions > 0 ||
01167 tree_has_constructor ||
01168 io_stmt_must_be_split ||
01169 io_item_must_flatten)) {
01170 process_deferred_io_list();
01171 }
01172 else if (ok) {
01173 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01174 gen_runtime_checks(&opnd);
01175 }
01176
01177 TRACE (Func_Exit, "encode_decode_stmt_semantics", NULL);
01178
01179 return;
01180
01181 }
01182
01183
01184
01185
01186
01187
01188
01189
01190
01191
01192
01193
01194
01195
01196
01197
01198
01199
01200 void endfile_stmt_semantics (void)
01201
01202 {
01203 int ir_idx;
01204 opnd_type opnd;
01205 int save_arg_info_list_base;
01206 int save_curr_stmt_sh_idx;
01207 boolean semantically_correct;
01208
01209 # ifndef _NO_IO_ALTERNATE_RETURN
01210 int alt_return_tmp;
01211 int asg_idx;
01212 int br_true_idx;
01213 int col;
01214 int eq_idx;
01215 int line;
01216 int save_next_sh_idx;
01217 # endif
01218
01219
01220 TRACE (Func_Entry, "endfile_stmt_semantics", NULL);
01221
01222 SCP_DOES_IO(curr_scp_idx) = TRUE;
01223
01224 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01225
01226
01227
01228 if (max_call_list_size >= arg_list_size) {
01229 enlarge_call_list_tables();
01230 }
01231
01232 save_arg_info_list_base = arg_info_list_base;
01233
01234 arg_info_list_base = arg_info_list_top;
01235
01236 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
01237
01238 if (arg_info_list_top >= arg_info_list_size) {
01239 enlarge_info_list_table();
01240 }
01241
01242 # ifndef _NO_IO_ALTERNATE_RETURN
01243 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01244 # endif
01245
01246 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01247 semantically_correct = io_ctl_list_semantics(&opnd, Endfile, TRUE);
01248 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01249
01250 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01251
01252 # ifndef _NO_IO_ALTERNATE_RETURN
01253 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
01254
01255 line = IR_LINE_NUM(ir_idx);
01256 col = IR_COL_NUM(ir_idx);
01257
01258 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
01259 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
01260 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
01261 AT_REFERENCED(alt_return_tmp) = Referenced;
01262 AT_DEFINED(alt_return_tmp) = TRUE;
01263 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01264
01265 NTR_IR_TBL(asg_idx);
01266 IR_OPR(asg_idx) = Alt_Return_Opr;
01267 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
01268 IR_LINE_NUM(asg_idx) = line;
01269 IR_COL_NUM(asg_idx) = col;
01270 IR_LINE_NUM_L(asg_idx) = line;
01271 IR_COL_NUM_L(asg_idx) = col;
01272 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
01273 IR_IDX_L(asg_idx) = alt_return_tmp;
01274 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
01275 IR_IDX_R(asg_idx) = ir_idx;
01276
01277 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01278
01279 if (err_list_idx) {
01280 NTR_IR_TBL(br_true_idx);
01281 IR_OPR(br_true_idx) = Br_True_Opr;
01282 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
01283 IR_LINE_NUM(br_true_idx) = line;
01284 IR_COL_NUM(br_true_idx) = col;
01285
01286 NTR_IR_TBL(eq_idx);
01287 IR_OPR(eq_idx) = Eq_Opr;
01288 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE;
01289 IR_LINE_NUM(eq_idx) = line;
01290 IR_COL_NUM(eq_idx) = col;
01291 IR_FLD_L(eq_idx) = AT_Tbl_Idx;
01292 IR_IDX_L(eq_idx) = alt_return_tmp;
01293 IR_LINE_NUM_L(eq_idx) = line;
01294 IR_COL_NUM_L(eq_idx) = col;
01295
01296 IR_FLD_R(eq_idx) = CN_Tbl_Idx;
01297 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX;
01298 IR_LINE_NUM_R(eq_idx) = line;
01299 IR_COL_NUM_R(eq_idx) = col;
01300
01301 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
01302 IR_IDX_L(br_true_idx) = eq_idx;
01303
01304 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
01305
01306 curr_stmt_sh_idx = save_next_sh_idx;
01307
01308 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
01309
01310 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx;
01311 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01312
01313 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01314 }
01315 }
01316 # endif
01317
01318 if (semantically_correct) {
01319 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01320 semantically_correct = final_arg_work(&opnd,
01321 IR_IDX_L(ir_idx),
01322 IR_LIST_CNT_R(ir_idx),
01323 NULL);
01324 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01325 # if defined(_FILE_IO_OPRS)
01326 IR_OPR(ir_idx) = Endfile_Opr;
01327 # endif
01328 }
01329
01330 # ifdef _NO_IO_ALTERNATE_RETURN
01331 add_alt_return_lbl(ir_idx, err_attr_idx);
01332 # endif
01333
01334
01335
01336 arg_info_list_top = arg_info_list_base;
01337 arg_info_list_base = save_arg_info_list_base;
01338
01339 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01340
01341 TRACE (Func_Exit, "endfile_stmt_semantics", NULL);
01342
01343 return;
01344
01345 }
01346
01347
01348
01349
01350
01351
01352
01353
01354
01355
01356
01357
01358
01359
01360
01361
01362
01363
01364 void inquire_stmt_semantics (void)
01365
01366 {
01367 int asg_idx;
01368 int attr_idx;
01369 int col;
01370 expr_arg_type exp_desc;
01371 int ir_idx;
01372 int line;
01373 int list_idx;
01374 opnd_type opnd;
01375 int save_arg_info_list_base;
01376 int save_curr_stmt_sh_idx;
01377 boolean semantically_correct;
01378 int tmp_idx;
01379
01380 # ifndef _NO_IO_ALTERNATE_RETURN
01381 int alt_return_tmp;
01382 int br_true_idx;
01383 int eq_idx;
01384 int save_next_sh_idx;
01385 # endif
01386
01387
01388 TRACE (Func_Entry, "inquire_stmt_semantics", NULL);
01389
01390 SCP_DOES_IO(curr_scp_idx) = TRUE;
01391
01392 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01393 line = IR_LINE_NUM(ir_idx);
01394 col = IR_COL_NUM(ir_idx);
01395
01396
01397
01398 if (max_call_list_size >= arg_list_size) {
01399 enlarge_call_list_tables();
01400 }
01401
01402 save_arg_info_list_base = arg_info_list_base;
01403
01404 arg_info_list_base = arg_info_list_top;
01405
01406 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
01407
01408 if (arg_info_list_top >= arg_info_list_size) {
01409 enlarge_info_list_table();
01410 }
01411
01412 if (IR_OPR(ir_idx) == Call_Opr) {
01413
01414 # ifndef _NO_IO_ALTERNATE_RETURN
01415 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01416 # endif
01417
01418 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01419 semantically_correct = io_ctl_list_semantics(&opnd, Inquire, TRUE);
01420 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01421
01422 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01423
01424 # ifndef _NO_IO_ALTERNATE_RETURN
01425 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
01426
01427
01428 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
01429 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
01430 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
01431 AT_REFERENCED(alt_return_tmp) = Referenced;
01432 AT_DEFINED(alt_return_tmp) = TRUE;
01433 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01434
01435 NTR_IR_TBL(asg_idx);
01436 IR_OPR(asg_idx) = Alt_Return_Opr;
01437 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
01438 IR_LINE_NUM(asg_idx) = line;
01439 IR_COL_NUM(asg_idx) = col;
01440 IR_LINE_NUM_L(asg_idx) = line;
01441 IR_COL_NUM_L(asg_idx) = col;
01442 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
01443 IR_IDX_L(asg_idx) = alt_return_tmp;
01444 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
01445 IR_IDX_R(asg_idx) = ir_idx;
01446
01447 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01448
01449 if (err_list_idx) {
01450 NTR_IR_TBL(br_true_idx);
01451 IR_OPR(br_true_idx) = Br_True_Opr;
01452 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
01453 IR_LINE_NUM(br_true_idx) = line;
01454 IR_COL_NUM(br_true_idx) = col;
01455
01456 NTR_IR_TBL(eq_idx);
01457 IR_OPR(eq_idx) = Eq_Opr;
01458 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE;
01459 IR_LINE_NUM(eq_idx) = line;
01460 IR_COL_NUM(eq_idx) = col;
01461 IR_FLD_L(eq_idx) = AT_Tbl_Idx;
01462 IR_IDX_L(eq_idx) = alt_return_tmp;
01463 IR_LINE_NUM_L(eq_idx) = line;
01464 IR_COL_NUM_L(eq_idx) = col;
01465
01466 IR_FLD_R(eq_idx) = CN_Tbl_Idx;
01467 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX;
01468 IR_LINE_NUM_R(eq_idx) = line;
01469 IR_COL_NUM_R(eq_idx) = col;
01470
01471 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
01472 IR_IDX_L(br_true_idx) = eq_idx;
01473
01474 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
01475
01476 curr_stmt_sh_idx = save_next_sh_idx;
01477
01478 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
01479
01480 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx;
01481 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01482
01483 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01484 }
01485 }
01486 # endif
01487
01488 if (semantically_correct) {
01489 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01490 semantically_correct = final_arg_work(&opnd,
01491 IR_IDX_L(ir_idx),
01492 IR_LIST_CNT_R(ir_idx),
01493 NULL);
01494 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01495 create_io_call_descriptor(ir_idx, Inquire_Desc);
01496 # if defined(_FILE_IO_OPRS)
01497 IR_OPR(ir_idx) = Inquire_Opr;
01498 # endif
01499 }
01500
01501 # ifdef _NO_IO_ALTERNATE_RETURN
01502 add_alt_return_lbl(ir_idx, err_attr_idx);
01503 # endif
01504
01505 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01506 }
01507 else {
01508
01509
01510
01511 NTR_IR_TBL(asg_idx);
01512 IR_OPR(asg_idx) = Asg_Opr;
01513 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
01514 IR_LINE_NUM(asg_idx) = IR_LINE_NUM(ir_idx);
01515 IR_COL_NUM(asg_idx) = IR_COL_NUM(ir_idx);
01516 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01517 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
01518 IR_IDX_R(asg_idx) = ir_idx;
01519
01520
01521
01522 list_idx = IR_IDX_L(ir_idx);
01523
01524
01525
01526
01527
01528
01529 COPY_OPND(opnd, IL_OPND(list_idx));
01530 exp_desc.rank = 0;
01531 xref_state = CIF_Symbol_Modification;
01532 semantically_correct = expr_semantics(&opnd, &exp_desc);
01533 COPY_OPND(IR_OPND_L(asg_idx), opnd);
01534
01535
01536 if (exp_desc.rank != 0 ||
01537 !exp_desc.reference ||
01538 exp_desc.type != Integer ||
01539 exp_desc.linear_type != INTEGER_DEFAULT_TYPE) {
01540
01541 find_opnd_line_and_column(&opnd, &line, &col);
01542 PRINTMSG(line, 483, Error, col);
01543 semantically_correct = FALSE;
01544 }
01545 else if (! check_for_legal_define(&opnd)) {
01546 semantically_correct = FALSE;
01547 }
01548 else {
01549
01550 attr_idx = find_left_attr(&opnd);
01551
01552
01553
01554 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
01555 ATD_TYPE_IDX(tmp_idx) = ATD_TYPE_IDX(attr_idx);
01556 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
01557 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
01558
01559 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
01560 IR_IDX_L(asg_idx) = tmp_idx;
01561 IR_LINE_NUM_L(asg_idx) = IR_LINE_NUM(ir_idx);
01562 IR_COL_NUM_L(asg_idx) = IR_COL_NUM(ir_idx);
01563
01564
01565
01566
01567 NTR_IR_TBL(asg_idx);
01568 IR_OPR(asg_idx) = Asg_Opr;
01569 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
01570 IR_LINE_NUM(asg_idx) = line;
01571 IR_COL_NUM(asg_idx) = col;
01572
01573 COPY_OPND(IR_OPND_L(asg_idx), opnd);
01574 IR_FLD_R(asg_idx) = AT_Tbl_Idx;
01575 IR_IDX_R(asg_idx) = tmp_idx;
01576 IR_LINE_NUM_R(asg_idx) = line;
01577 IR_COL_NUM_R(asg_idx) = col;
01578
01579 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
01580
01581 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01582 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
01583
01584 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
01585
01586 }
01587
01588
01589
01590
01591
01592
01593
01594
01595
01596
01597 IL_FLD(list_idx) = CN_Tbl_Idx;
01598 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE);
01599 IL_LINE_NUM(list_idx) = line;
01600 IL_COL_NUM(list_idx) = col;
01601
01602
01603
01604
01605
01606 defer_stmt_expansion = TRUE;
01607 number_of_functions = 0;
01608 io_stmt_must_be_split = FALSE;
01609
01610 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01611 semantically_correct = io_list_semantics(&opnd, Inquire) &&
01612 semantically_correct;
01613 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01614
01615 defer_stmt_expansion = FALSE;
01616
01617 if (semantically_correct &&
01618 (number_of_functions > 0 ||
01619 tree_has_constructor ||
01620 io_stmt_must_be_split ||
01621 io_item_must_flatten)) {
01622 process_deferred_io_list();
01623 }
01624 else if (semantically_correct) {
01625 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01626 gen_runtime_checks(&opnd);
01627 }
01628 }
01629
01630
01631
01632 arg_info_list_top = arg_info_list_base;
01633 arg_info_list_base = save_arg_info_list_base;
01634
01635 TRACE (Func_Exit, "inquire_stmt_semantics", NULL);
01636
01637 return;
01638
01639 }
01640
01641
01642
01643
01644
01645
01646
01647
01648
01649
01650
01651
01652
01653
01654
01655
01656
01657
01658 void open_stmt_semantics (void)
01659
01660 {
01661 int ir_idx;
01662 opnd_type opnd;
01663 int save_arg_info_list_base;
01664 int save_curr_stmt_sh_idx;
01665 boolean semantically_correct;
01666
01667 # ifndef _NO_IO_ALTERNATE_RETURN
01668 int alt_return_tmp;
01669 int asg_idx;
01670 int br_true_idx;
01671 int col;
01672 int eq_idx;
01673 int line;
01674 int save_next_sh_idx;
01675 # endif
01676
01677
01678 TRACE (Func_Entry, "open_stmt_semantics", NULL);
01679
01680 SCP_DOES_IO(curr_scp_idx) = TRUE;
01681
01682 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01683
01684
01685
01686 if (max_call_list_size >= arg_list_size) {
01687 enlarge_call_list_tables();
01688 }
01689
01690 save_arg_info_list_base = arg_info_list_base;
01691
01692 arg_info_list_base = arg_info_list_top;
01693
01694 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
01695
01696 if (arg_info_list_top >= arg_info_list_size) {
01697 enlarge_info_list_table();
01698 }
01699
01700 # ifndef _NO_IO_ALTERNATE_RETURN
01701 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
01702 # endif
01703
01704 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01705 semantically_correct = io_ctl_list_semantics(&opnd, Open, TRUE);
01706 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01707
01708 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01709
01710 # ifndef _NO_IO_ALTERNATE_RETURN
01711 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
01712
01713 line = IR_LINE_NUM(ir_idx);
01714 col = IR_COL_NUM(ir_idx);
01715
01716 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
01717 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
01718 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
01719 AT_REFERENCED(alt_return_tmp) = Referenced;
01720 AT_DEFINED(alt_return_tmp) = TRUE;
01721 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01722
01723 NTR_IR_TBL(asg_idx);
01724 IR_OPR(asg_idx) = Alt_Return_Opr;
01725 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
01726 IR_LINE_NUM(asg_idx) = line;
01727 IR_COL_NUM(asg_idx) = col;
01728 IR_LINE_NUM_L(asg_idx) = line;
01729 IR_COL_NUM_L(asg_idx) = col;
01730 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
01731 IR_IDX_L(asg_idx) = alt_return_tmp;
01732 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
01733 IR_IDX_R(asg_idx) = ir_idx;
01734
01735 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01736
01737 if (err_list_idx) {
01738 NTR_IR_TBL(br_true_idx);
01739 IR_OPR(br_true_idx) = Br_True_Opr;
01740 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
01741 IR_LINE_NUM(br_true_idx) = line;
01742 IR_COL_NUM(br_true_idx) = col;
01743
01744 NTR_IR_TBL(eq_idx);
01745 IR_OPR(eq_idx) = Eq_Opr;
01746 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE;
01747 IR_LINE_NUM(eq_idx) = line;
01748 IR_COL_NUM(eq_idx) = col;
01749 IR_FLD_L(eq_idx) = AT_Tbl_Idx;
01750 IR_IDX_L(eq_idx) = alt_return_tmp;
01751 IR_LINE_NUM_L(eq_idx) = line;
01752 IR_COL_NUM_L(eq_idx) = col;
01753
01754 IR_FLD_R(eq_idx) = CN_Tbl_Idx;
01755 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX;
01756 IR_LINE_NUM_R(eq_idx) = line;
01757 IR_COL_NUM_R(eq_idx) = col;
01758
01759 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
01760 IR_IDX_L(br_true_idx) = eq_idx;
01761
01762 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
01763
01764 curr_stmt_sh_idx = save_next_sh_idx;
01765
01766 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
01767
01768 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx;
01769 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01770
01771 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01772 }
01773 }
01774 # endif
01775
01776 if (semantically_correct) {
01777 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01778 semantically_correct = final_arg_work(&opnd,
01779 IR_IDX_L(ir_idx),
01780 IR_LIST_CNT_R(ir_idx),
01781 NULL);
01782 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01783 create_io_call_descriptor(ir_idx, Open_Desc);
01784 # if defined(_FILE_IO_OPRS)
01785 IR_OPR(ir_idx) = Open_Opr;
01786 # endif
01787 }
01788
01789 # ifdef _NO_IO_ALTERNATE_RETURN
01790 add_alt_return_lbl(ir_idx, err_attr_idx);
01791 # endif
01792
01793
01794
01795 arg_info_list_top = arg_info_list_base;
01796 arg_info_list_base = save_arg_info_list_base;
01797
01798 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01799
01800 TRACE (Func_Exit, "open_stmt_semantics", NULL);
01801
01802 return;
01803
01804 }
01805
01806
01807
01808
01809
01810
01811
01812
01813
01814
01815
01816
01817
01818
01819
01820
01821
01822
01823 void print_stmt_semantics (void)
01824
01825 {
01826 int col;
01827 int ir_idx;
01828 int line;
01829 int list_idx;
01830 int loc_idx;
01831 opnd_type opnd;
01832 boolean semantically_correct;
01833
01834
01835 TRACE (Func_Entry, "print_stmt_semantics", NULL);
01836
01837 SCP_DOES_IO(curr_scp_idx) = TRUE;
01838
01839 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
01840
01841 COPY_OPND(opnd, IR_OPND_L(ir_idx));
01842 semantically_correct = io_ctl_list_semantics(&opnd, Print, FALSE);
01843 COPY_OPND(IR_OPND_L(ir_idx), opnd);
01844
01845 if (is_namelist) {
01846
01847 if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) {
01848 find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)),
01849 &line,
01850 &col);
01851 PRINTMSG(line, 444, Error, col);
01852 }
01853
01854 if (namelist_descriptor_attr) {
01855
01856 # if 0
01857
01858
01859 {int _call_idx, _list_idx, _loc_idx;
01860 int _dump_nml_idx;
01861 _dump_nml_idx = create_lib_entry_attr("DUMP_NML",
01862 8,
01863 stmt_start_line,
01864 stmt_start_col);
01865
01866 ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx);
01867
01868 NTR_IR_TBL(_call_idx);
01869 IR_OPR(_call_idx) = Call_Opr;
01870 IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE;
01871 IR_LINE_NUM(_call_idx) = stmt_start_line;
01872 IR_COL_NUM(_call_idx) = stmt_start_col;
01873 IR_FLD_L(_call_idx) = AT_Tbl_Idx;
01874 IR_IDX_L(_call_idx) = _dump_nml_idx;
01875 IR_LINE_NUM_L(_call_idx) = stmt_start_line;
01876 IR_COL_NUM_L(_call_idx) = stmt_start_col;
01877
01878 NTR_IR_LIST_TBL(_list_idx);
01879 IR_FLD_R(_call_idx) = IL_Tbl_Idx;
01880 IR_IDX_R(_call_idx) = _list_idx;
01881 IR_LIST_CNT_R(_call_idx) = 1;
01882
01883 NTR_IR_TBL(_loc_idx);
01884 IR_OPR(_loc_idx) = Aloc_Opr;
01885 IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8;
01886 IR_LINE_NUM(_loc_idx) = stmt_start_line;
01887 IR_COL_NUM(_loc_idx) = stmt_start_col;
01888 IL_FLD(_list_idx) = IR_Tbl_Idx;
01889 IL_IDX(_list_idx) = _loc_idx;
01890
01891 IR_FLD_L(_loc_idx) = AT_Tbl_Idx;
01892 IR_IDX_L(_loc_idx) = namelist_descriptor_attr;
01893 IR_LINE_NUM_L(_loc_idx) = stmt_start_line;
01894 IR_COL_NUM_L(_loc_idx) = stmt_start_col;
01895
01896 gen_sh(Before, Call_Stmt, stmt_start_line,
01897 stmt_start_col, FALSE, FALSE, TRUE);
01898
01899 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = _call_idx;
01900 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01901 }
01902
01903 # endif
01904 NTR_IR_LIST_TBL(list_idx);
01905 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
01906 IR_LIST_CNT_R(ir_idx) = 1;
01907 IR_IDX_R(ir_idx) = list_idx;
01908 NTR_IR_TBL(loc_idx);
01909 IR_OPR(loc_idx) = Loc_Opr;
01910 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
01911 IR_LINE_NUM(loc_idx) = stmt_start_line;
01912 IR_COL_NUM(loc_idx) = stmt_start_col;
01913 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
01914 IR_IDX_L(loc_idx) = namelist_descriptor_attr;
01915 IR_LINE_NUM_L(loc_idx) = stmt_start_line;
01916 IR_COL_NUM_L(loc_idx) = stmt_start_col;
01917 IL_FLD(list_idx) = IR_Tbl_Idx;
01918 IL_IDX(list_idx) = loc_idx;
01919 }
01920 }
01921 else {
01922 defer_stmt_expansion = TRUE;
01923 number_of_functions = 0;
01924 io_stmt_must_be_split = FALSE;
01925
01926 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01927 semantically_correct = io_list_semantics(&opnd, Print) &&
01928 semantically_correct;
01929 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01930
01931 defer_stmt_expansion = FALSE;
01932
01933 if (semantically_correct &&
01934 (number_of_functions > 0 ||
01935 tree_has_constructor ||
01936 io_stmt_must_be_split ||
01937 io_item_must_flatten)) {
01938 process_deferred_io_list();
01939 }
01940 else if (semantically_correct) {
01941 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01942 gen_runtime_checks(&opnd);
01943 }
01944 }
01945
01946 TRACE (Func_Exit, "print_stmt_semantics", NULL);
01947
01948 return;
01949
01950 }
01951
01952
01953
01954
01955
01956
01957
01958
01959
01960
01961
01962
01963
01964
01965
01966
01967
01968
01969 void read_stmt_semantics (void)
01970
01971 {
01972 int col;
01973 int ir_idx;
01974 int line;
01975 int list_idx;
01976 int loc_idx;
01977 opnd_type opnd;
01978 boolean semantically_correct;
01979
01980 # ifndef _NO_IO_ALTERNATE_RETURN
01981 int alt_return_tmp;
01982 int asg_idx;
01983 int br_idx_idx = NULL_IDX;
01984 int br_true_idx;
01985 int drop_thru_label_idx;
01986 int jump_out_label;
01987 int lab_idx;
01988 int ne_idx;
01989 int save_next_sh_idx;
01990 int save_curr_stmt_sh_idx;
01991 # endif
01992
01993
01994 TRACE (Func_Entry, "read_stmt_semantics", NULL);
01995
01996 SCP_DOES_IO(curr_scp_idx) = TRUE;
01997
01998 # ifndef _NO_IO_ALTERNATE_RETURN
01999 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
02000 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02001 # endif
02002
02003 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
02004
02005 COPY_OPND(opnd, IR_OPND_L(ir_idx));
02006 semantically_correct = io_ctl_list_semantics(&opnd, Read, FALSE);
02007 COPY_OPND(IR_OPND_L(ir_idx), opnd);
02008
02009 line = IR_LINE_NUM(ir_idx);
02010 col = IR_COL_NUM(ir_idx);
02011
02012 # ifndef _NO_IO_ALTERNATE_RETURN
02013 if (have_iostat ||
02014 end_list_idx != NULL_IDX ||
02015 err_list_idx != NULL_IDX ||
02016 eor_list_idx != NULL_IDX) {
02017
02018 if (end_list_idx == NULL_IDX ||
02019 err_list_idx == NULL_IDX ||
02020 eor_list_idx == NULL_IDX) {
02021
02022
02023
02024 drop_thru_label_idx = gen_internal_lbl(stmt_start_line);
02025
02026 curr_stmt_sh_idx = save_next_sh_idx;
02027
02028 gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
02029
02030 NTR_IR_TBL(lab_idx);
02031 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = lab_idx;
02032 IR_OPR(lab_idx) = Label_Opr;
02033 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE;
02034 IR_LINE_NUM(lab_idx) = line;
02035 IR_COL_NUM(lab_idx) = col;
02036 IR_FLD_L(lab_idx) = AT_Tbl_Idx;
02037 IR_IDX_L(lab_idx) = drop_thru_label_idx;
02038 IR_COL_NUM_L(lab_idx) = col;
02039 IR_LINE_NUM_L(lab_idx) = line;
02040
02041 AT_DEFINED(drop_thru_label_idx) = TRUE;
02042 ATL_DEF_STMT_IDX(drop_thru_label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
02043
02044 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02045 save_next_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02046
02047 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02048 }
02049
02050 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
02051 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
02052 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
02053 AT_REFERENCED(alt_return_tmp) = Referenced;
02054 AT_DEFINED(alt_return_tmp) = TRUE;
02055 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
02056
02057 NTR_IR_TBL(asg_idx);
02058 IR_OPR(asg_idx) = Alt_Return_Opr;
02059 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
02060 IR_LINE_NUM(asg_idx) = line;
02061 IR_COL_NUM(asg_idx) = col;
02062 IR_LINE_NUM_L(asg_idx) = line;
02063 IR_COL_NUM_L(asg_idx) = col;
02064 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
02065 IR_IDX_L(asg_idx) = alt_return_tmp;
02066
02067 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
02068 IR_IDX_R(asg_idx) = ir_idx;
02069
02070 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
02071
02072 NTR_IR_TBL(br_idx_idx);
02073 IR_OPR(br_idx_idx) = Br_Index_Opr;
02074 IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE;
02075
02076 IR_FLD_L(br_idx_idx) = AT_Tbl_Idx;
02077 IR_IDX_L(br_idx_idx) = alt_return_tmp;
02078 IR_LINE_NUM(br_idx_idx) = line;
02079 IR_COL_NUM(br_idx_idx) = col;
02080 IR_LINE_NUM_L(br_idx_idx) = line;
02081 IR_COL_NUM_L(br_idx_idx) = col;
02082 IR_FLD_R(br_idx_idx) = IL_Tbl_Idx;
02083 IR_LIST_CNT_R(br_idx_idx) = 3;
02084
02085 NTR_IR_LIST_TBL(list_idx);
02086 IR_IDX_R(br_idx_idx) = list_idx;
02087
02088 if (err_list_idx) {
02089 COPY_OPND(IL_OPND(list_idx), IL_OPND(err_list_idx));
02090 }
02091 else {
02092 IL_FLD(list_idx) = AT_Tbl_Idx;
02093 IL_IDX(list_idx) = drop_thru_label_idx;
02094 IL_LINE_NUM(list_idx) = line;
02095 IL_COL_NUM(list_idx) = col;
02096 }
02097
02098 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02099 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02100 list_idx = IL_NEXT_LIST_IDX(list_idx);
02101
02102 if (end_list_idx) {
02103 COPY_OPND(IL_OPND(list_idx), IL_OPND(end_list_idx));
02104 }
02105 else {
02106 IL_FLD(list_idx) = AT_Tbl_Idx;
02107 IL_IDX(list_idx) = drop_thru_label_idx;
02108 IL_LINE_NUM(list_idx) = line;
02109 IL_COL_NUM(list_idx) = col;
02110 }
02111
02112 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02113 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02114 list_idx = IL_NEXT_LIST_IDX(list_idx);
02115
02116 if (eor_list_idx) {
02117 COPY_OPND(IL_OPND(list_idx), IL_OPND(eor_list_idx));
02118 }
02119 else {
02120 IL_FLD(list_idx) = AT_Tbl_Idx;
02121 IL_IDX(list_idx) = drop_thru_label_idx;
02122 IL_LINE_NUM(list_idx) = line;
02123 IL_COL_NUM(list_idx) = col;
02124 }
02125
02126 curr_stmt_sh_idx = save_next_sh_idx;
02127
02128 gen_sh(Before, If_Stmt, line, col, FALSE, TRUE, TRUE);
02129 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02130 SH_IR_IDX(curr_stmt_sh_idx) = br_idx_idx;
02131 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02132
02133 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02134
02135 }
02136 # endif
02137
02138 if (is_namelist) {
02139
02140 if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) {
02141 find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)),
02142 &line,
02143 &col);
02144 PRINTMSG(line, 444, Error, col);
02145 }
02146
02147 if (namelist_descriptor_attr) {
02148 # if 0
02149
02150
02151 {int _call_idx, _list_idx, _loc_idx;
02152 int _dump_nml_idx;
02153 _dump_nml_idx = create_lib_entry_attr("DUMP_NML",
02154 8,
02155 stmt_start_line,
02156 stmt_start_col);
02157
02158 ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx);
02159
02160 NTR_IR_TBL(_call_idx);
02161 IR_OPR(_call_idx) = Call_Opr;
02162 IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE;
02163 IR_LINE_NUM(_call_idx) = stmt_start_line;
02164 IR_COL_NUM(_call_idx) = stmt_start_col;
02165 IR_FLD_L(_call_idx) = AT_Tbl_Idx;
02166 IR_IDX_L(_call_idx) = _dump_nml_idx;
02167 IR_LINE_NUM_L(_call_idx) = stmt_start_line;
02168 IR_COL_NUM_L(_call_idx) = stmt_start_col;
02169
02170 NTR_IR_LIST_TBL(_list_idx);
02171 IR_FLD_R(_call_idx) = IL_Tbl_Idx;
02172 IR_IDX_R(_call_idx) = _list_idx;
02173 IR_LIST_CNT_R(_call_idx) = 1;
02174
02175 NTR_IR_TBL(_loc_idx);
02176 IR_OPR(_loc_idx) = Aloc_Opr;
02177 IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8;
02178 IR_LINE_NUM(_loc_idx) = stmt_start_line;
02179 IR_COL_NUM(_loc_idx) = stmt_start_col;
02180 IL_FLD(_list_idx) = IR_Tbl_Idx;
02181 IL_IDX(_list_idx) = _loc_idx;
02182
02183 IR_FLD_L(_loc_idx) = AT_Tbl_Idx;
02184 IR_IDX_L(_loc_idx) = namelist_descriptor_attr;
02185 IR_LINE_NUM_L(_loc_idx) = stmt_start_line;
02186 IR_COL_NUM_L(_loc_idx) = stmt_start_col;
02187
02188 gen_sh(Before, Call_Stmt, stmt_start_line,
02189 stmt_start_col, FALSE, FALSE, TRUE);
02190
02191 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = _call_idx;
02192 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02193 }
02194
02195 # endif
02196
02197 NTR_IR_LIST_TBL(list_idx);
02198 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
02199 IR_LIST_CNT_R(ir_idx) = 1;
02200 IR_IDX_R(ir_idx) = list_idx;
02201 NTR_IR_TBL(loc_idx);
02202 IR_OPR(loc_idx) = Loc_Opr;
02203 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
02204 IR_LINE_NUM(loc_idx) = stmt_start_line;
02205 IR_COL_NUM(loc_idx) = stmt_start_col;
02206 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
02207 IR_IDX_L(loc_idx) = namelist_descriptor_attr;
02208 IR_LINE_NUM_L(loc_idx) = stmt_start_line;
02209 IR_COL_NUM_L(loc_idx) = stmt_start_col;
02210 IL_FLD(list_idx) = IR_Tbl_Idx;
02211 IL_IDX(list_idx) = loc_idx;
02212 }
02213 }
02214 else {
02215 defer_stmt_expansion = TRUE;
02216 number_of_functions = 0;
02217 io_stmt_must_be_split = FALSE;
02218
02219 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02220 semantically_correct = io_list_semantics(&opnd, Read) &&
02221 semantically_correct;
02222 COPY_OPND(IR_OPND_R(ir_idx), opnd);
02223
02224 defer_stmt_expansion = FALSE;
02225
02226 # ifndef _NO_IO_ALTERNATE_RETURN
02227 if (semantically_correct &&
02228 io_stmt_must_be_split &&
02229 br_idx_idx != NULL_IDX) {
02230
02231
02232
02233
02234 jump_out_label = gen_internal_lbl(stmt_start_line);
02235
02236 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
02237
02238 NTR_IR_TBL(lab_idx);
02239 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx;
02240 IR_OPR(lab_idx) = Label_Opr;
02241 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE;
02242 IR_LINE_NUM(lab_idx) = line;
02243 IR_COL_NUM(lab_idx) = col;
02244 IR_FLD_L(lab_idx) = AT_Tbl_Idx;
02245 IR_IDX_L(lab_idx) = jump_out_label;
02246 IR_COL_NUM_L(lab_idx) = col;
02247 IR_LINE_NUM_L(lab_idx) = line;
02248 AT_DEFINED(jump_out_label) = TRUE;
02249 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx;
02250 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02251 ATL_DEF_STMT_IDX(jump_out_label) = curr_stmt_sh_idx;
02252
02253 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02254
02255 NTR_IR_TBL(br_true_idx);
02256 IR_OPR(br_true_idx) = Br_True_Opr;
02257 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
02258 IR_LINE_NUM(br_true_idx) = line;
02259 IR_COL_NUM(br_true_idx) = col;
02260
02261 NTR_IR_TBL(ne_idx);
02262 IR_OPR(ne_idx) = Ne_Opr;
02263 IR_TYPE_IDX(ne_idx) = LOGICAL_DEFAULT_TYPE;
02264 IR_LINE_NUM(ne_idx) = line;
02265 IR_COL_NUM(ne_idx) = col;
02266 IR_FLD_L(ne_idx) = AT_Tbl_Idx;
02267 IR_IDX_L(ne_idx) = alt_return_tmp;
02268 IR_LINE_NUM_L(ne_idx) = line;
02269 IR_COL_NUM_L(ne_idx) = col;
02270
02271 IR_FLD_R(ne_idx) = CN_Tbl_Idx;
02272 IR_IDX_R(ne_idx) = CN_INTEGER_ZERO_IDX;
02273 IR_LINE_NUM_R(ne_idx) = line;
02274 IR_COL_NUM_R(ne_idx) = col;
02275
02276 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
02277 IR_IDX_L(br_true_idx) = ne_idx;
02278
02279 IR_FLD_R(br_true_idx) = AT_Tbl_Idx;
02280 IR_IDX_R(br_true_idx) = jump_out_label;
02281 IR_LINE_NUM_R(br_true_idx) = line;
02282 IR_COL_NUM_R(br_true_idx) = col;
02283
02284 gen_sh(After, If_Stmt, line, col, FALSE, FALSE, TRUE);
02285
02286 SH_IR_IDX(curr_stmt_sh_idx) = br_true_idx;
02287 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02288
02289 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02290
02291 }
02292 # endif
02293
02294 if (semantically_correct &&
02295 (number_of_functions > 0 ||
02296 tree_has_constructor ||
02297 io_stmt_must_be_split ||
02298 io_item_must_flatten)) {
02299 process_deferred_io_list();
02300 }
02301 else if (semantically_correct) {
02302 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02303 gen_runtime_checks(&opnd);
02304 }
02305 }
02306
02307 TRACE (Func_Exit, "read_stmt_semantics", NULL);
02308
02309 return;
02310
02311 }
02312
02313
02314
02315
02316
02317
02318
02319
02320
02321
02322
02323
02324
02325
02326
02327
02328
02329
02330 void rewind_stmt_semantics (void)
02331
02332 {
02333 int ir_idx;
02334 opnd_type opnd;
02335 int save_arg_info_list_base;
02336 int save_curr_stmt_sh_idx;
02337 boolean semantically_correct;
02338
02339 # ifndef _NO_IO_ALTERNATE_RETURN
02340 int alt_return_tmp;
02341 int asg_idx;
02342 int br_true_idx;
02343 int col;
02344 int eq_idx;
02345 int line;
02346 int save_next_sh_idx;
02347 # endif
02348
02349
02350 TRACE (Func_Entry, "rewind_stmt_semantics", NULL);
02351
02352 SCP_DOES_IO(curr_scp_idx) = TRUE;
02353
02354 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
02355
02356
02357
02358 if (max_call_list_size >= arg_list_size) {
02359 enlarge_call_list_tables();
02360 }
02361
02362 save_arg_info_list_base = arg_info_list_base;
02363
02364 arg_info_list_base = arg_info_list_top;
02365
02366 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
02367
02368 if (arg_info_list_top >= arg_info_list_size) {
02369 enlarge_info_list_table();
02370 }
02371
02372 # ifndef _NO_IO_ALTERNATE_RETURN
02373 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
02374 # endif
02375
02376 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02377 semantically_correct = io_ctl_list_semantics(&opnd, Rewind, TRUE);
02378 COPY_OPND(IR_OPND_R(ir_idx), opnd);
02379
02380 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02381
02382 # ifndef _NO_IO_ALTERNATE_RETURN
02383
02384 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) {
02385
02386 line = IR_LINE_NUM(ir_idx);
02387 col = IR_COL_NUM(ir_idx);
02388
02389 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
02390 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
02391 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
02392 AT_REFERENCED(alt_return_tmp) = Referenced;
02393 AT_DEFINED(alt_return_tmp) = TRUE;
02394 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
02395
02396 NTR_IR_TBL(asg_idx);
02397 IR_OPR(asg_idx) = Alt_Return_Opr;
02398 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
02399 IR_LINE_NUM(asg_idx) = line;
02400 IR_COL_NUM(asg_idx) = col;
02401 IR_LINE_NUM_L(asg_idx) = line;
02402 IR_COL_NUM_L(asg_idx) = col;
02403 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
02404 IR_IDX_L(asg_idx) = alt_return_tmp;
02405 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
02406 IR_IDX_R(asg_idx) = ir_idx;
02407
02408 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
02409
02410 if (err_list_idx) {
02411 NTR_IR_TBL(br_true_idx);
02412 IR_OPR(br_true_idx) = Br_True_Opr;
02413 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
02414 IR_LINE_NUM(br_true_idx) = line;
02415 IR_COL_NUM(br_true_idx) = col;
02416
02417 NTR_IR_TBL(eq_idx);
02418 IR_OPR(eq_idx) = Eq_Opr;
02419 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE;
02420 IR_LINE_NUM(eq_idx) = line;
02421 IR_COL_NUM(eq_idx) = col;
02422 IR_FLD_L(eq_idx) = AT_Tbl_Idx;
02423 IR_IDX_L(eq_idx) = alt_return_tmp;
02424 IR_LINE_NUM_L(eq_idx) = line;
02425 IR_COL_NUM_L(eq_idx) = col;
02426
02427 IR_FLD_R(eq_idx) = CN_Tbl_Idx;
02428 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX;
02429 IR_LINE_NUM_R(eq_idx) = line;
02430 IR_COL_NUM_R(eq_idx) = col;
02431
02432 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
02433 IR_IDX_L(br_true_idx) = eq_idx;
02434
02435 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx));
02436
02437 curr_stmt_sh_idx = save_next_sh_idx;
02438
02439 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
02440
02441 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx;
02442 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02443
02444 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02445 }
02446 }
02447 # endif
02448
02449 if (semantically_correct) {
02450 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02451 semantically_correct = final_arg_work(&opnd,
02452 IR_IDX_L(ir_idx),
02453 IR_LIST_CNT_R(ir_idx),
02454 NULL);
02455 COPY_OPND(IR_OPND_R(ir_idx), opnd);
02456 # if defined(_FILE_IO_OPRS)
02457 IR_OPR(ir_idx) = Rewind_Opr;
02458 # endif
02459 }
02460
02461 # ifdef _NO_IO_ALTERNATE_RETURN
02462 add_alt_return_lbl(ir_idx, err_attr_idx);
02463 # endif
02464
02465
02466
02467 arg_info_list_top = arg_info_list_base;
02468 arg_info_list_base = save_arg_info_list_base;
02469
02470 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02471
02472 TRACE (Func_Exit, "rewind_stmt_semantics", NULL);
02473
02474 return;
02475
02476 }
02477
02478
02479
02480
02481
02482
02483
02484
02485
02486
02487
02488
02489
02490
02491
02492
02493
02494
02495 void write_stmt_semantics (void)
02496
02497 {
02498 int col;
02499 int ir_idx;
02500 int line;
02501 int list_idx;
02502 int loc_idx;
02503 opnd_type opnd;
02504 boolean semantically_correct;
02505
02506 # ifndef _NO_IO_ALTERNATE_RETURN
02507 int alt_return_tmp;
02508 int asg_idx;
02509 int br_idx_idx = NULL_IDX;
02510 int br_true_idx;
02511 int drop_thru_label_idx;
02512 int jump_out_label;
02513 int lab_idx;
02514 int ne_idx;
02515 int save_curr_stmt_sh_idx;
02516 int save_next_sh_idx;
02517 # endif
02518
02519
02520 TRACE (Func_Entry, "write_stmt_semantics", NULL);
02521
02522 SCP_DOES_IO(curr_scp_idx) = TRUE;
02523
02524 # ifndef _NO_IO_ALTERNATE_RETURN
02525 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
02526 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
02527 # endif
02528
02529 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
02530
02531 COPY_OPND(opnd, IR_OPND_L(ir_idx));
02532 semantically_correct = io_ctl_list_semantics(&opnd, Write, FALSE);
02533 COPY_OPND(IR_OPND_L(ir_idx), opnd);
02534
02535 line = IR_LINE_NUM(ir_idx);
02536 col = IR_COL_NUM(ir_idx);
02537
02538 # ifndef _NO_IO_ALTERNATE_RETURN
02539 if (have_iostat ||
02540 end_list_idx != NULL_IDX ||
02541 err_list_idx != NULL_IDX ||
02542 eor_list_idx != NULL_IDX) {
02543
02544 if (end_list_idx == NULL_IDX ||
02545 err_list_idx == NULL_IDX ||
02546 eor_list_idx == NULL_IDX) {
02547
02548
02549
02550 drop_thru_label_idx = gen_internal_lbl(stmt_start_line);
02551
02552 curr_stmt_sh_idx = save_next_sh_idx;
02553
02554 gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
02555
02556 NTR_IR_TBL(lab_idx);
02557 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = lab_idx;
02558 IR_OPR(lab_idx) = Label_Opr;
02559 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE;
02560 IR_LINE_NUM(lab_idx) = line;
02561 IR_COL_NUM(lab_idx) = col;
02562 IR_FLD_L(lab_idx) = AT_Tbl_Idx;
02563 IR_IDX_L(lab_idx) = drop_thru_label_idx;
02564 IR_COL_NUM_L(lab_idx) = col;
02565 IR_LINE_NUM_L(lab_idx) = line;
02566
02567 AT_DEFINED(drop_thru_label_idx) = TRUE;
02568 ATL_DEF_STMT_IDX(drop_thru_label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
02569
02570 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02571 save_next_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02572
02573 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02574 }
02575
02576 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
02577 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
02578 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
02579 AT_REFERENCED(alt_return_tmp) = Referenced;
02580 AT_DEFINED(alt_return_tmp) = TRUE;
02581 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
02582
02583 NTR_IR_TBL(asg_idx);
02584 IR_OPR(asg_idx) = Alt_Return_Opr;
02585 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
02586 IR_LINE_NUM(asg_idx) = line;
02587 IR_COL_NUM(asg_idx) = col;
02588 IR_LINE_NUM_L(asg_idx) = line;
02589 IR_COL_NUM_L(asg_idx) = col;
02590 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
02591 IR_IDX_L(asg_idx) = alt_return_tmp;
02592
02593 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
02594 IR_IDX_R(asg_idx) = ir_idx;
02595
02596 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
02597
02598 NTR_IR_TBL(br_idx_idx);
02599 IR_OPR(br_idx_idx) = Br_Index_Opr;
02600 IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE;
02601
02602 IR_FLD_L(br_idx_idx) = AT_Tbl_Idx;
02603 IR_IDX_L(br_idx_idx) = alt_return_tmp;
02604 IR_LINE_NUM(br_idx_idx) = line;
02605 IR_COL_NUM(br_idx_idx) = col;
02606 IR_LINE_NUM_L(br_idx_idx) = line;
02607 IR_COL_NUM_L(br_idx_idx) = col;
02608 IR_FLD_R(br_idx_idx) = IL_Tbl_Idx;
02609 IR_LIST_CNT_R(br_idx_idx) = 3;
02610
02611 NTR_IR_LIST_TBL(list_idx);
02612 IR_IDX_R(br_idx_idx) = list_idx;
02613
02614 if (err_list_idx) {
02615 COPY_OPND(IL_OPND(list_idx), IL_OPND(err_list_idx));
02616 }
02617 else {
02618 IL_FLD(list_idx) = AT_Tbl_Idx;
02619 IL_IDX(list_idx) = drop_thru_label_idx;
02620 IL_LINE_NUM(list_idx) = line;
02621 IL_COL_NUM(list_idx) = col;
02622 }
02623
02624 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02625 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02626 list_idx = IL_NEXT_LIST_IDX(list_idx);
02627
02628 if (end_list_idx) {
02629 COPY_OPND(IL_OPND(list_idx), IL_OPND(end_list_idx));
02630 }
02631 else {
02632 IL_FLD(list_idx) = AT_Tbl_Idx;
02633 IL_IDX(list_idx) = drop_thru_label_idx;
02634 IL_LINE_NUM(list_idx) = line;
02635 IL_COL_NUM(list_idx) = col;
02636 }
02637
02638 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02639 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02640 list_idx = IL_NEXT_LIST_IDX(list_idx);
02641
02642 if (eor_list_idx) {
02643 COPY_OPND(IL_OPND(list_idx), IL_OPND(eor_list_idx));
02644 }
02645 else {
02646 IL_FLD(list_idx) = AT_Tbl_Idx;
02647 IL_IDX(list_idx) = drop_thru_label_idx;
02648 IL_LINE_NUM(list_idx) = line;
02649 IL_COL_NUM(list_idx) = col;
02650 }
02651
02652 curr_stmt_sh_idx = save_next_sh_idx;
02653
02654 gen_sh(Before, If_Stmt, line, col, FALSE, TRUE, TRUE);
02655 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02656 SH_IR_IDX(curr_stmt_sh_idx) = br_idx_idx;
02657 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02658
02659 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
02660
02661 }
02662 # endif
02663
02664 if (is_namelist) {
02665
02666 if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) {
02667 find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)),
02668 &line,
02669 &col);
02670 PRINTMSG(line, 444, Error, col);
02671 }
02672
02673 if (namelist_descriptor_attr) {
02674 # if 0
02675
02676
02677 {int _call_idx, _list_idx, _loc_idx;
02678 int _dump_nml_idx;
02679 _dump_nml_idx = create_lib_entry_attr("DUMP_NML",
02680 8,
02681 stmt_start_line,
02682 stmt_start_col);
02683
02684 ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx);
02685
02686 NTR_IR_TBL(_call_idx);
02687 IR_OPR(_call_idx) = Call_Opr;
02688 IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE;
02689 IR_LINE_NUM(_call_idx) = stmt_start_line;
02690 IR_COL_NUM(_call_idx) = stmt_start_col;
02691 IR_FLD_L(_call_idx) = AT_Tbl_Idx;
02692 IR_IDX_L(_call_idx) = _dump_nml_idx;
02693 IR_LINE_NUM_L(_call_idx) = stmt_start_line;
02694 IR_COL_NUM_L(_call_idx) = stmt_start_col;
02695
02696 NTR_IR_LIST_TBL(_list_idx);
02697 IR_FLD_R(_call_idx) = IL_Tbl_Idx;
02698 IR_IDX_R(_call_idx) = _list_idx;
02699 IR_LIST_CNT_R(_call_idx) = 1;
02700
02701 NTR_IR_TBL(_loc_idx);
02702 IR_OPR(_loc_idx) = Aloc_Opr;
02703 IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8;
02704 IR_LINE_NUM(_loc_idx) = stmt_start_line;
02705 IR_COL_NUM(_loc_idx) = stmt_start_col;
02706 IL_FLD(_list_idx) = IR_Tbl_Idx;
02707 IL_IDX(_list_idx) = _loc_idx;
02708
02709 IR_FLD_L(_loc_idx) = AT_Tbl_Idx;
02710 IR_IDX_L(_loc_idx) = namelist_descriptor_attr;
02711 IR_LINE_NUM_L(_loc_idx) = stmt_start_line;
02712 IR_COL_NUM_L(_loc_idx) = stmt_start_col;
02713
02714 gen_sh(Before, Call_Stmt, stmt_start_line,
02715 stmt_start_col, FALSE, FALSE, TRUE);
02716
02717 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = _call_idx;
02718 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02719 }
02720
02721 # endif
02722
02723 NTR_IR_LIST_TBL(list_idx);
02724 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
02725 IR_LIST_CNT_R(ir_idx) = 1;
02726 IR_IDX_R(ir_idx) = list_idx;
02727 NTR_IR_TBL(loc_idx);
02728 IR_OPR(loc_idx) = Loc_Opr;
02729 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
02730 IR_LINE_NUM(loc_idx) = stmt_start_line;
02731 IR_COL_NUM(loc_idx) = stmt_start_col;
02732 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
02733 IR_IDX_L(loc_idx) = namelist_descriptor_attr;
02734 IR_LINE_NUM_L(loc_idx) = stmt_start_line;
02735 IR_COL_NUM_L(loc_idx) = stmt_start_col;
02736 IL_FLD(list_idx) = IR_Tbl_Idx;
02737 IL_IDX(list_idx) = loc_idx;
02738 }
02739 }
02740 else {
02741 defer_stmt_expansion = TRUE;
02742 number_of_functions = 0;
02743 io_stmt_must_be_split = FALSE;
02744
02745 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02746 semantically_correct = io_list_semantics(&opnd, Write) &&
02747 semantically_correct;
02748 COPY_OPND(IR_OPND_R(ir_idx), opnd);
02749
02750 defer_stmt_expansion = FALSE;
02751
02752 # ifndef _NO_IO_ALTERNATE_RETURN
02753 if (semantically_correct &&
02754 io_stmt_must_be_split &&
02755 br_idx_idx != NULL_IDX) {
02756
02757
02758
02759
02760 jump_out_label = gen_internal_lbl(stmt_start_line);
02761
02762 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
02763
02764 NTR_IR_TBL(lab_idx);
02765 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx;
02766 IR_OPR(lab_idx) = Label_Opr;
02767 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE;
02768 IR_LINE_NUM(lab_idx) = line;
02769 IR_COL_NUM(lab_idx) = col;
02770 IR_FLD_L(lab_idx) = AT_Tbl_Idx;
02771 IR_IDX_L(lab_idx) = jump_out_label;
02772 IR_COL_NUM_L(lab_idx) = col;
02773 IR_LINE_NUM_L(lab_idx) = line;
02774 AT_DEFINED(jump_out_label) = TRUE;
02775 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx;
02776 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02777 ATL_DEF_STMT_IDX(jump_out_label) = curr_stmt_sh_idx;
02778
02779 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02780
02781 NTR_IR_TBL(br_true_idx);
02782 IR_OPR(br_true_idx) = Br_True_Opr;
02783 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE;
02784 IR_LINE_NUM(br_true_idx) = line;
02785 IR_COL_NUM(br_true_idx) = col;
02786
02787 NTR_IR_TBL(ne_idx);
02788 IR_OPR(ne_idx) = Ne_Opr;
02789 IR_TYPE_IDX(ne_idx) = LOGICAL_DEFAULT_TYPE;
02790 IR_LINE_NUM(ne_idx) = line;
02791 IR_COL_NUM(ne_idx) = col;
02792 IR_FLD_L(ne_idx) = AT_Tbl_Idx;
02793 IR_IDX_L(ne_idx) = alt_return_tmp;
02794 IR_LINE_NUM_L(ne_idx) = line;
02795 IR_COL_NUM_L(ne_idx) = col;
02796
02797 IR_FLD_R(ne_idx) = CN_Tbl_Idx;
02798 IR_IDX_R(ne_idx) = CN_INTEGER_ZERO_IDX;
02799 IR_LINE_NUM_R(ne_idx) = line;
02800 IR_COL_NUM_R(ne_idx) = col;
02801
02802 IR_FLD_L(br_true_idx) = IR_Tbl_Idx;
02803 IR_IDX_L(br_true_idx) = ne_idx;
02804
02805 IR_FLD_R(br_true_idx) = AT_Tbl_Idx;
02806 IR_IDX_R(br_true_idx) = jump_out_label;
02807 IR_LINE_NUM_R(br_true_idx) = line;
02808 IR_COL_NUM_R(br_true_idx) = col;
02809
02810 gen_sh(After, If_Stmt, line, col, FALSE, FALSE, TRUE);
02811
02812 SH_IR_IDX(curr_stmt_sh_idx) = br_true_idx;
02813 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02814
02815 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
02816
02817 }
02818 # endif
02819
02820 if (semantically_correct &&
02821 (number_of_functions > 0 ||
02822 tree_has_constructor ||
02823 io_stmt_must_be_split ||
02824 io_item_must_flatten)) {
02825 process_deferred_io_list();
02826 }
02827 else if (semantically_correct) {
02828 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02829 gen_runtime_checks(&opnd);
02830 }
02831 }
02832
02833 TRACE (Func_Exit, "write_stmt_semantics", NULL);
02834
02835 return;
02836
02837 }
02838
02839
02840
02841
02842
02843
02844
02845
02846
02847
02848
02849
02850
02851
02852
02853
02854
02855
02856 static boolean io_ctl_list_semantics(opnd_type *list_opnd,
02857 io_stmt_type io_type,
02858 boolean is_call)
02859
02860 {
02861 int attr_idx;
02862 int ciitem_idx;
02863 int col;
02864 long_type constant_value;
02865 int err_idx;
02866 expr_arg_type exp_desc;
02867 boolean default_kind;
02868 boolean format_expected;
02869 int free_list_idx;
02870 int i;
02871 int info_idx;
02872 boolean internal_file = FALSE;
02873 char io_type_string[16];
02874 int k;
02875 opnd_type left_opnd;
02876 int line;
02877 int list_array[MAX_NUM_CIITEM + 1];
02878 int list_idx;
02879 boolean match;
02880 boolean namelist_expected;
02881 opnd_type opnd;
02882 int pp_tmp = NULL_IDX;
02883 boolean semantically_correct = TRUE;
02884 int tmp_idx;
02885
02886 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
02887 int ir_idx;
02888 # endif
02889
02890
02891 TRACE (Func_Entry, "io_ctl_list_semantics", NULL);
02892
02893 list_directed = FALSE;
02894
02895 io_type_string[0] = '\0';
02896 strcat(io_type_string, io_stmt_str[io_type]);
02897
02898 end_list_idx = NULL_IDX;
02899 err_list_idx = NULL_IDX;
02900 err_attr_idx = NULL_IDX;
02901 eor_list_idx = NULL_IDX;
02902 have_iostat = FALSE;
02903
02904 if (io_type == Print) {
02905 io_type = Write;
02906 }
02907
02908 if (io_type == Inquire) {
02909 err_idx = INQ_ERR_IDX;
02910 }
02911 else {
02912 err_idx = ERR_IDX;
02913 }
02914
02915 is_namelist = FALSE;
02916
02917 list_idx = OPND_IDX((*list_opnd));
02918
02919 info_idx = arg_info_list_base;
02920
02921 for (i = 1; i <= OPND_LIST_CNT((*list_opnd)); i++) {
02922
02923 info_idx++;
02924
02925 list_array[i] = list_idx;
02926
02927 format_expected = IL_FORMAT_EXPECTED(list_idx);
02928 namelist_expected = IL_NAMELIST_EXPECTED(list_idx);
02929
02930 if (IL_FLD(list_idx) == NO_Tbl_Idx) {
02931 list_idx = IL_NEXT_LIST_IDX(list_idx);
02932 continue;
02933 }
02934 else if (IL_FLD(list_idx) == CN_Tbl_Idx &&
02935 IL_IDX(list_idx) == NULL_IDX) {
02936
02937
02938 if (i == 1) {
02939
02940
02941
02942 IL_FLD(list_idx) = NO_Tbl_Idx;
02943 }
02944 else if (i == 2) {
02945
02946 list_directed = TRUE;
02947
02948 }
02949 # ifdef _DEBUG
02950 else {
02951 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02952 &line,
02953 &col);
02954 PRINTMSG(line, 762, Internal, col);
02955 }
02956 # endif
02957 list_idx = IL_NEXT_LIST_IDX(list_idx);
02958 continue;
02959 }
02960 else if (i == FMT_IDX &&
02961 IL_FLD(list_idx) == IL_Tbl_Idx) {
02962
02963
02964
02965
02966
02967 pp_tmp = IL_IDX(IL_NEXT_LIST_IDX(IL_IDX(list_idx)));
02968 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(list_idx)));
02969 free_list_idx = IL_IDX(list_idx);
02970 COPY_OPND(IL_OPND(list_idx), IL_OPND(IL_IDX(list_idx)));
02971 FREE_IR_LIST_NODE(free_list_idx);
02972
02973 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
02974 ADD_TMP_TO_SHARED_LIST(pp_tmp);
02975
02976 list_idx = IL_NEXT_LIST_IDX(list_idx);
02977 continue;
02978 }
02979
02980 ciitem_idx = arg_idx_tbl[io_type][i];
02981
02982 exp_desc.rank = 0;
02983 COPY_OPND(opnd, IL_OPND(list_idx));
02984
02985 if (i == NML_IDX) {
02986 namelist_illegal = FALSE;
02987 }
02988
02989 io_item_must_flatten = FALSE;
02990
02991 if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form
02992 == Var_Only_Form) {
02993 xref_state = CIF_Symbol_Modification;
02994 }
02995 else if (i == FMT_IDX &&
02996 IL_FLD(list_idx) == AT_Tbl_Idx &&
02997 AT_OBJ_CLASS(IL_IDX(list_idx)) == Label) {
02998
02999 xref_state = CIF_No_Usage_Rec;
03000 }
03001 else {
03002 xref_state = CIF_Symbol_Reference;
03003 }
03004
03005 if (i == UNIT_IDX) {
03006 in_call_list = TRUE;
03007 }
03008
03009 if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form
03010 == Label_Form ||
03011 ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form
03012 == Format_Form) {
03013
03014 label_allowed = TRUE;
03015 }
03016
03017 if (!expr_semantics(&opnd, &exp_desc)) {
03018 namelist_illegal = TRUE;
03019 label_allowed = FALSE;
03020 semantically_correct = FALSE;
03021 list_idx = IL_NEXT_LIST_IDX(list_idx);
03022 in_call_list = FALSE;
03023 continue;
03024 }
03025
03026 in_call_list = FALSE;
03027 label_allowed = FALSE;
03028
03029 COPY_OPND(IL_OPND(list_idx), opnd);
03030
03031 namelist_illegal = TRUE;
03032
03033 if (! is_call) {
03034
03035 if (io_item_must_flatten ||
03036 exp_desc.dist_reshape_ref ||
03037 exp_desc.vector_subscript) {
03038
03039 tmp_idx = create_tmp_asg(&opnd, &exp_desc, &left_opnd,
03040 Intent_In, TRUE, FALSE);
03041 COPY_OPND(IL_OPND(list_idx), left_opnd);
03042 }
03043 }
03044 else {
03045 arg_info_list[info_idx] = init_arg_info;
03046 arg_info_list[info_idx].ed = exp_desc;
03047 arg_info_list[info_idx].maybe_modified = TRUE;
03048 IL_ARG_DESC_IDX(list_idx) = info_idx;
03049 }
03050
03051 if (exp_desc.rank != 0 &&
03052 i != FMT_IDX &&
03053 exp_desc.type != Character) {
03054
03055 find_opnd_line_and_column(&opnd, &line, &col);
03056 PRINTMSG(line, 449, Error, col,
03057 exp_desc.rank,
03058 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name);
03059 semantically_correct = FALSE;
03060 }
03061
03062 if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].scalar &&
03063 exp_desc.rank > 0) {
03064
03065 find_opnd_line_and_column(&opnd, &line, &col);
03066 PRINTMSG(line, 1113, Error, col,
03067 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name);
03068 semantically_correct = FALSE;
03069 }
03070
03071 switch (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form) {
03072 case Exp_Form :
03073
03074 match = FALSE;
03075
03076 for (k = 0;
03077 k < ciitem_tbl[io_type].ciitem_list[ciitem_idx].num_types;
03078 k++){
03079
03080 if (exp_desc.type ==
03081 ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03082 allowed_types[k]) {
03083 match = TRUE;
03084 break;
03085 }
03086 }
03087
03088 find_opnd_line_and_column(&opnd, &line, &col);
03089
03090 if (!match) {
03091 PRINTMSG(line, 441, Error, col,
03092 get_basic_type_str(exp_desc.type_idx),
03093 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03094 io_type_string);
03095
03096 semantically_correct = FALSE;
03097 }
03098 else if (exp_desc.type == Typeless) {
03099
03100 if (exp_desc.linear_type == Long_Typeless) {
03101 find_opnd_line_and_column(&opnd, &line, &col);
03102 PRINTMSG(line, 1133, Error, col);
03103 semantically_correct = FALSE;
03104 }
03105 else if (exp_desc.linear_type == Short_Typeless_Const) {
03106 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
03107 INTEGER_DEFAULT_TYPE,
03108 line,
03109 col);
03110 exp_desc.linear_type = INTEGER_DEFAULT_TYPE;
03111 exp_desc.type_idx = INTEGER_DEFAULT_TYPE;
03112 exp_desc.type = Integer;
03113 COPY_OPND(opnd, IL_OPND(list_idx));
03114 }
03115 }
03116 else if (exp_desc.type == Character &&
03117 ! exp_desc.constant &&
03118 ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03119 allowed_types[0] == Integer &&
03120 (io_type == Rewind ||
03121 io_type == Backspace ||
03122 io_type == Endfile)) {
03123
03124
03125
03126
03127 PRINTMSG(line, 441, Error, col,
03128 get_basic_type_str(exp_desc.type_idx),
03129 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03130 io_type_string);
03131
03132 semantically_correct = FALSE;
03133
03134 }
03135 else if (exp_desc.type == Character &&
03136 exp_desc.constant &&
03137 ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03138 allowed_types[0] == Integer) {
03139
03140
03141
03142
03143
03144
03145 # ifdef _DEBUG
03146 if (strcmp(ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03147 "UNIT") != 0) {
03148 PRINTMSG(line, 606, Internal, col);
03149 }
03150 # endif
03151
03152 if (compare_cn_and_value(TYP_IDX(exp_desc.type_idx),
03153 TARGET_BYTES_PER_WORD,
03154 Lt_Opr)) {
03155
03156
03157
03158
03159 constant_value = (long_type) CN_INT_TO_C(OPND_IDX(opnd));
03160 IL_IDX(list_idx) = ntr_const_tbl(TYPELESS_DEFAULT_TYPE,
03161 FALSE,
03162 &constant_value);
03163
03164 exp_desc.type = Typeless;
03165 exp_desc.linear_type = TYPELESS_DEFAULT_TYPE;
03166 exp_desc.type_idx = TYPELESS_DEFAULT_TYPE;
03167
03168 PRINTMSG(line, 485, Ansi, col);
03169
03170 if (is_call) {
03171 arg_info_list[info_idx].ed = exp_desc;
03172 }
03173 }
03174 else {
03175 PRINTMSG(line, 216, Error, col,
03176 TARGET_BYTES_PER_WORD);
03177 semantically_correct = FALSE;
03178 }
03179 }
03180
03181 if (semantically_correct) {
03182
03183 COPY_OPND(opnd, IL_OPND(list_idx));
03184 cast_to_cg_default(&opnd, &exp_desc);
03185 COPY_OPND(IL_OPND(list_idx), opnd);
03186
03187 if (is_call) {
03188 arg_info_list[info_idx].ed = exp_desc;
03189 }
03190 }
03191
03192 if (is_call) {
03193 arg_info_list[info_idx].maybe_modified = FALSE;
03194 }
03195 break;
03196
03197 case Label_Form :
03198
03199 if (i == err_idx) {
03200 err_list_idx = list_idx;
03201 err_attr_idx = IL_IDX(list_idx);
03202 }
03203 else if (i == END_IDX) {
03204 end_list_idx = list_idx;
03205 }
03206 else if (i == EOR_IDX) {
03207 eor_list_idx = list_idx;
03208 }
03209
03210 if (OPND_FLD(opnd) == AT_Tbl_Idx &&
03211 AT_OBJ_CLASS(OPND_IDX(opnd)) == Label) {
03212 }
03213 else {
03214 find_opnd_line_and_column(&opnd, &line, &col);
03215 PRINTMSG(line, 448, Error, col);
03216 semantically_correct = FALSE;
03217 }
03218
03219 break;
03220
03221 case Namelist_Form :
03222
03223
03224 break;
03225
03226 case Var_Only_Form :
03227
03228 find_opnd_line_and_column(&opnd, &line, &col);
03229
03230 if (exp_desc.reference) {
03231
03232 default_kind = TRUE;
03233 switch (exp_desc.type) {
03234 case Integer :
03235 default_kind = (exp_desc.linear_type == INTEGER_DEFAULT_TYPE);
03236 break;
03237
03238 case Logical :
03239 default_kind = (exp_desc.linear_type == LOGICAL_DEFAULT_TYPE);
03240 break;
03241 case Real :
03242 default_kind = (exp_desc.linear_type == REAL_DEFAULT_TYPE);
03243 break;
03244 case Complex :
03245 default_kind = (exp_desc.linear_type == COMPLEX_DEFAULT_TYPE);
03246 break;
03247 case Character :
03248 default_kind = TRUE;
03249 break;
03250 }
03251
03252 if (exp_desc.type != ciitem_tbl[io_type].ciitem_list[ciitem_idx].
03253 allowed_types[0]) {
03254 PRINTMSG(line, 459, Error, col,
03255 get_basic_type_str(exp_desc.type_idx),
03256 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03257 io_type_string);
03258
03259 semantically_correct = FALSE;
03260 }
03261 else if (!default_kind) {
03262 PRINTMSG(line, 461, Error, col,
03263 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03264 io_type_string);
03265 semantically_correct = FALSE;
03266 }
03267 else if (! check_for_legal_define(&opnd)) {
03268 semantically_correct = FALSE;
03269 }
03270 else {
03271
03272 attr_idx = find_left_attr(&opnd);
03273
03274 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03275 if ((exp_desc.type == Integer &&
03276 storage_bit_size_tbl[exp_desc.linear_type] !=
03277 storage_bit_size_tbl[
03278 TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)]) ||
03279 (exp_desc.type == Logical &&
03280 storage_bit_size_tbl[exp_desc.linear_type] !=
03281 storage_bit_size_tbl[
03282 TYP_LINEAR(CG_LOGICAL_DEFAULT_TYPE)])) {
03283
03284
03285
03286
03287 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
03288
03289 if (exp_desc.type == Integer) {
03290 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE;
03291 }
03292 else {
03293 ATD_TYPE_IDX(tmp_idx) = CG_LOGICAL_DEFAULT_TYPE;
03294 }
03295
03296 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03297 AT_SEMANTICS_DONE(tmp_idx)= TRUE;
03298
03299
03300 NTR_IR_TBL(ir_idx);
03301 IR_OPR(ir_idx) = Asg_Opr;
03302 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(tmp_idx);
03303 IR_LINE_NUM(ir_idx) = line;
03304 IR_COL_NUM(ir_idx) = col;
03305
03306 IR_FLD_R(ir_idx) = AT_Tbl_Idx;
03307 IR_IDX_R(ir_idx) = tmp_idx;
03308 IR_LINE_NUM_R(ir_idx) = line;
03309 IR_COL_NUM_R(ir_idx) = col;
03310
03311 COPY_OPND(IR_OPND_L(ir_idx), opnd);
03312 gen_sh(After, Assignment_Stmt, line,
03313 col, FALSE, FALSE, TRUE);
03314 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
03315 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
03316 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03317
03318 IL_FLD(list_idx) = AT_Tbl_Idx;
03319 IL_IDX(list_idx) = tmp_idx;
03320 IL_LINE_NUM(list_idx) = line;
03321 IL_COL_NUM(list_idx) = col;
03322
03323 COPY_OPND(opnd, IL_OPND(list_idx));
03324
03325 exp_desc.tmp_reference = TRUE;
03326 exp_desc.type_idx = ATD_TYPE_IDX(tmp_idx);
03327 exp_desc.linear_type = TYP_LINEAR(ATD_TYPE_IDX(tmp_idx));
03328
03329 if (is_call) {
03330 arg_info_list[info_idx].ed = exp_desc;
03331 }
03332
03333 }
03334 # endif
03335 }
03336 }
03337 else {
03338 PRINTMSG(line, 460, Error, col,
03339 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name,
03340 basic_type_str[ciitem_tbl[io_type].
03341 ciitem_list[ciitem_idx].allowed_types[0]],
03342 io_type_string);
03343 semantically_correct = FALSE;
03344 }
03345
03346 break;
03347
03348 case Format_Form :
03349
03350
03351
03352 find_opnd_line_and_column(&opnd, &line, &col);
03353
03354 if (!format_expected &&
03355 OPND_FLD(opnd) == AT_Tbl_Idx &&
03356 AT_OBJ_CLASS(OPND_IDX(opnd)) == Namelist_Grp) {
03357 is_namelist = TRUE;
03358
03359 if (io_type == Read) {
03360 semantically_correct = do_read_namelist_semantics(&opnd)
03361 && semantically_correct;
03362 }
03363 else {
03364 do_write_namelist_semantics(&opnd);
03365 }
03366
03367 if (ATN_NAMELIST_DESC(OPND_IDX(opnd)) == NULL_IDX) {
03368 create_namelist_descriptor(OPND_IDX(opnd));
03369 }
03370
03371 namelist_descriptor_attr = ATN_NAMELIST_DESC(OPND_IDX(opnd));
03372
03373 ADD_TMP_TO_SHARED_LIST(namelist_descriptor_attr);
03374
03375 }
03376 else if (namelist_expected) {
03377
03378
03379
03380 PRINTMSG(line, 446, Error, col);
03381 semantically_correct = FALSE;
03382
03383 is_namelist = TRUE;
03384 }
03385 else if (OPND_FLD(opnd) == AT_Tbl_Idx &&
03386 AT_OBJ_CLASS(OPND_IDX(opnd)) == Label) {
03387
03388 if (ATL_CLASS(OPND_IDX(opnd)) == Lbl_Format) {
03389
03390 IL_IDX(list_idx) = ATL_FORMAT_TMP(OPND_IDX(opnd));
03391 IL_FLD(list_idx) = AT_Tbl_Idx;
03392 IL_LINE_NUM(list_idx) = line;
03393 IL_COL_NUM(list_idx) = col;
03394
03395 pp_tmp = ATL_PP_FORMAT_TMP(OPND_IDX(opnd));
03396
03397 ADD_TMP_TO_SHARED_LIST(ATL_FORMAT_TMP(OPND_IDX(opnd)));
03398 ADD_TMP_TO_SHARED_LIST(ATL_PP_FORMAT_TMP(OPND_IDX(opnd)));
03399 }
03400
03401
03402
03403 }
03404 else if (exp_desc.type == Character) {
03405
03406 }
03407 else if (exp_desc.rank > 0 &&
03408 (OPND_FLD(opnd) != IR_Tbl_Idx ||
03409 exp_desc.dope_vector ||
03410 IR_OPR(OPND_IDX(opnd)) != Whole_Subscript_Opr)) {
03411
03412
03413
03414
03415 PRINTMSG(line, 447, Error, col);
03416 semantically_correct = FALSE;
03417 }
03418 else if (exp_desc.type == Integer &&
03419 exp_desc.reference) {
03420
03421 if (exp_desc.rank == 0) {
03422
03423 if (!exp_desc.reference) {
03424 PRINTMSG(line, 447, Error, col);
03425 semantically_correct = FALSE;
03426 }
03427 else if (exp_desc.linear_type != INTEGER_DEFAULT_TYPE) {
03428
03429
03430
03431 PRINTMSG(line, 462, Error, col);
03432 semantically_correct = FALSE;
03433 }
03434 else {
03435
03436 attr_idx = find_base_attr(&opnd, &line, &col);
03437
03438 if (! ATD_IN_ASSIGN(attr_idx)) {
03439 PRINTMSG(line, 1099, Error, col);
03440 }
03441
03442 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03443 if (ATD_ASSIGN_TMP_IDX(attr_idx) != NULL_IDX) {
03444 OPND_FLD(opnd) = AT_Tbl_Idx;
03445 OPND_IDX(opnd) = ATD_ASSIGN_TMP_IDX(attr_idx);
03446 COPY_OPND(IL_OPND(list_idx), opnd);
03447 ADD_TMP_TO_SHARED_LIST(ATD_ASSIGN_TMP_IDX(attr_idx));
03448 }
03449 # endif
03450 }
03451 }
03452 else {
03453 PRINTMSG(line, 778, Ansi, col);
03454 }
03455 }
03456 else if ((exp_desc.linear_type == REAL_DEFAULT_TYPE ||
03457 exp_desc.type == Logical) &&
03458 exp_desc.reference &&
03459 exp_desc.rank > 0) {
03460 PRINTMSG(line, 778, Ansi, col);
03461 }
03462 else if (exp_desc.type == Typeless &&
03463 exp_desc.rank == 0) {
03464
03465
03466
03467 }
03468 else {
03469 PRINTMSG(line, 447, Error, col);
03470 semantically_correct = FALSE;
03471 }
03472
03473 break;
03474 }
03475
03476
03477
03478
03479 if (io_type == Read || io_type == Write) {
03480
03481 if (i == UNIT_IDX) {
03482
03483 if (exp_desc.type == Character &&
03484 !exp_desc.constant &&
03485 exp_desc.reference) {
03486
03487 internal_file = TRUE;
03488
03489 if (io_type == Write) {
03490 mark_attr_defined(&opnd);
03491
03492 if (! check_for_legal_define(&opnd)) {
03493 semantically_correct = FALSE;
03494 }
03495 }
03496
03497 if (exp_desc.vector_subscript) {
03498 find_opnd_line_and_column(&opnd, &line, &col);
03499 PRINTMSG(line, 467, Error, col);
03500 semantically_correct = FALSE;
03501 }
03502 else if (OPND_FLD(opnd) == AT_Tbl_Idx &&
03503 ATD_ARRAY_IDX(OPND_IDX(opnd)) != NULL_IDX &&
03504 BD_ARRAY_CLASS(ATD_ARRAY_IDX(OPND_IDX(opnd))) ==
03505 Assumed_Size) {
03506
03507 PRINTMSG(line, 1302, Ansi, col);
03508 }
03509 }
03510 }
03511 }
03512
03513 list_idx = IL_NEXT_LIST_IDX(list_idx);
03514 }
03515
03516
03517
03518
03519 if (internal_file && is_namelist) {
03520 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_array[FMT_IDX]),
03521 &line, &col);
03522 PRINTMSG(line, 472, Error, col);
03523 semantically_correct = FALSE;
03524 }
03525
03526 if (is_call) {
03527
03528 for (k = 1; k <= OPND_LIST_CNT((*list_opnd)); k++) {
03529 arg_list[k] = list_array[k];
03530 }
03531 }
03532 else {
03533
03534
03535
03536
03537 if (!internal_file &&
03538 (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
03539 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) &&
03540 (io_type == Read || io_type == Write)) {
03541 #ifdef KEY
03542 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_array[FMT_IDX]),
03543 &line, &col);
03544 #endif
03545 PRINTMSG(line, 1263, Error, col,
03546 io_type == Read ? "READ" : "WRITE",
03547 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))?"elemental":"pure",
03548 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
03549 semantically_correct = FALSE;
03550 }
03551
03552
03553 if (internal_file) {
03554 }
03555
03556
03557
03558 if (IL_FLD(list_array[ADVANCE_IDX]) != NO_Tbl_Idx) {
03559
03560 if (IL_FLD(list_array[FMT_IDX]) == NO_Tbl_Idx || is_namelist) {
03561 find_opnd_line_and_column((opnd_type *)
03562 &IL_OPND(list_array[ADVANCE_IDX]),
03563 &line, &col);
03564 PRINTMSG(line, 468, Error, col);
03565 semantically_correct = FALSE;
03566 }
03567 else if (list_directed) {
03568 find_opnd_line_and_column((opnd_type *)
03569 &IL_OPND(list_array[FMT_IDX]),
03570 &line, &col);
03571 PRINTMSG(line, 469, Error, col);
03572 semantically_correct = FALSE;
03573 }
03574
03575 if (internal_file) {
03576 find_opnd_line_and_column((opnd_type *)
03577 &IL_OPND(list_array[UNIT_IDX]),
03578 &line, &col);
03579 PRINTMSG(line, 470, Error, col);
03580 semantically_correct = FALSE;
03581 }
03582 }
03583
03584
03585
03586 if (IL_FLD(list_array[REC_IDX]) != NO_Tbl_Idx) {
03587
03588 if (internal_file) {
03589 find_opnd_line_and_column((opnd_type *)
03590 &IL_OPND(list_array[REC_IDX]),
03591 &line, &col);
03592 PRINTMSG(line, 471, Error, col);
03593 semantically_correct = FALSE;
03594 }
03595 else if (is_namelist) {
03596 find_opnd_line_and_column((opnd_type *)
03597 &IL_OPND(list_array[FMT_IDX]),
03598 &line, &col);
03599 PRINTMSG(line, 466, Error, col,
03600 io_type_string);
03601 semantically_correct = FALSE;
03602 }
03603 }
03604
03605
03606 if (is_namelist) {
03607
03608 IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) = (operator_type)
03609 (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) + 2);
03610 }
03611 else if (IL_FLD(list_array[FMT_IDX]) == NO_Tbl_Idx) {
03612
03613 IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) = (operator_type)
03614 (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) + 1);
03615 }
03616
03617 if (IL_FLD(list_array[IOSTAT_IDX]) != NO_Tbl_Idx) {
03618 have_iostat = TRUE;
03619 }
03620
03621
03622
03623
03624
03625 NTR_IR_LIST_TBL(list_idx);
03626 OPND_IDX((*list_opnd)) = list_idx;
03627
03628 # ifdef _NO_IO_ALTERNATE_RETURN
03629 OPND_LIST_CNT((*list_opnd)) = NUM_PDG_CONTROL_LIST_ITEMS + 3;
03630 # else
03631 OPND_LIST_CNT((*list_opnd)) = NUM_PDG_CONTROL_LIST_ITEMS;
03632 # endif
03633
03634
03635
03636
03637
03638 IL_FLD(list_idx) = CN_Tbl_Idx;
03639 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03640 IL_LINE_NUM(list_idx) = stmt_start_line;
03641 IL_COL_NUM(list_idx) = stmt_start_col;
03642
03643
03644
03645
03646
03647 constant_value = 0;
03648 constant_value |= (IL_FLD(list_array[err_idx]) != NO_Tbl_Idx) ?
03649 ERR_IS_PRESENT : 0;
03650 constant_value |= (IL_FLD(list_array[END_IDX]) != NO_Tbl_Idx) ?
03651 END_IS_PRESENT : 0;
03652 constant_value |= (IL_FLD(list_array[EOR_IDX]) != NO_Tbl_Idx) ?
03653 EOR_IS_PRESENT : 0;
03654 constant_value |= (IL_FLD(list_array[IOSTAT_IDX]) != NO_Tbl_Idx) ?
03655 IOSTAT_IS_PRESENT : 0;
03656
03657 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03658 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03659 list_idx = IL_NEXT_LIST_IDX(list_idx);
03660
03661 IL_FLD(list_idx) = CN_Tbl_Idx;
03662 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, constant_value);
03663 IL_LINE_NUM(list_idx) = stmt_start_line;
03664 IL_COL_NUM(list_idx) = stmt_start_col;
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
03674
03675
03676
03677 constant_value = FL_IO_SINGLE;
03678
03679 IL_FLD(list_idx) = CN_Tbl_Idx;
03680 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE);
03681 IL_LINE_NUM(list_idx) = stmt_start_line;
03682 IL_COL_NUM(list_idx) = stmt_start_col;
03683
03684
03685
03686
03687
03688
03689 IL_NEXT_LIST_IDX(list_idx) = list_array[UNIT_IDX];
03690 IL_PREV_LIST_IDX(list_array[UNIT_IDX]) = list_idx;
03691 list_idx = IL_NEXT_LIST_IDX(list_idx);
03692
03693
03694
03695
03696
03697 IL_NEXT_LIST_IDX(list_idx) = list_array[IOSTAT_IDX];
03698 IL_PREV_LIST_IDX(list_array[IOSTAT_IDX]) = list_idx;
03699 list_idx = IL_NEXT_LIST_IDX(list_idx);
03700
03701
03702
03703
03704
03705 IL_NEXT_LIST_IDX(list_idx) = list_array[REC_IDX];
03706 IL_PREV_LIST_IDX(list_array[REC_IDX]) = list_idx;
03707 list_idx = IL_NEXT_LIST_IDX(list_idx);
03708
03709
03710
03711
03712
03713 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03714 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03715 list_idx = IL_NEXT_LIST_IDX(list_idx);
03716
03717
03718
03719 if (! is_namelist &&
03720 ! list_directed) {
03721
03722 if (pp_tmp) {
03723 IL_FLD(list_idx) = AT_Tbl_Idx;
03724 IL_IDX(list_idx) = pp_tmp;
03725 IL_LINE_NUM(list_idx) = stmt_start_line;
03726 IL_COL_NUM(list_idx) = stmt_start_col;
03727 }
03728 }
03729
03730
03731
03732
03733
03734 IL_NEXT_LIST_IDX(list_idx) = list_array[FMT_IDX];
03735 IL_PREV_LIST_IDX(list_array[FMT_IDX]) = list_idx;
03736 list_idx = IL_NEXT_LIST_IDX(list_idx);
03737
03738 if (list_directed)
03739 {
03740 IL_OPND(list_idx) = null_opnd;
03741 }
03742
03743
03744
03745
03746
03747 IL_NEXT_LIST_IDX(list_idx) = list_array[ADVANCE_IDX];
03748 IL_PREV_LIST_IDX(list_array[ADVANCE_IDX]) = list_idx;
03749 list_idx = IL_NEXT_LIST_IDX(list_idx);
03750
03751
03752
03753
03754
03755 IL_NEXT_LIST_IDX(list_idx) = list_array[SIZE_IDX];
03756 IL_PREV_LIST_IDX(list_array[SIZE_IDX]) = list_idx;
03757 list_idx = IL_NEXT_LIST_IDX(list_idx);
03758 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
03759
03760 # ifdef _NO_IO_ALTERNATE_RETURN
03761
03762
03763
03764
03765 if (err_list_idx == NULL_IDX) {
03766 NTR_IR_LIST_TBL(err_list_idx);
03767 }
03768
03769 IL_NEXT_LIST_IDX(list_idx) = err_list_idx;
03770 IL_PREV_LIST_IDX(err_list_idx) = list_idx;
03771 list_idx = IL_NEXT_LIST_IDX(list_idx);
03772
03773
03774
03775
03776
03777 if (end_list_idx == NULL_IDX) {
03778 NTR_IR_LIST_TBL(end_list_idx);
03779 }
03780
03781 IL_NEXT_LIST_IDX(list_idx) = end_list_idx;
03782 IL_PREV_LIST_IDX(end_list_idx) = list_idx;
03783 list_idx = IL_NEXT_LIST_IDX(list_idx);
03784
03785
03786
03787
03788
03789 if (eor_list_idx == NULL_IDX) {
03790 NTR_IR_LIST_TBL(eor_list_idx);
03791 }
03792
03793 IL_NEXT_LIST_IDX(list_idx) = eor_list_idx;
03794 IL_PREV_LIST_IDX(eor_list_idx) = list_idx;
03795 list_idx = IL_NEXT_LIST_IDX(list_idx);
03796 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
03797 # endif
03798
03799 }
03800
03801 TRACE (Func_Exit, "io_ctl_list_semantics", NULL);
03802
03803 return(semantically_correct);
03804
03805 }
03806 #ifdef KEY
03807
03808
03809
03810
03811
03812
03813
03814
03815
03816
03817
03818
03819
03820
03821
03822
03823
03824
03825
03826
03827
03828
03829
03830
03831
03832
03833
03834
03835
03836
03837
03838 static Uint
03839 intrinsic_special_case(opnd_type *opnd, expr_arg_type *exp_desc) {
03840 if (opnd->fld == IR_Tbl_Idx) {
03841 operator_type op = IR_OPR(opnd->idx);
03842 if (op == Len_Trim_Opr || op == Index_Opr || op == Scan_Opr ||
03843 op == Verify_Opr) {
03844 return CG_INTEGER_DEFAULT_TYPE;
03845 }
03846 }
03847 return exp_desc->type_idx;
03848 }
03849 #endif
03850
03851
03852
03853
03854
03855
03856
03857
03858
03859
03860
03861
03862
03863
03864
03865
03866
03867 static boolean io_list_semantics(opnd_type *top_opnd,
03868 io_stmt_type io_type)
03869
03870 {
03871 int asg_idx;
03872 int attr_idx;
03873 int cnt;
03874 int col;
03875 boolean do_var_ok;
03876 expr_arg_type exp_desc;
03877 expr_arg_type lcv_exp_desc;
03878 expr_arg_type start_exp_desc;
03879 expr_arg_type end_exp_desc;
03880 expr_arg_type inc_exp_desc;
03881 boolean have_seen_must_flatten = FALSE;
03882 boolean have_seen_constructor = FALSE;
03883 int imp_idx;
03884 int line;
03885 #ifdef KEY
03886 int list_idx = 0;
03887 #else
03888 int list_idx;
03889 #endif
03890 int list2_idx;
03891 boolean needs_expansion = FALSE;
03892 int new_do_var_idx;
03893 opnd_type opnd;
03894 boolean save_in_implied_do;
03895 boolean semantically_correct = TRUE;
03896 int struct_list_idx;
03897 long_type the_constant;
03898 int type_idx;
03899
03900
03901 TRACE (Func_Entry, "io_list_semantics", NULL);
03902
03903 if (OPND_FLD((*top_opnd)) == NO_Tbl_Idx) {
03904 goto EXIT;
03905 }
03906 if (OPND_FLD((*top_opnd)) == IL_Tbl_Idx) {
03907 list_idx = OPND_IDX((*top_opnd));
03908 }
03909 else {
03910 find_opnd_line_and_column(top_opnd, &line, &col);
03911 PRINTMSG(line, 637, Internal, col);
03912 }
03913
03914 io_item_must_flatten = FALSE;
03915 tree_has_constructor = FALSE;
03916
03917 # ifdef _THREE_CALL_IO
03918 io_stmt_must_be_split = TRUE;
03919 three_call_model = TRUE;
03920 # endif
03921
03922 while (list_idx != NULL_IDX) {
03923
03924 IL_HAS_FUNCTIONS(list_idx) = FALSE;
03925 IL_MUST_BE_LOOP(list_idx) = FALSE;
03926
03927 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
03928 IR_OPR(IL_IDX(list_idx)) == Implied_Do_Opr) {
03929
03930 # ifdef _THREE_CALL_IO
03931 IL_MUST_BE_LOOP(list_idx) = TRUE;
03932 # endif
03933
03934
03935
03936
03937
03938
03939
03940 list2_idx = IL_NEXT_LIST_IDX(IR_IDX_R(IL_IDX(list_idx)));
03941
03942 COPY_OPND(opnd, IL_OPND(list2_idx));
03943 start_exp_desc.rank = 0;
03944 number_of_functions = 0;
03945 xref_state = CIF_Symbol_Reference;
03946 semantically_correct = expr_semantics(&opnd, &start_exp_desc) &&
03947 semantically_correct;
03948 COPY_OPND(IL_OPND(list2_idx), opnd);
03949
03950 if (item_has_bounds_chk(&opnd)) {
03951 number_of_functions++;
03952 }
03953
03954 if (number_of_functions > 0) {
03955 IL_HAS_FUNCTIONS(list2_idx) = TRUE;
03956 IL_HAS_FUNCTIONS(list_idx) = TRUE;
03957 needs_expansion = TRUE;
03958
03959 if (io_type == Read &&
03960 list_idx != OPND_IDX((*top_opnd))) {
03961 io_stmt_must_be_split = TRUE;
03962 }
03963 }
03964 else {
03965 IL_HAS_FUNCTIONS(list2_idx) = FALSE;
03966 }
03967
03968 find_opnd_line_and_column(&opnd, &line, &col);
03969
03970 if (start_exp_desc.rank != 0) {
03971 PRINTMSG(line, 476, Error, col);
03972 semantically_correct = FALSE;
03973 }
03974
03975 if (start_exp_desc.linear_type == Long_Typeless) {
03976 PRINTMSG(line, 1133, Error, col);
03977 semantically_correct = FALSE;
03978 }
03979 else if (start_exp_desc.type != Integer &&
03980 start_exp_desc.type != Typeless &&
03981 (start_exp_desc.type != Real ||
03982 (start_exp_desc.linear_type != REAL_DEFAULT_TYPE &&
03983 start_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) {
03984
03985 PRINTMSG(line, 477, Error, col);
03986 semantically_correct = FALSE;
03987 }
03988 else if (start_exp_desc.type == Real) {
03989 PRINTMSG(line, 943,
03990 #ifdef KEY
03991 Ansi,
03992 #else
03993 Comment,
03994 #endif
03995 col);
03996 }
03997
03998 #ifdef KEY
03999
04000
04001
04002
04003 #else
04004 COPY_OPND(opnd, IL_OPND(list2_idx));
04005 cast_to_cg_default(&opnd, &start_exp_desc);
04006 COPY_OPND(IL_OPND(list2_idx), opnd);
04007 #endif
04008
04009
04010
04011
04012
04013 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
04014
04015 COPY_OPND(opnd, IL_OPND(list2_idx));
04016 end_exp_desc.rank = 0;
04017 number_of_functions = 0;
04018 xref_state = CIF_Symbol_Reference;
04019 semantically_correct = expr_semantics(&opnd, &end_exp_desc) &&
04020 semantically_correct;
04021 COPY_OPND(IL_OPND(list2_idx), opnd);
04022
04023 if (item_has_bounds_chk(&opnd)) {
04024 number_of_functions++;
04025 }
04026
04027 if (number_of_functions > 0) {
04028 IL_HAS_FUNCTIONS(list2_idx) = TRUE;
04029 IL_HAS_FUNCTIONS(list_idx) = TRUE;
04030 needs_expansion = TRUE;
04031
04032 if (io_type == Read &&
04033 list_idx != OPND_IDX((*top_opnd))) {
04034 io_stmt_must_be_split = TRUE;
04035 }
04036 }
04037 else {
04038 IL_HAS_FUNCTIONS(list2_idx) = FALSE;
04039 }
04040
04041 find_opnd_line_and_column(&opnd, &line, &col);
04042
04043 if (end_exp_desc.rank != 0) {
04044 PRINTMSG(line, 476, Error, col);
04045 semantically_correct = FALSE;
04046 }
04047
04048 if (end_exp_desc.linear_type == Long_Typeless) {
04049 PRINTMSG(line, 1133, Error, col);
04050 semantically_correct = FALSE;
04051 }
04052 else if (end_exp_desc.type != Integer &&
04053 end_exp_desc.type != Typeless &&
04054 (end_exp_desc.type != Real ||
04055 (end_exp_desc.linear_type != REAL_DEFAULT_TYPE &&
04056 end_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) {
04057
04058 PRINTMSG(line, 477, Error, col);
04059 semantically_correct = FALSE;
04060 }
04061 else if (end_exp_desc.type == Real) {
04062 PRINTMSG(line, 943,
04063 #ifdef KEY
04064 Ansi,
04065 #else
04066 Comment,
04067 #endif
04068 col);
04069 }
04070
04071 #ifdef KEY
04072
04073
04074
04075
04076 #else
04077 COPY_OPND(opnd, IL_OPND(list2_idx));
04078 cast_to_cg_default(&opnd, &end_exp_desc);
04079 COPY_OPND(IL_OPND(list2_idx), opnd);
04080 #endif
04081
04082
04083
04084
04085
04086
04087 if (IL_NEXT_LIST_IDX(list2_idx) != NULL_IDX) {
04088 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
04089 COPY_OPND(opnd, IL_OPND(list2_idx));
04090 inc_exp_desc.rank = 0;
04091 number_of_functions = 0;
04092 xref_state = CIF_Symbol_Reference;
04093 semantically_correct = expr_semantics(&opnd, &inc_exp_desc) &&
04094 semantically_correct;
04095 COPY_OPND(IL_OPND(list2_idx), opnd);
04096
04097 if (item_has_bounds_chk(&opnd)) {
04098 number_of_functions++;
04099 }
04100
04101 if (number_of_functions > 0) {
04102 IL_HAS_FUNCTIONS(list2_idx) = TRUE;
04103 IL_HAS_FUNCTIONS(list_idx) = TRUE;
04104 needs_expansion = TRUE;
04105
04106 if (io_type == Read &&
04107 list_idx != OPND_IDX((*top_opnd))) {
04108 io_stmt_must_be_split = TRUE;
04109 }
04110 }
04111 else {
04112 IL_HAS_FUNCTIONS(list2_idx) = FALSE;
04113 }
04114
04115 find_opnd_line_and_column(&opnd, &line, &col);
04116
04117 if (inc_exp_desc.rank != 0) {
04118 PRINTMSG(line, 476, Error, col);
04119 semantically_correct = FALSE;
04120 }
04121
04122 if (inc_exp_desc.linear_type == Long_Typeless) {
04123 PRINTMSG(line, 1133, Error, col);
04124 semantically_correct = FALSE;
04125 }
04126 else if (inc_exp_desc.type != Integer &&
04127 inc_exp_desc.type != Typeless &&
04128 (inc_exp_desc.type != Real ||
04129 (inc_exp_desc.linear_type != REAL_DEFAULT_TYPE &&
04130 inc_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) {
04131
04132 PRINTMSG(line, 477, Error, col);
04133 semantically_correct = FALSE;
04134 }
04135 else if (inc_exp_desc.type == Real) {
04136 PRINTMSG(line, 943,
04137 #ifdef KEY
04138 Ansi,
04139 #else
04140 Comment,
04141 #endif
04142 col);
04143 }
04144
04145 if (semantically_correct &&
04146 OPND_FLD(opnd) == CN_Tbl_Idx) {
04147
04148 type_idx = CG_LOGICAL_DEFAULT_TYPE;
04149
04150 semantically_correct &=
04151 folder_driver((char *)&CN_CONST(OPND_IDX(opnd)),
04152 inc_exp_desc.type_idx,
04153 (char *)&CN_CONST(CN_INTEGER_ZERO_IDX),
04154 CG_INTEGER_DEFAULT_TYPE,
04155 &the_constant,
04156 &type_idx,
04157 line,
04158 col,
04159 2,
04160 Eq_Opr);
04161
04162 if (THIS_IS_TRUE(&the_constant, type_idx)) {
04163 PRINTMSG(line, 1084, Error, col);
04164 semantically_correct = FALSE;
04165 }
04166 }
04167
04168 #ifdef KEY
04169
04170
04171
04172
04173 #else
04174 COPY_OPND(opnd, IL_OPND(list2_idx));
04175 cast_to_cg_default(&opnd, &inc_exp_desc);
04176 COPY_OPND(IL_OPND(list2_idx), opnd);
04177 #endif
04178
04179 }
04180 else {
04181
04182 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
04183 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
04184 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
04185 IR_LIST_CNT_R(IL_IDX(list_idx))++;
04186 IL_FLD(list2_idx) = CN_Tbl_Idx;
04187 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX;
04188 IL_LINE_NUM(list2_idx) = stmt_start_line;
04189 IL_COL_NUM(list2_idx) = stmt_start_col;
04190
04191 inc_exp_desc = init_exp_desc;
04192
04193 inc_exp_desc.type_idx = CN_TYPE_IDX(CN_INTEGER_ONE_IDX);
04194 inc_exp_desc.linear_type = TYP_LINEAR(inc_exp_desc.type_idx);
04195 inc_exp_desc.type = TYP_TYPE(inc_exp_desc.type_idx);
04196 }
04197
04198
04199
04200
04201
04202
04203 list2_idx = IR_IDX_R(IL_IDX(list_idx));
04204
04205 do_var_ok = TRUE;
04206
04207 COPY_OPND(opnd, IL_OPND(list2_idx));
04208 lcv_exp_desc.rank = 0;
04209 number_of_functions = 0;
04210 xref_state = CIF_Symbol_Modification;
04211 save_in_implied_do = in_implied_do;
04212 in_implied_do = FALSE;
04213 do_var_ok = expr_semantics(&opnd, &lcv_exp_desc);
04214 COPY_OPND(IL_OPND(list2_idx), opnd);
04215 in_implied_do = save_in_implied_do;
04216
04217
04218
04219
04220
04221
04222 attr_idx = find_left_attr(&opnd);
04223
04224 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
04225 ATD_SEEN_AS_IO_LCV(attr_idx) = TRUE;
04226 }
04227
04228
04229 if (number_of_functions > 0) {
04230 IL_HAS_FUNCTIONS(list2_idx) = TRUE;
04231 IL_HAS_FUNCTIONS(list_idx) = TRUE;
04232 needs_expansion = TRUE;
04233 }
04234 else {
04235 IL_HAS_FUNCTIONS(list2_idx) = FALSE;
04236 }
04237
04238
04239
04240
04241 find_opnd_line_and_column(&opnd, &line, &col);
04242
04243 if (!lcv_exp_desc.reference) {
04244 PRINTMSG(line, 481, Error, col);
04245 do_var_ok = FALSE;
04246 }
04247 else {
04248
04249 if (lcv_exp_desc.rank != 0) {
04250 PRINTMSG(line, 482, Error, col);
04251 do_var_ok = FALSE;
04252 }
04253
04254 if (lcv_exp_desc.type != Integer &&
04255 (lcv_exp_desc.type != Real ||
04256 (lcv_exp_desc.linear_type != REAL_DEFAULT_TYPE &&
04257 lcv_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) {
04258
04259 PRINTMSG(line, 474, Error, col);
04260 do_var_ok = FALSE;
04261 }
04262 else if (lcv_exp_desc.type == Real) {
04263 IL_MUST_BE_LOOP(list_idx) = TRUE;
04264 io_stmt_must_be_split = TRUE;
04265 PRINTMSG(line, 1569, Ansi, col);
04266 }
04267
04268 if (do_var_ok &&
04269 OPND_FLD(opnd) != AT_Tbl_Idx &&
04270 (OPND_FLD(opnd) != IR_Tbl_Idx ||
04271 IR_OPR(OPND_IDX(opnd)) != Dv_Deref_Opr ||
04272 IR_FLD_L(OPND_IDX(opnd)) != AT_Tbl_Idx)) {
04273
04274 PRINTMSG(line, 530, Comment, col);
04275 do_var_ok = FALSE;
04276 }
04277
04278 if (do_var_ok) {
04279
04280 if (! check_for_legal_define(&opnd)) {
04281 do_var_ok = FALSE;
04282 }
04283 }
04284 }
04285
04286 NTR_IR_LIST_TBL(imp_idx);
04287 IL_NEXT_LIST_IDX(imp_idx) = imp_do_var_list;
04288 imp_do_var_list = imp_idx;
04289
04290 if (do_var_ok) {
04291 imp_idx = IL_NEXT_LIST_IDX(imp_idx);
04292
04293 while (imp_idx) {
04294
04295 if (OPND_IDX(opnd) == IL_IDX(imp_idx)) {
04296 PRINTMSG(line, 533, Error, col,
04297 AT_OBJ_NAME_PTR(OPND_IDX(opnd)));
04298 do_var_ok = FALSE;
04299 break;
04300 }
04301
04302 imp_idx = IL_NEXT_LIST_IDX(imp_idx);
04303 }
04304
04305 if (do_var_ok) {
04306 COPY_OPND(IL_OPND(imp_do_var_list), opnd);
04307 }
04308 }
04309
04310
04311 semantically_correct = semantically_correct && do_var_ok;
04312
04313
04314
04315
04316
04317
04318 in_implied_do = TRUE;
04319 COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx)));
04320 number_of_functions = 0;
04321 semantically_correct = io_list_semantics(&opnd, io_type) &&
04322 semantically_correct;
04323 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), opnd);
04324
04325 if (number_of_functions > 0) {
04326 IL_HAS_FUNCTIONS(list_idx) = TRUE;
04327 IL_MUST_BE_LOOP(list_idx) = TRUE;
04328 io_stmt_must_be_split = TRUE;
04329 needs_expansion = TRUE;
04330 }
04331
04332 if (io_item_must_flatten) {
04333 IL_MUST_BE_LOOP(list_idx) = TRUE;
04334 io_stmt_must_be_split = TRUE;
04335 have_seen_must_flatten = TRUE;
04336 }
04337
04338 if (tree_has_constructor) {
04339 IL_MUST_BE_LOOP(list_idx) = TRUE;
04340 io_stmt_must_be_split = TRUE;
04341 have_seen_constructor = TRUE;
04342 }
04343
04344
04345 imp_idx = imp_do_var_list;
04346 imp_do_var_list = IL_NEXT_LIST_IDX(imp_idx);
04347 FREE_IR_LIST_NODE(imp_idx);
04348
04349 # ifdef KEY
04350 if (do_var_ok &&
04351 storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))] <
04352 storage_bit_size_tbl[TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)] &&
04353 ! IL_MUST_BE_LOOP(list_idx)) {
04354 # else
04355 if (do_var_ok &&
04356 storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))] !=
04357 storage_bit_size_tbl[TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)] &&
04358 ! IL_MUST_BE_LOOP(list_idx)) {
04359 # endif
04360
04361 new_do_var_idx = gen_compiler_tmp(stmt_start_line, stmt_start_col,
04362 Priv, TRUE);
04363
04364 AT_SEMANTICS_DONE(new_do_var_idx)= TRUE;
04365 ATD_TYPE_IDX(new_do_var_idx) = CG_INTEGER_DEFAULT_TYPE;
04366 ATD_STOR_BLK_IDX(new_do_var_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
04367 AT_CIF_SYMBOL_ID(new_do_var_idx) = AT_CIF_SYMBOL_ID(attr_idx);
04368
04369 lcv_exp_desc.type_idx = ATD_TYPE_IDX(new_do_var_idx);
04370 lcv_exp_desc.type = TYP_TYPE(lcv_exp_desc.type_idx);
04371 lcv_exp_desc.linear_type = TYP_LINEAR(lcv_exp_desc.type_idx);
04372
04373 AT_ATTR_LINK(attr_idx) = new_do_var_idx;
04374 AT_IGNORE_ATTR_LINK(attr_idx) = TRUE;
04375
04376 ATD_IMP_DO_LCV(new_do_var_idx) = TRUE;
04377
04378 IL_NONDEFAULT_IMP_DO_LCV(list_idx) = TRUE;
04379 io_stmt_must_be_split = TRUE;
04380 needs_expansion = TRUE;
04381
04382 NTR_IR_TBL(asg_idx);
04383 IR_OPR(asg_idx) = Asg_Opr;
04384 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(attr_idx);
04385 IR_LINE_NUM(asg_idx) = stmt_start_line;
04386 IR_COL_NUM(asg_idx) = stmt_start_col;
04387 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
04388 IR_IDX_L(asg_idx) = attr_idx;
04389 IR_LINE_NUM_L(asg_idx) = stmt_start_line;
04390 IR_COL_NUM_L(asg_idx) = stmt_start_col;
04391 IR_FLD_R(asg_idx) = AT_Tbl_Idx;
04392 IR_IDX_R(asg_idx) = new_do_var_idx;
04393 IR_LINE_NUM_R(asg_idx) = stmt_start_line;
04394 IR_COL_NUM_R(asg_idx) = stmt_start_col;
04395
04396 IL_FLD(IR_IDX_R(IL_IDX(list_idx))) = IR_Tbl_Idx;
04397 IL_IDX(IR_IDX_R(IL_IDX(list_idx))) = asg_idx;
04398
04399 in_implied_do = TRUE;
04400 COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx)));
04401 semantically_correct = io_list_semantics(&opnd, io_type) &&
04402 semantically_correct;
04403 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), opnd);
04404 }
04405
04406 if (semantically_correct &&
04407 lcv_exp_desc.type == Integer) {
04408
04409
04410
04411
04412 list2_idx = IL_NEXT_LIST_IDX(IR_IDX_R(IL_IDX(list_idx)));
04413
04414 COPY_OPND(opnd, IL_OPND(list2_idx));
04415 cast_to_type_idx(&opnd, &start_exp_desc, lcv_exp_desc.type_idx);
04416 COPY_OPND(IL_OPND(list2_idx), opnd);
04417
04418 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
04419
04420 COPY_OPND(opnd, IL_OPND(list2_idx));
04421 cast_to_type_idx(&opnd, &end_exp_desc, lcv_exp_desc.type_idx);
04422 COPY_OPND(IL_OPND(list2_idx), opnd);
04423
04424 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
04425
04426 COPY_OPND(opnd, IL_OPND(list2_idx));
04427 cast_to_type_idx(&opnd, &inc_exp_desc, lcv_exp_desc.type_idx);
04428 COPY_OPND(IL_OPND(list2_idx), opnd);
04429 }
04430
04431 if (do_var_ok) {
04432
04433 AT_ATTR_LINK(attr_idx) = NULL_IDX;
04434 AT_IGNORE_ATTR_LINK(attr_idx) = FALSE;
04435 }
04436
04437 in_implied_do = save_in_implied_do;
04438 }
04439 else {
04440
04441 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04442 IR_OPR(IL_IDX(list_idx)) == Io_Item_Type_Code_Opr) {
04443
04444
04445
04446
04447 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
04448 }
04449
04450 exp_desc.rank = 0;
04451 COPY_OPND(opnd, IL_OPND(list_idx));
04452 number_of_functions = 0;
04453 io_item_must_flatten = FALSE;
04454 tree_has_constructor = FALSE;
04455
04456 if (io_type == Read || io_type == Decode) {
04457 xref_state = CIF_Symbol_Modification;
04458 }
04459 else {
04460 xref_state = CIF_Symbol_Reference;
04461 }
04462
04463 if (list_directed &&
04464 OPND_FLD(opnd) == CN_Tbl_Idx &&
04465 TYP_TYPE(CN_TYPE_IDX(OPND_IDX(opnd))) == Typeless) {
04466
04467 find_opnd_line_and_column(&opnd, &line, &col);
04468 PRINTMSG(line, 316, Error, col);
04469 semantically_correct = FALSE;
04470 }
04471
04472 in_io_list = TRUE;
04473 semantically_correct = expr_semantics(&opnd, &exp_desc) &&
04474 semantically_correct;
04475 COPY_OPND(IL_OPND(list_idx), opnd);
04476 in_io_list = FALSE;
04477
04478 if (exp_desc.reference) {
04479 attr_idx = find_left_attr(&opnd);
04480
04481 if (ATD_AUXILIARY(attr_idx)) {
04482 semantically_correct = FALSE;
04483 find_opnd_line_and_column(&opnd, &line, &col);
04484 PRINTMSG(line, 945, Error, col);
04485 }
04486 }
04487
04488 if (item_has_bounds_chk(&opnd)) {
04489 number_of_functions++;
04490 }
04491
04492 if (number_of_functions > 0) {
04493 IL_HAS_FUNCTIONS(list_idx) = TRUE;
04494 needs_expansion = TRUE;
04495
04496 if (io_type == Read &&
04497 list_idx != OPND_IDX((*top_opnd))) {
04498 io_stmt_must_be_split = TRUE;
04499 }
04500 }
04501
04502 if (io_item_must_flatten ||
04503 exp_desc.dist_reshape_ref ||
04504 (IL_FLD(list_idx) == IR_Tbl_Idx &&
04505 IR_ARRAY_SYNTAX(IL_IDX(list_idx))) ||
04506 exp_desc.vector_subscript) {
04507
04508 IL_MUST_FLATTEN(list_idx) = TRUE;
04509 have_seen_must_flatten = TRUE;
04510
04511 if ((io_type == Read || io_type == Decode) &&
04512 (exp_desc.vector_subscript || exp_desc.dist_reshape_ref) &&
04513 IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
04514
04515 io_stmt_must_be_split = TRUE;
04516 }
04517
04518 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
04519
04520
04521 arg_info_list_base = arg_info_list_top;
04522 arg_info_list_top = arg_info_list_base + 1;
04523
04524 if (arg_info_list_top >= arg_info_list_size) {
04525 enlarge_info_list_table();
04526 }
04527
04528 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top;
04529 arg_info_list[arg_info_list_top] = init_arg_info;
04530 arg_info_list[arg_info_list_top].ed = exp_desc;
04531 }
04532 else if (tree_has_constructor) {
04533 IL_HAS_CONSTRUCTOR(list_idx) = TRUE;
04534 have_seen_constructor = TRUE;
04535 }
04536
04537 if (io_type == Read || io_type == Decode) {
04538
04539 if (!exp_desc.reference) {
04540 find_opnd_line_and_column(&opnd, &line, &col);
04541
04542 if (exp_desc.constant) {
04543 PRINTMSG(line, 479, Error, col,
04544 io_stmt_str[io_type]);
04545 }
04546 else {
04547 PRINTMSG(line, 478, Error, col,
04548 io_stmt_str[io_type]);
04549 }
04550
04551 semantically_correct = FALSE;
04552 }
04553 else if (OPND_FLD(opnd) == AT_Tbl_Idx &&
04554 imp_do_var_list != NULL_IDX) {
04555
04556 imp_idx = imp_do_var_list;
04557
04558 while (imp_idx) {
04559
04560 if (OPND_IDX(opnd) == IL_IDX(imp_idx)) {
04561
04562
04563
04564 find_opnd_line_and_column(&opnd, &line, &col);
04565 PRINTMSG(line, 532, Error, col);
04566 semantically_correct = FALSE;
04567 break;
04568 }
04569 imp_idx = IL_NEXT_LIST_IDX(imp_idx);
04570 }
04571 }
04572
04573 if (semantically_correct) {
04574
04575 if (! check_for_legal_define(&opnd)) {
04576 semantically_correct = FALSE;
04577 }
04578 }
04579 }
04580
04581 if (exp_desc.type == Structure) {
04582
04583 #ifdef KEY
04584 if (ATT_POINTER_CPNT(TYP_IDX(exp_desc.type_idx)) ||
04585 ATT_ALLOCATABLE_CPNT(TYP_IDX(exp_desc.type_idx)))
04586 #else
04587 if (ATT_POINTER_CPNT(TYP_IDX(exp_desc.type_idx)))
04588 #endif
04589 {
04590 find_opnd_line_and_column(&opnd, &line, &col);
04591 PRINTMSG(line, 235, Error, col);
04592 semantically_correct = FALSE;
04593 }
04594 else if (AT_USE_ASSOCIATED(TYP_IDX(exp_desc.type_idx)) &&
04595 ATT_PRIVATE_CPNT(TYP_IDX(exp_desc.type_idx))) {
04596 find_opnd_line_and_column(&opnd, &line, &col);
04597 PRINTMSG(line, 1100, Error, col);
04598 semantically_correct = FALSE;
04599 }
04600 else if (IL_MUST_FLATTEN(list_idx)) {
04601
04602
04603
04604
04605
04606 IL_STRUCT_REF(list_idx) = TRUE;
04607
04608 }
04609 else
04610 {
04611
04612 IL_STRUCT_REF(list_idx) = TRUE;
04613 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
04614 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
04615 number_of_functions++;
04616 needs_expansion = TRUE;
04617
04618
04619 arg_info_list_base = arg_info_list_top;
04620 arg_info_list_top = arg_info_list_base + 1;
04621
04622 if (arg_info_list_top >= arg_info_list_size) {
04623 enlarge_info_list_table();
04624 }
04625
04626 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top;
04627 arg_info_list[arg_info_list_top] = init_arg_info;
04628 arg_info_list[arg_info_list_top].ed = exp_desc;
04629 }
04630 }
04631 else {
04632
04633
04634 COPY_OPND(opnd, IL_OPND(list_idx));
04635 find_opnd_line_and_column(&opnd, &line, &col);
04636
04637 NTR_IR_TBL(asg_idx);
04638 IR_OPR(asg_idx) = Io_Item_Type_Code_Opr;
04639 #ifdef KEY
04640 IR_TYPE_IDX(asg_idx) = intrinsic_special_case(&opnd, &exp_desc);
04641 #else
04642 IR_TYPE_IDX(asg_idx) = exp_desc.type_idx;
04643 #endif
04644 IR_LINE_NUM(asg_idx) = line;
04645 IR_COL_NUM(asg_idx) = col;
04646
04647 COPY_OPND(IR_OPND_L(asg_idx), opnd);
04648 IL_FLD(list_idx) = IR_Tbl_Idx;
04649 IL_IDX(list_idx) = asg_idx;
04650 }
04651 }
04652
04653 list_idx = IL_NEXT_LIST_IDX(list_idx);
04654 }
04655
04656 EXIT:
04657
04658 if (needs_expansion) {
04659 number_of_functions = 1;
04660 }
04661
04662 if (have_seen_must_flatten) {
04663 io_item_must_flatten = TRUE;
04664 }
04665
04666 if (have_seen_constructor) {
04667 tree_has_constructor = TRUE;
04668 }
04669
04670 TRACE (Func_Exit, "io_list_semantics", NULL);
04671
04672 return(semantically_correct);
04673
04674 }
04675
04676
04677
04678
04679
04680
04681
04682
04683
04684
04685
04686
04687
04688
04689
04690
04691
04692
04693
04694
04695
04696
04697
04698
04699
04700
04701
04702
04703
04704
04705
04706
04707
04708
04709
04710
04711
04712
04713
04714
04715
04716
04717
04718
04719
04720
04721
04722
04723
04724
04725
04726
04727
04728
04729
04730
04731
04732
04733
04734
04735
04736
04737
04738
04739
04740
04741
04742
04743
04744
04745
04746
04747
04748
04749
04750
04751
04752
04753
04754
04755
04756
04757
04758
04759
04760
04761
04762
04763
04764
04765
04766
04767
04768
04769
04770
04771
04772
04773
04774
04775
04776
04777
04778
04779
04780
04781
04782
04783
04784
04785
04786
04787
04788
04789
04790
04791
04792
04793
04794
04795
04796
04797
04798
04799
04800
04801
04802
04803
04804
04805
04806
04807
04808
04809
04810
04811
04812
04813
04814
04815
04816
04817
04818
04819
04820
04821
04822
04823
04824
04825
04826
04827
04828
04829
04830
04831
04832
04833
04834
04835
04836
04837
04838
04839
04840
04841
04842
04843
04844
04845
04846
04847
04848 void create_namelist_descriptor(int namelist_attr)
04849
04850 {
04851 int asg_idx;
04852 int col;
04853 expr_arg_type exp_desc;
04854 int head_idx;
04855 long_type idx_constant;
04856 boolean in_module = FALSE;
04857 int item_attr;
04858 opnd_type l_opnd;
04859 int line;
04860 int list_idx;
04861 int loc_idx;
04862 long num;
04863 int offset;
04864 boolean ok;
04865 opnd_type opnd;
04866 opnd_type opnd2;
04867 int save_curr_stmt_sh_idx;
04868 int sh_idx;
04869 int size;
04870 int sn_idx;
04871 int sub_idx;
04872 #ifdef KEY
04873 int stack_grp_tbl_idx = 0;
04874 #else
04875 int stack_grp_tbl_idx;
04876 #endif
04877 int static_grp_tbl_idx;
04878 int tail_idx;
04879 long_type the_constant[2];
04880 int tmp_idx;
04881 int type_idx;
04882 int val_type;
04883
04884 nmlist_group_hdr *group_hdr_ptr;
04885 nmlist_goli_t *goli_ptr;
04886
04887 # ifdef _INIT_RELOC_BASE_OFFSET
04888 int attr_idx;
04889 # endif
04890
04891
04892 TRACE (Func_Entry, "create_namelist_descriptor", NULL);
04893
04894 line = AT_DEF_LINE(namelist_attr);
04895 col = AT_DEF_COLUMN(namelist_attr);
04896 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
04897
04898 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
04899 in_module = TRUE;
04900 }
04901
04902 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04903 type_idx = SA_INTEGER_DEFAULT_TYPE;
04904 # else
04905 type_idx = CG_INTEGER_DEFAULT_TYPE;
04906 # endif
04907
04908
04909
04910
04911
04912 if (two_word_fcd) {
04913 size = NML_GRP_HDR_SIZE_FCD2 +
04914 (NML_GRP_ITEM_SIZE_FCD2 * ATN_NUM_NAMELIST(namelist_attr));
04915 }
04916 else {
04917 size = NML_GRP_HDR_SIZE +
04918 (NML_GRP_ITEM_SIZE * ATN_NUM_NAMELIST(namelist_attr));
04919 }
04920
04921 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04922
04923
04924 if (TYP_LINEAR(type_idx) == Integer_4) {
04925 size += 1 + ATN_NUM_NAMELIST(namelist_attr);
04926 }
04927 # endif
04928
04929 static_grp_tbl_idx = gen_static_integer_array_tmp(size, line, col);
04930
04931 if (! in_module) {
04932
04933
04934
04935
04936 stack_grp_tbl_idx = gen_compiler_tmp(line,col,
04937 Priv, TRUE);
04938 ATD_TYPE_IDX(stack_grp_tbl_idx) = ATD_TYPE_IDX(static_grp_tbl_idx);
04939 ATD_STOR_BLK_IDX(stack_grp_tbl_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
04940
04941
04942
04943 AT_SEMANTICS_DONE(stack_grp_tbl_idx) = TRUE;
04944
04945 ATD_ARRAY_IDX(stack_grp_tbl_idx) = ATD_ARRAY_IDX(static_grp_tbl_idx);
04946 }
04947
04948
04949 sh_idx = ntr_sh_tbl();
04950 SH_STMT_TYPE(sh_idx) = Assignment_Stmt;
04951 SH_GLB_LINE(sh_idx) = line;
04952 SH_COL_NUM(sh_idx) = col;
04953 SH_COMPILER_GEN(sh_idx) = TRUE;
04954 SH_P2_SKIP_ME(sh_idx) = TRUE;
04955 head_idx = sh_idx;
04956 tail_idx = sh_idx;
04957 curr_stmt_sh_idx = sh_idx;
04958
04959 if (! in_module) {
04960
04961
04962
04963
04964
04965 gen_opnd(&opnd, stack_grp_tbl_idx, AT_Tbl_Idx, line, col);
04966 ok = gen_whole_subscript(&opnd, &exp_desc);
04967
04968 gen_opnd(&opnd2, static_grp_tbl_idx, AT_Tbl_Idx, line, col);
04969 ok = gen_whole_subscript(&opnd2, &exp_desc);
04970
04971 asg_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
04972 Asg_Opr, type_idx, line, col,
04973 OPND_FLD(opnd2), OPND_IDX(opnd2));
04974
04975 gen_sh(After, Assignment_Stmt, line, col,
04976 FALSE, FALSE, TRUE);
04977 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
04978 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
04979 }
04980
04981
04982
04983
04984 idx_constant = 1;
04985
04986 the_constant[0] = 0;
04987 the_constant[1] = 0;
04988
04989 group_hdr_ptr = (nmlist_group_hdr *)the_constant;
04990
04991 # if defined(_BITFIELD_RIGHT_TO_LEFT)
04992 the_constant[0] = 1 | (ATN_NUM_NAMELIST(namelist_attr) << 16) ;
04993 # else
04994 group_hdr_ptr->version = 1;
04995 group_hdr_ptr->icount = ATN_NUM_NAMELIST(namelist_attr);
04996 # endif
04997
04998 gen_opnd(&opnd,
04999 ntr_const_tbl((sizeof(nmlist_group_hdr) == 8) ? Integer_8 :
05000 Integer_4,
05001 FALSE,
05002 the_constant),
05003 CN_Tbl_Idx,
05004 line,
05005 col);
05006
05007 gen_array_element_init(static_grp_tbl_idx,
05008 &idx_constant,
05009 &opnd,
05010 Init_Opr,
05011 NULL_IDX);
05012
05013
05014
05015
05016
05017
05018 put_string_in_tmp(AT_OBJ_NAME_PTR(namelist_attr),
05019 AT_NAME_LEN(namelist_attr),
05020 &opnd);
05021
05022 # ifdef _INIT_RELOC_BASE_OFFSET
05023 if (in_module) {
05024
05025
05026
05027
05028
05029 attr_idx = find_left_attr(&opnd);
05030
05031 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
05032 set_sb_first_attr_idx(attr_idx);
05033 }
05034 }
05035 # endif
05036
05037
05038
05039 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05040 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
05041 Loc_Opr, CRI_Ch_Ptr_8, line, col,
05042 NO_Tbl_Idx, NULL_IDX);
05043 # else
05044 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
05045 Aloc_Opr, CRI_Ch_Ptr_8, line, col,
05046 NO_Tbl_Idx, NULL_IDX);
05047 # endif
05048
05049
05050 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col);
05051
05052 gen_array_element_init(in_module ? static_grp_tbl_idx : stack_grp_tbl_idx,
05053 &idx_constant,
05054 &opnd,
05055 in_module ? Init_Reloc_Opr : Asg_Opr,
05056 NULL_IDX);
05057
05058
05059 if (two_word_fcd) {
05060
05061
05062 if (char_len_in_bytes) {
05063
05064 num = (long) AT_NAME_LEN(namelist_attr);
05065 }
05066 else {
05067
05068 num = (long) AT_NAME_LEN(namelist_attr) * CHAR_BIT;
05069 }
05070
05071 gen_opnd(&opnd,
05072 C_INT_TO_CN(type_idx, num),
05073 CN_Tbl_Idx,
05074 line,
05075 col);
05076
05077 gen_array_element_init(static_grp_tbl_idx,
05078 &idx_constant,
05079 &opnd,
05080 Init_Opr,
05081 NULL_IDX);
05082
05083 }
05084
05085 sn_idx = ATN_FIRST_NAMELIST_IDX(namelist_attr);
05086
05087 while (sn_idx != NULL_IDX) {
05088
05089 item_attr = SN_ATTR_IDX(sn_idx);
05090
05091 while (AT_ATTR_LINK(item_attr) &&
05092 ! AT_IGNORE_ATTR_LINK(item_attr)) {
05093 item_attr = AT_ATTR_LINK(item_attr);
05094 }
05095
05096
05097
05098
05099
05100
05101 if (TYP_TYPE(ATD_TYPE_IDX(item_attr)) == Structure) {
05102
05103 if (ATD_ARRAY_IDX(item_attr)) {
05104 val_type = NML_VALTYPE_STRCT_ARRAY;
05105 }
05106 else {
05107 val_type = NML_VALTYPE_STRCT;
05108 }
05109 }
05110 else if (ATD_ARRAY_IDX(item_attr)) {
05111 val_type = NML_VALTYPE_ARRAY;
05112 }
05113 else {
05114 val_type = NML_VALTYPE_SCALAR;
05115 }
05116
05117
05118 # if defined(_BITFIELD_RIGHT_TO_LEFT)
05119 the_constant[0] = val_type;
05120 # else
05121
05122 the_constant[0] = 0;
05123 the_constant[1] = 0;
05124
05125 goli_ptr = (nmlist_goli_t *)the_constant;
05126
05127 goli_ptr->valtype = val_type;
05128 # endif
05129
05130 gen_opnd(&opnd,
05131 ntr_const_tbl((sizeof(nmlist_goli_t) == 8) ? Integer_8 :
05132 Integer_4,
05133 FALSE,
05134 the_constant),
05135 CN_Tbl_Idx,
05136 line,
05137 col);
05138
05139 gen_array_element_init(static_grp_tbl_idx,
05140 &idx_constant,
05141 &opnd,
05142 Init_Opr,
05143 NULL_IDX);
05144
05145
05146
05147
05148
05149
05150 put_string_in_tmp(AT_OBJ_NAME_PTR(item_attr),
05151 AT_NAME_LEN(item_attr),
05152 &opnd);
05153
05154 # ifdef _INIT_RELOC_BASE_OFFSET
05155 if (in_module) {
05156
05157
05158
05159
05160
05161 attr_idx = find_left_attr(&opnd);
05162
05163 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
05164 set_sb_first_attr_idx(attr_idx);
05165 }
05166 }
05167 # endif
05168
05169
05170
05171 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05172 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
05173 Loc_Opr, CRI_Ch_Ptr_8, line, col,
05174 NO_Tbl_Idx, NULL_IDX);
05175 # else
05176 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
05177 Aloc_Opr, CRI_Ch_Ptr_8, line, col,
05178 NO_Tbl_Idx, NULL_IDX);
05179 # endif
05180
05181
05182 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col);
05183
05184 gen_array_element_init(in_module ? static_grp_tbl_idx:stack_grp_tbl_idx,
05185 &idx_constant,
05186 &opnd,
05187 in_module ? Init_Reloc_Opr : Asg_Opr,
05188 NULL_IDX);
05189
05190
05191 if (two_word_fcd) {
05192
05193
05194 if (char_len_in_bytes) {
05195
05196 num = (long) AT_NAME_LEN(item_attr);
05197 }
05198 else {
05199
05200 num = (long) AT_NAME_LEN(item_attr) * CHAR_BIT;
05201 }
05202
05203 gen_opnd(&opnd,
05204 C_INT_TO_CN(type_idx, num),
05205 CN_Tbl_Idx,
05206 line,
05207 col);
05208
05209 gen_array_element_init(static_grp_tbl_idx,
05210 &idx_constant,
05211 &opnd,
05212 Init_Opr,
05213 NULL_IDX);
05214
05215 }
05216
05217
05218
05219
05220
05221
05222 gen_opnd(&opnd, item_attr, AT_Tbl_Idx, line, col);
05223
05224 switch (val_type) {
05225 case NML_VALTYPE_SCALAR :
05226
05227 loc_idx = gen_ir(AT_Tbl_Idx, create_scalar_type_tbl(&opnd,
05228 in_module),
05229 Loc_Opr, CRI_Ptr_8, line, col,
05230 NO_Tbl_Idx, NULL_IDX);
05231
05232 break;
05233
05234 case NML_VALTYPE_ARRAY :
05235
05236
05237 exp_desc = init_exp_desc;
05238 ok = gen_whole_subscript(&opnd, &exp_desc);
05239
05240 if (in_module) {
05241 namelist_static_dv_whole_def(&l_opnd, &opnd);
05242 }
05243 else {
05244 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
05245 ATD_TYPE_IDX(tmp_idx) = ATD_TYPE_IDX(item_attr);
05246 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
05247 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
05248
05249
05250
05251 ATD_ARRAY_IDX(tmp_idx) = exp_desc.rank;
05252 ATD_IM_A_DOPE(tmp_idx) = TRUE;
05253 OPND_FLD(l_opnd) = AT_Tbl_Idx;
05254 OPND_IDX(l_opnd) = tmp_idx;
05255 OPND_LINE_NUM(l_opnd) = line;
05256 OPND_COL_NUM(l_opnd) = col;
05257
05258 exp_desc.type_idx = ATD_TYPE_IDX(item_attr);
05259 exp_desc.type = TYP_TYPE(exp_desc.type_idx);
05260 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
05261
05262 if (exp_desc.type == Character) {
05263 exp_desc.char_len.fld = TYP_FLD(exp_desc.type_idx);
05264 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx);
05265 }
05266 gen_dv_whole_def(&l_opnd, &opnd, &exp_desc);
05267 }
05268
05269 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05270 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd),
05271 Loc_Opr, CRI_Ptr_8, line, col,
05272 NO_Tbl_Idx, NULL_IDX);
05273 # else
05274 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd),
05275 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col,
05276 NO_Tbl_Idx, NULL_IDX);
05277 # endif
05278
05279 break;
05280
05281 case NML_VALTYPE_STRCT :
05282 case NML_VALTYPE_STRCT_ARRAY :
05283
05284 loc_idx = gen_ir(AT_Tbl_Idx, create_strct_tbl(&opnd, in_module),
05285 Loc_Opr, CRI_Ptr_8, line, col,
05286 NO_Tbl_Idx, NULL_IDX);
05287
05288 break;
05289 }
05290
05291 # ifdef _INIT_RELOC_BASE_OFFSET
05292 if (in_module) {
05293
05294
05295
05296
05297
05298 attr_idx = find_left_attr(&(IR_OPND_L(loc_idx)));
05299
05300 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
05301 set_sb_first_attr_idx(attr_idx);
05302 }
05303 }
05304 # endif
05305
05306 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col);
05307
05308 gen_array_element_init(in_module ? static_grp_tbl_idx:stack_grp_tbl_idx,
05309 &idx_constant,
05310 &opnd,
05311 in_module ? Init_Reloc_Opr : Asg_Opr,
05312 NULL_IDX);
05313
05314
05315 sn_idx = SN_SIBLING_LINK(sn_idx);
05316 }
05317
05318 ATN_NAMELIST_DESC(namelist_attr) = in_module ? static_grp_tbl_idx :
05319 stack_grp_tbl_idx;
05320
05321 tail_idx = curr_stmt_sh_idx;
05322
05323 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
05324
05325 # ifdef _DEBUG
05326 if (SH_IR_IDX(head_idx) != NULL_IDX) {
05327 PRINTMSG(line, 626, Internal, col,
05328 "empty head_idx", "create_namelist_descriptor");
05329 }
05330 # endif
05331 head_idx = SH_NEXT_IDX(head_idx);
05332 FREE_SH_NODE(SH_PREV_IDX(head_idx));
05333 SH_PREV_IDX(head_idx) = NULL_IDX;
05334
05335 insert_sh_chain_after_entries(head_idx, tail_idx);
05336
05337 TRACE (Func_Exit, "create_namelist_descriptor", NULL);
05338
05339 return;
05340
05341 }
05342
05343
05344
05345
05346
05347
05348
05349
05350
05351
05352
05353
05354
05355
05356
05357
05358
05359
05360
05361 static void namelist_static_dv_whole_def(opnd_type *l_opnd,
05362 opnd_type *r_opnd)
05363
05364 {
05365 int asg_idx;
05366 int attr_idx;
05367 int col;
05368 int const_idx;
05369 long_type constant[2];
05370 int dope_idx = NULL_IDX;
05371 ext_dope_type *dv_ptr;
05372 int i;
05373 long_type idx_constant;
05374 int line;
05375 int list_idx;
05376 int loc_idx;
05377 int num_elements;
05378 int num_words;
05379 int offset;
05380 opnd_type opnd;
05381 long_type rank;
05382 int rank_idx = NULL_IDX;
05383 int sub_idx;
05384 long_type the_constant[2];
05385 int tmp_idx;
05386 int type_idx;
05387 int type_idx2;
05388 int words_in_address = 1;
05389
05390 # ifdef _INIT_RELOC_BASE_OFFSET
05391 int attr_idx2;
05392 # endif
05393
05394
05395 TRACE (Func_Entry, "namelist_static_dv_whole_def", NULL);
05396
05397 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05398 type_idx2 = SA_INTEGER_DEFAULT_TYPE;
05399
05400 if (type_idx2 == Integer_8) {
05401 words_in_address = 2;
05402 }
05403 # else
05404 type_idx2 = CG_INTEGER_DEFAULT_TYPE;
05405 # endif
05406
05407 attr_idx = find_base_attr(r_opnd, &line, &col);
05408
05409 rank = (long_type) ((ATD_ARRAY_IDX(attr_idx) ?
05410 BD_RANK(ATD_ARRAY_IDX(attr_idx)) :0));
05411
05412 num_words = DV_HD_WORD_SIZE + (rank * DV_DIM_WORD_SIZE);
05413 num_elements = num_words;
05414
05415 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05416 if (TYP_LINEAR(type_idx2) == Integer_8) {
05417 num_elements = num_elements / 2;
05418 }
05419 # endif
05420
05421 tmp_idx = gen_static_integer_array_tmp(num_elements, line, col);
05422
05423 gen_opnd(l_opnd, tmp_idx, AT_Tbl_Idx, line, col);
05424
05425
05426
05427 idx_constant = 2;
05428
05429
05430
05431
05432
05433 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
05434 TYP_TYPE(TYP_WORK_IDX) = Typeless;
05435 #if defined (TARG_X8664) && defined (_HOST64)
05436
05437 TYP_BIT_LEN(TYP_WORK_IDX) = (num_words - words_in_address) *
05438 ((SET_POINTER_SIZE) ? 64 : 32);
05439 #else
05440 TYP_BIT_LEN(TYP_WORK_IDX) = (num_words - words_in_address) *
05441 TARGET_BITS_PER_WORD;
05442 #endif
05443 type_idx = ntr_type_tbl();
05444
05445 const_idx = ntr_const_tbl(type_idx, FALSE, NULL);
05446
05447 gen_opnd(&opnd, const_idx, CN_Tbl_Idx, line, col);
05448
05449 gen_array_element_init(tmp_idx,
05450 &idx_constant,
05451 &opnd,
05452 Init_Opr,
05453 NULL_IDX);
05454
05455
05456
05457
05458
05459 # ifdef _INIT_RELOC_BASE_OFFSET
05460 offset = change_to_base_and_offset(r_opnd, &opnd);
05461 # else
05462 make_base_subtree(r_opnd, &opnd, &rank_idx, &dope_idx);
05463 offset = NULL_IDX;
05464 # endif
05465
05466
05467 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05468 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
05469 Loc_Opr, TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character ?
05470 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col,
05471 NO_Tbl_Idx, NULL_IDX);
05472 # else
05473 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
05474 Aloc_Opr, TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character ?
05475 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col,
05476 NO_Tbl_Idx, NULL_IDX);
05477 # endif
05478
05479
05480 # ifdef _INIT_RELOC_BASE_OFFSET
05481
05482
05483
05484
05485 attr_idx2 = find_left_attr(&opnd);
05486
05487 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx2)) == NULL_IDX) {
05488 set_sb_first_attr_idx(attr_idx2);
05489 }
05490 # endif
05491
05492
05493 # ifdef _TRANSFORM_CHAR_SEQUENCE
05494 # ifdef _TARGET_OS_UNICOS
05495 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
05496 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
05497
05498 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
05499 COPY_OPND(opnd, IR_OPND_L(loc_idx));
05500 transform_char_sequence_ref(&opnd, ATD_TYPE_IDX(attr_idx));
05501 COPY_OPND(IR_OPND_L(loc_idx), opnd);
05502 }
05503 # endif
05504 # endif
05505
05506 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col);
05507
05508
05509 idx_constant = 1;
05510 gen_array_element_init(tmp_idx,
05511 &idx_constant,
05512 &opnd,
05513 Init_Reloc_Opr,
05514 offset);
05515
05516
05517
05518
05519
05520 dv_ptr = (ext_dope_type *)&(CP_CONSTANT(
05521 CN_POOL_IDX(const_idx) - words_in_address));
05522 type_idx = ATD_TYPE_IDX(attr_idx);
05523
05524
05525
05526
05527
05528
05529
05530
05531 DV_SET_ASSOC(*dv_ptr, 1);
05532
05533
05534
05535
05536
05537
05538 if (TYP_TYPE(type_idx) == Structure) {
05539
05540 if (compare_cn_and_value(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)),
05541 MAX_DV_EL_LEN,
05542 Ge_Opr)) {
05543 PRINTMSG(line, 1174, Error, col,
05544 ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)),
05545 MAX_DV_EL_LEN);
05546 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
05547 }
05548 else {
05549
05550 gen_opnd(&opnd,
05551 ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)),
05552 CN_Tbl_Idx,
05553 line,
05554 col);
05555
05556 cast_opnd_to_type_idx(&opnd, type_idx2);
05557
05558 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05559 if (TYP_LINEAR(type_idx2) == Integer_8) {
05560 DV_SET_EL_LEN(*dv_ptr, *(long long *)&(CN_CONST(OPND_IDX(opnd))));
05561 }
05562 else {
05563 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd)));
05564 }
05565 # else
05566 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd)));
05567 # endif
05568 }
05569 }
05570 else if (TYP_TYPE(type_idx) == Character) {
05571
05572 if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
05573
05574 gen_opnd(&opnd,
05575 TYP_IDX(type_idx),
05576 CN_Tbl_Idx,
05577 line,
05578 col);
05579
05580 cast_opnd_to_type_idx(&opnd, type_idx2);
05581
05582
05583 if (! char_len_in_bytes) {
05584
05585
05586 if (folder_driver((char *)&CN_CONST(OPND_IDX(opnd)),
05587 type_idx2,
05588 (char *)&CN_CONST(CN_INTEGER_CHAR_BIT_IDX),
05589 CN_TYPE_IDX(CN_INTEGER_CHAR_BIT_IDX),
05590 the_constant,
05591 &type_idx2,
05592 line,
05593 col,
05594 2,
05595 Mult_Opr)) {
05596 }
05597
05598 gen_opnd(&opnd,
05599 ntr_const_tbl(type_idx2,
05600 FALSE,
05601 the_constant),
05602 CN_Tbl_Idx,
05603 line,
05604 col);
05605 }
05606
05607
05608 if (char_len_in_bytes) {
05609
05610 if (compare_cn_and_value(TYP_IDX(type_idx),
05611 MAX_DV_EL_LEN,
05612 Ge_Opr)) {
05613 PRINTMSG(line, 1174, Error, col,
05614 TYP_IDX(type_idx), MAX_DV_EL_LEN);
05615 }
05616 }
05617 else {
05618
05619 if (compare_cn_and_value(TYP_IDX(type_idx),
05620 MAX_DV_EL_LEN/8,
05621 Ge_Opr)) {
05622 PRINTMSG(line, 1174, Error, col,
05623 TYP_IDX(type_idx),
05624 MAX_DV_EL_LEN/8);
05625 }
05626 }
05627
05628 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05629 if (TYP_LINEAR(type_idx2) == Integer_8) {
05630 DV_SET_EL_LEN(*dv_ptr, *(long long *)&(CN_CONST(OPND_IDX(opnd))));
05631 }
05632 else {
05633 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd)));
05634 }
05635 # else
05636 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd)));
05637 # endif
05638 }
05639 else {
05640 PRINTMSG(line, 630, Internal, col);
05641 }
05642 }
05643 else {
05644 DV_SET_EL_LEN(*dv_ptr, storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
05645 }
05646
05647
05648
05649
05650
05651 if (ATD_ALLOCATABLE(attr_idx)) {
05652 DV_SET_P_OR_A(*dv_ptr, 2);
05653 }
05654 else if (ATD_POINTER(attr_idx)) {
05655 DV_SET_P_OR_A(*dv_ptr, 1);
05656 }
05657
05658
05659
05660
05661
05662 DV_SET_NUM_DIMS(*dv_ptr, rank);
05663
05664
05665
05666
05667
05668 make_io_type_code(type_idx, constant);
05669 # ifdef _TYPE_CODE_64_BIT
05670 DV_SET_TYPE_CODE(*dv_ptr, *(f90_type_t *)constant);
05671 # else
05672 DV_SET_TYPE_CODE(*dv_ptr, *constant);
05673 # endif
05674
05675 for (i = 0; i < rank; i++) {
05676
05677
05678
05679
05680
05681 gen_opnd(&opnd,
05682 BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i + 1),
05683 CN_Tbl_Idx,
05684 line,
05685 col);
05686
05687 cast_opnd_to_type_idx(&opnd, type_idx2);
05688
05689 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05690 if (TYP_LINEAR(type_idx2) == Integer_8) {
05691 DV_SET_LOW_BOUND(*dv_ptr,i,
05692 *(long long *)&(CN_CONST(OPND_IDX(opnd))));
05693 }
05694 else {
05695 DV_SET_LOW_BOUND(*dv_ptr,i, CN_CONST(OPND_IDX(opnd)));
05696 }
05697 # else
05698 DV_SET_LOW_BOUND(*dv_ptr,i, CN_CONST(OPND_IDX(opnd)));
05699 # endif
05700
05701
05702
05703
05704
05705 gen_opnd(&opnd,
05706 BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), i + 1),
05707 CN_Tbl_Idx,
05708 line,
05709 col);
05710
05711 cast_opnd_to_type_idx(&opnd, type_idx2);
05712
05713 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05714 if (TYP_LINEAR(type_idx2) == Integer_8) {
05715 DV_SET_EXTENT(*dv_ptr,i,
05716 *(long long *)&(CN_CONST(OPND_IDX(opnd))));
05717 }
05718 else {
05719 DV_SET_EXTENT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd)));
05720 }
05721 # else
05722 DV_SET_EXTENT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd)));
05723 # endif
05724
05725
05726
05727
05728
05729 gen_opnd(&opnd,
05730 BD_SM_IDX(ATD_ARRAY_IDX(attr_idx), i + 1),
05731 CN_Tbl_Idx,
05732 line,
05733 col);
05734
05735 cast_opnd_to_type_idx(&opnd, type_idx2);
05736
05737 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05738 if (TYP_LINEAR(type_idx2) == Integer_8) {
05739 DV_SET_STRIDE_MULT(*dv_ptr,i,
05740 *(long long *)&(CN_CONST(OPND_IDX(opnd))));
05741 }
05742 else {
05743 DV_SET_STRIDE_MULT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd)));
05744 }
05745 # else
05746 DV_SET_STRIDE_MULT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd)));
05747 # endif
05748
05749 }
05750
05751 TRACE (Func_Exit, "namelist_static_dv_whole_def", NULL);
05752
05753 return;
05754
05755 }
05756
05757
05758
05759
05760
05761
05762
05763
05764
05765
05766
05767
05768
05769
05770
05771
05772
05773
05774 static int create_scalar_type_tbl(opnd_type *opnd,
05775 boolean in_module)
05776
05777 {
05778 int attr_idx;
05779 int asg_idx;
05780 int base_attr;
05781 int col;
05782 expr_arg_type exp_desc;
05783 long_type idx_constant;
05784 int line;
05785 int list_idx;
05786 int loc_idx;
05787 int offset;
05788 boolean ok;
05789 opnd_type opnd2;
05790 int sub_idx;
05791 long_type the_constant[2];
05792 long64 num;
05793 int tmp_idx;
05794 int type_idx;
05795
05796 TRACE (Func_Entry, "create_scalar_type_tbl", NULL);
05797
05798 base_attr = find_base_attr(opnd, &line, &col);
05799
05800
05801
05802
05803
05804 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05805 type_idx = SA_INTEGER_DEFAULT_TYPE;
05806 # else
05807 type_idx = CG_INTEGER_DEFAULT_TYPE;
05808 # endif
05809
05810 if (in_module) {
05811 tmp_idx = gen_compiler_tmp(line,col, Shared, TRUE);
05812 ATD_TYPE_IDX(tmp_idx) = type_idx;
05813 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
05814
05815 ATD_SAVED(tmp_idx) = TRUE;
05816 ATD_DATA_INIT(tmp_idx) = TRUE;
05817 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
05818 }
05819 else {
05820 tmp_idx = gen_compiler_tmp(line,col, Priv, TRUE);
05821 ATD_TYPE_IDX(tmp_idx) = type_idx;
05822 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
05823
05824 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
05825 }
05826
05827 exp_desc.type = Integer;
05828 exp_desc.type_idx = type_idx;
05829 exp_desc.linear_type = TYP_LINEAR(type_idx);
05830 exp_desc.rank = 1;
05831 exp_desc.shape[0].fld = CN_Tbl_Idx;
05832
05833 if (two_word_fcd) {
05834 num = NML_SCALAR_ENTRY_SIZE_FCD2;
05835 }
05836 else {
05837 num = NML_SCALAR_ENTRY_SIZE;
05838 }
05839
05840 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05841 if (TYP_LINEAR(type_idx) == Integer_4) {
05842 num++;
05843 }
05844 # endif
05845
05846 exp_desc.shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num);
05847
05848 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&exp_desc,
05849 line,
05850 col);
05851
05852
05853
05854
05855
05856
05857 idx_constant = 1;
05858
05859 make_io_type_code(ATD_TYPE_IDX(base_attr), the_constant);
05860
05861 gen_opnd(&opnd2,
05862 ntr_const_tbl(IO_TYPE_CODE_TYPE,
05863 FALSE,
05864 the_constant),
05865 CN_Tbl_Idx,
05866 line,
05867 col);
05868
05869 gen_array_element_init(tmp_idx,
05870 &idx_constant,
05871 &opnd2,
05872 in_module ? Init_Opr : Asg_Opr,
05873 NULL_IDX);
05874
05875
05876
05877
05878
05879 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character) {
05880 ok = gen_whole_substring(opnd, 0);
05881 }
05882
05883 offset = NULL_IDX;
05884
05885 opnd2 = *opnd;
05886
05887 # ifdef _INIT_RELOC_BASE_OFFSET
05888 if (in_module) {
05889 offset = change_to_base_and_offset(opnd, &opnd2);
05890
05891
05892
05893
05894
05895 attr_idx = find_left_attr(&opnd2);
05896
05897 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
05898 set_sb_first_attr_idx(attr_idx);
05899 }
05900 }
05901 # endif
05902
05903 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05904 loc_idx = gen_ir(OPND_FLD(opnd2), OPND_IDX(opnd2),
05905 Loc_Opr, TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character ?
05906 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col,
05907 NO_Tbl_Idx, NULL_IDX);
05908 # else
05909 loc_idx = gen_ir(OPND_FLD(opnd2), OPND_IDX(opnd2),
05910 Aloc_Opr, TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character ?
05911 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col,
05912 NO_Tbl_Idx, NULL_IDX);
05913 # endif
05914
05915
05916 # ifdef _TRANSFORM_CHAR_SEQUENCE
05917 # ifdef _TARGET_OS_UNICOS
05918 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Structure &&
05919 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(base_attr)))) {
05920
05921 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
05922 COPY_OPND(opnd2, IR_OPND_L(loc_idx));
05923 transform_char_sequence_ref(&opnd2, ATD_TYPE_IDX(base_attr));
05924 COPY_OPND(IR_OPND_L(loc_idx), opnd2);
05925 }
05926 # endif
05927 # endif
05928
05929 gen_opnd(&opnd2, loc_idx, IR_Tbl_Idx, line, col);
05930
05931 gen_array_element_init(tmp_idx,
05932 &idx_constant,
05933 &opnd2,
05934 in_module ? Init_Reloc_Opr : Asg_Opr,
05935 offset);
05936
05937
05938 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character &&
05939 two_word_fcd) {
05940
05941
05942
05943
05944 # ifdef _DEBUG
05945 if (TYP_FLD(ATD_TYPE_IDX(base_attr)) != CN_Tbl_Idx) {
05946 PRINTMSG(line, 1025, Internal, col);
05947 }
05948 # endif
05949
05950 gen_opnd(&opnd2,
05951 TYP_IDX(ATD_TYPE_IDX(base_attr)),
05952 CN_Tbl_Idx,
05953 line,
05954 col);
05955
05956 cast_opnd_to_type_idx(&opnd2, type_idx);
05957
05958
05959 if (! char_len_in_bytes) {
05960
05961
05962 if (folder_driver((char *)&CN_CONST(OPND_IDX(opnd2)),
05963 type_idx,
05964 (char *)&CN_CONST(CN_INTEGER_CHAR_BIT_IDX),
05965 CN_TYPE_IDX(CN_INTEGER_CHAR_BIT_IDX),
05966 the_constant,
05967 &type_idx,
05968 line,
05969 col,
05970 2,
05971 Mult_Opr)) {
05972 }
05973
05974 gen_opnd(&opnd2,
05975 ntr_const_tbl(type_idx,
05976 FALSE,
05977 the_constant),
05978 CN_Tbl_Idx,
05979 line,
05980 col);
05981
05982 }
05983
05984
05985 gen_array_element_init(tmp_idx,
05986 &idx_constant,
05987 &opnd2,
05988 in_module ? Init_Opr : Asg_Opr,
05989 NULL_IDX);
05990 }
05991
05992
05993 TRACE (Func_Exit, "create_scalar_type_tbl", NULL);
05994
05995 return(tmp_idx);
05996
05997 }
05998
05999
06000
06001
06002
06003
06004
06005
06006
06007
06008
06009
06010
06011
06012
06013
06014
06015 static int create_strct_tbl(opnd_type *base_opnd,
06016 boolean in_module)
06017
06018 {
06019 int asg_idx;
06020 int base_attr;
06021 int col;
06022 int comp_attr;
06023 int dope_idx = NULL_IDX;
06024 int dv_tmp_idx;
06025 expr_arg_type exp_desc;
06026 long_type idx_constant;
06027 opnd_type l_opnd;
06028 int line;
06029 int list_idx;
06030 int loc_idx;
06031 long64 num;
06032 int offset;
06033 boolean ok;
06034 opnd_type opnd;
06035 opnd_type opnd2;
06036 int rank_idx = NULL_IDX;
06037 int size;
06038 int sn_idx;
06039 int static_tmp_idx;
06040 int sub_idx;
06041 int struct_idx;
06042 long_type the_constant[2];
06043 #ifdef KEY
06044 int tmp_idx = 0;
06045 #else
06046 int tmp_idx;
06047 #endif
06048 int type_idx;
06049 int type_idx2;
06050 int val_type;
06051
06052 # ifdef _INIT_RELOC_BASE_OFFSET
06053 int attr_idx;
06054 # endif
06055
06056 nmlist_struclist_t *struct_hdr;
06057 nmlist_goli_t *goli_ptr;
06058
06059 TRACE (Func_Entry, "create_strct_tbl", NULL);
06060
06061 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
06062 type_idx2 = SA_INTEGER_DEFAULT_TYPE;
06063 # else
06064 type_idx2 = CG_INTEGER_DEFAULT_TYPE;
06065 # endif
06066
06067 base_attr = find_base_attr(base_opnd, &line, &col);
06068 type_idx = TYP_IDX(ATD_TYPE_IDX(base_attr));
06069
06070
06071
06072
06073
06074 if (two_word_fcd) {
06075 size = NML_STRCT_HDR_SIZE_FCD2 +
06076 (NML_STRCT_ITEM_SIZE_FCD2 * ATT_NUM_CPNTS(type_idx));
06077 }
06078 else {
06079 size = NML_STRCT_HDR_SIZE +
06080 (NML_STRCT_ITEM_SIZE * ATT_NUM_CPNTS(type_idx));
06081 }
06082
06083 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
06084
06085
06086 if (TYP_LINEAR(type_idx2) == Integer_4) {
06087 size += 1 + ATT_NUM_CPNTS(type_idx);
06088 }
06089 # endif
06090
06091 static_tmp_idx = gen_static_integer_array_tmp(size,line,col);
06092
06093 if (! in_module) {
06094
06095
06096
06097
06098
06099 tmp_idx = gen_compiler_tmp(line,col, Priv, TRUE);
06100 ATD_TYPE_IDX(tmp_idx) = type_idx2;
06101 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
06102
06103 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
06104
06105 ATD_ARRAY_IDX(tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx);
06106
06107
06108
06109
06110
06111
06112 gen_opnd(&opnd, tmp_idx, AT_Tbl_Idx, line, col);
06113 ok = gen_whole_subscript(&opnd, &exp_desc);
06114
06115 gen_opnd(&opnd2, static_tmp_idx, AT_Tbl_Idx, line, col);
06116 ok = gen_whole_subscript(&opnd2, &exp_desc);
06117
06118 asg_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
06119 Asg_Opr, type_idx2, line, col,
06120 OPND_FLD(opnd2), OPND_IDX(opnd2));
06121
06122 gen_sh(After, Assignment_Stmt, line, col,
06123 FALSE, FALSE, TRUE);
06124 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
06125 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06126 }
06127
06128
06129
06130
06131
06132
06133 idx_constant = 1;
06134
06135 # if defined(_BITFIELD_RIGHT_TO_LEFT)
06136 the_constant[0] = (long_type) ATT_NUM_CPNTS(type_idx) << 16;
06137 # else
06138 the_constant[0] = 0;
06139 the_constant[1] = 0;
06140
06141 struct_hdr = (nmlist_struclist_t *)the_constant;
06142
06143 struct_hdr->structlen = ATT_NUM_CPNTS(type_idx);
06144 # endif
06145
06146 gen_opnd(&opnd,
06147 ntr_const_tbl((sizeof(nmlist_struclist_t) == 8) ? Integer_8 :
06148 Integer_4,
06149 FALSE,
06150 the_constant),
06151 CN_Tbl_Idx,
06152 line,
06153 col);
06154
06155 gen_array_element_init(static_tmp_idx,
06156 &idx_constant,
06157 &opnd,
06158 Init_Opr,
06159 NULL_IDX);
06160
06161
06162
06163
06164
06165
06166 if (ATD_ARRAY_IDX(base_attr)) {
06167
06168
06169 COPY_OPND(opnd, (*base_opnd));
06170 exp_desc = init_exp_desc;
06171 ok = gen_whole_subscript(&opnd, &exp_desc);
06172 COPY_OPND((*base_opnd), opnd);
06173
06174 if (in_module) {
06175 namelist_static_dv_whole_def(&l_opnd, &opnd);
06176 }
06177 else {
06178 dv_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
06179
06180 ATD_TYPE_IDX(dv_tmp_idx) = ATD_TYPE_IDX(base_attr);
06181 ATD_STOR_BLK_IDX(dv_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
06182 AT_SEMANTICS_DONE(dv_tmp_idx)= TRUE;
06183
06184
06185
06186 ATD_ARRAY_IDX(dv_tmp_idx) = exp_desc.rank;
06187 ATD_IM_A_DOPE(dv_tmp_idx) = TRUE;
06188
06189 gen_opnd(&l_opnd, dv_tmp_idx, AT_Tbl_Idx, line, col);
06190
06191 exp_desc.type_idx = ATD_TYPE_IDX(base_attr);
06192 exp_desc.type = TYP_TYPE(exp_desc.type_idx);
06193 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
06194
06195 if (exp_desc.type == Character) {
06196 exp_desc.char_len.fld = TYP_FLD(exp_desc.type_idx);
06197 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx);
06198 }
06199 gen_dv_whole_def(&l_opnd, &opnd, &exp_desc);
06200 }
06201
06202 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
06203 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd),
06204 Loc_Opr, CRI_Ptr_8, line, col,
06205 NO_Tbl_Idx, NULL_IDX);
06206 # else
06207 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd),
06208 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col,
06209 NO_Tbl_Idx, NULL_IDX);
06210 # endif
06211
06212 rank_idx = 0;
06213 dope_idx = 0;
06214 make_base_subtree(base_opnd, &l_opnd, &rank_idx, &dope_idx);
06215 COPY_OPND((*base_opnd), l_opnd);
06216
06217 }
06218 else {
06219
06220 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
06221 loc_idx = gen_ir(OPND_FLD((*base_opnd)), OPND_IDX((*base_opnd)),
06222 Loc_Opr, CRI_Ptr_8, line, col,
06223 NO_Tbl_Idx, NULL_IDX);
06224 # else
06225 loc_idx = gen_ir(OPND_FLD((*base_opnd)), OPND_IDX((*base_opnd)),
06226 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col,
06227 NO_Tbl_Idx, NULL_IDX);
06228 # endif
06229
06230 # ifdef _TRANSFORM_CHAR_SEQUENCE
06231 # ifdef _TARGET_OS_UNICOS
06232 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Structure &&
06233 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(base_attr)))) {
06234
06235 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
06236 COPY_OPND(opnd, IR_OPND_L(loc_idx));
06237 transform_char_sequence_ref(&opnd, ATD_TYPE_IDX(base_attr));
06238 COPY_OPND(IR_OPND_L(loc_idx), opnd);
06239 }
06240 # endif
06241 # endif
06242
06243 }
06244
06245 offset = NULL_IDX;
06246
06247 # ifdef _INIT_RELOC_BASE_OFFSET
06248 if (in_module) {
06249
06250 COPY_OPND(opnd, IR_OPND_L(loc_idx));
06251 offset = change_to_base_and_offset(&opnd, &opnd2);
06252 COPY_OPND(IR_OPND_L(loc_idx), opnd2);
06253
06254
06255
06256
06257
06258 attr_idx = find_left_attr(&(IR_OPND_L(loc_idx)));
06259
06260 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
06261 set_sb_first_attr_idx(attr_idx);
06262 }
06263 }
06264 # endif
06265
06266 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col);
06267
06268 gen_array_element_init(in_module ? static_tmp_idx : tmp_idx,
06269 &idx_constant,
06270 &opnd,
06271 in_module ? Init_Reloc_Opr : Asg_Opr,
06272 offset);
06273
06274 sn_idx = ATT_FIRST_CPNT_IDX(type_idx);
06275
06276 while (sn_idx != NULL_IDX) {
06277
06278 comp_attr = SN_ATTR_IDX(sn_idx);
06279
06280
06281
06282
06283
06284 if (TYP_TYPE(ATD_TYPE_IDX(comp_attr)) == Structure) {
06285
06286 if (ATD_ARRAY_IDX(comp_attr)) {
06287 val_type = NML_VALTYPE_STRCT_ARRAY;
06288 }
06289 else {
06290 val_type = NML_VALTYPE_STRCT;
06291 }
06292 }
06293 else if (ATD_ARRAY_IDX(comp_attr)) {
06294 val_type = NML_VALTYPE_ARRAY;
06295 }
06296 else {
06297 val_type = NML_VALTYPE_SCALAR;
06298 }
06299
06300 # if defined(_BITFIELD_RIGHT_TO_LEFT)
06301 the_constant[0] = val_type;
06302 # else
06303
06304 the_constant[0] = 0;
06305 the_constant[1] = 0;
06306
06307 goli_ptr = (nmlist_goli_t *)the_constant;
06308
06309 goli_ptr->valtype = val_type;
06310 # endif
06311
06312 gen_opnd(&opnd,
06313 ntr_const_tbl((sizeof(nmlist_goli_t) == 8) ? Integer_8 :
06314 Integer_4,
06315 FALSE,
06316 the_constant),
06317 CN_Tbl_Idx,
06318 line,
06319 col);
06320
06321 gen_array_element_init(static_tmp_idx,
06322 &idx_constant,
06323 &opnd,
06324 Init_Opr,
06325 NULL_IDX);
06326
06327
06328
06329
06330
06331
06332 put_string_in_tmp(AT_OBJ_NAME_PTR(comp_attr),
06333 AT_NAME_LEN(comp_attr),
06334 &opnd);
06335
06336
06337 # ifdef _INIT_RELOC_BASE_OFFSET
06338 if (in_module) {
06339
06340
06341
06342
06343 attr_idx = find_left_attr(&opnd);
06344
06345 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
06346 set_sb_first_attr_idx(attr_idx);
06347 }
06348 }
06349 # endif
06350
06351
06352
06353 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
06354 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
06355 Loc_Opr, CRI_Ch_Ptr_8, line, col,
06356 NO_Tbl_Idx, NULL_IDX);
06357 # else
06358 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
06359 Aloc_Opr, CRI_Ch_Ptr_8, line, col,
06360 NO_Tbl_Idx, NULL_IDX);
06361 # endif
06362
06363 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col);
06364
06365 gen_array_element_init(in_module ? static_tmp_idx : tmp_idx,
06366 &idx_constant,
06367 &opnd,
06368 in_module ? Init_Reloc_Opr : Asg_Opr,
06369 NULL_IDX);
06370
06371 if (two_word_fcd) {
06372
06373
06374 if (char_len_in_bytes) {
06375
06376 num = AT_NAME_LEN(comp_attr);
06377 }
06378 else {
06379
06380 num = AT_NAME_LEN(comp_attr) * CHAR_BIT;
06381 }
06382
06383 gen_opnd(&opnd,
06384 C_INT_TO_CN(type_idx2, num),
06385 CN_Tbl_Idx,
06386 line,
06387 col);
06388
06389 gen_array_element_init(static_tmp_idx,
06390 &idx_constant,
06391 &opnd,
06392 Init_Opr,
06393 NULL_IDX);
06394
06395 }
06396
06397
06398
06399
06400
06401 NTR_IR_TBL(struct_idx);
06402 IR_OPR(struct_idx) = Struct_Opr;
06403 IR_TYPE_IDX(struct_idx) = ATD_TYPE_IDX(comp_attr);
06404 IR_LINE_NUM(struct_idx) = line;
06405 IR_COL_NUM(struct_idx) = col;
06406
06407 COPY_OPND(IR_OPND_L(struct_idx), (*base_opnd));
06408 IR_FLD_R(struct_idx) = AT_Tbl_Idx;
06409 IR_IDX_R(struct_idx) = comp_attr;
06410 IR_LINE_NUM_R(struct_idx) = line;
06411 IR_COL_NUM_R(struct_idx) = col;
06412
06413 gen_opnd(&opnd, struct_idx, IR_Tbl_Idx, line, col);
06414
06415 switch (val_type) {
06416 case NML_VALTYPE_SCALAR :
06417
06418
06419 loc_idx = gen_ir(AT_Tbl_Idx, create_scalar_type_tbl(&opnd,
06420 in_module),
06421 Loc_Opr, CRI_Ptr_8, line, col,
06422 NO_Tbl_Idx, NULL_IDX);
06423
06424 break;
06425
06426 case NML_VALTYPE_ARRAY :
06427
06428
06429 exp_desc = init_exp_desc;
06430 ok = gen_whole_subscript(&opnd, &exp_desc);
06431
06432 if (in_module) {
06433 namelist_static_dv_whole_def(&l_opnd, &opnd);
06434 }
06435 else {
06436 dv_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
06437
06438 ATD_TYPE_IDX(dv_tmp_idx) = ATD_TYPE_IDX(comp_attr);
06439 ATD_STOR_BLK_IDX(dv_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
06440 AT_SEMANTICS_DONE(dv_tmp_idx) = TRUE;
06441
06442
06443
06444 ATD_ARRAY_IDX(dv_tmp_idx) = exp_desc.rank;
06445 ATD_IM_A_DOPE(dv_tmp_idx) = TRUE;
06446
06447 gen_opnd(&l_opnd, dv_tmp_idx, AT_Tbl_Idx, line, col);
06448
06449 exp_desc.type_idx = ATD_TYPE_IDX(comp_attr);
06450 exp_desc.type = TYP_TYPE(exp_desc.type_idx);
06451 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
06452
06453 if (exp_desc.type == Character) {
06454 exp_desc.char_len.fld = TYP_FLD(exp_desc.type_idx);
06455 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx);
06456 }
06457 gen_dv_whole_def(&l_opnd, &opnd, &exp_desc);
06458 }
06459
06460 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
06461 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd),
06462 Loc_Opr, CRI_Ptr_8, line, col,
06463 NO_Tbl_Idx, NULL_IDX);
06464 # else
06465 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd),
06466 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col,
06467 NO_Tbl_Idx, NULL_IDX);
06468 # endif
06469 break;
06470
06471 case NML_VALTYPE_STRCT :
06472 case NML_VALTYPE_STRCT_ARRAY :
06473
06474
06475 loc_idx = gen_ir(AT_Tbl_Idx, create_strct_tbl(&opnd, in_module),
06476 Loc_Opr, CRI_Ptr_8, line, col,
06477 NO_Tbl_Idx, NULL_IDX);
06478
06479 break;
06480 }
06481
06482 # ifdef _INIT_RELOC_BASE_OFFSET
06483 if (in_module) {
06484
06485
06486
06487
06488
06489 attr_idx = find_left_attr(&(IR_OPND_L(loc_idx)));
06490
06491 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
06492 set_sb_first_attr_idx(attr_idx);
06493 }
06494 }
06495 # endif
06496
06497 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col);
06498
06499 gen_array_element_init(in_module ? static_tmp_idx : tmp_idx,
06500 &idx_constant,
06501 &opnd,
06502 in_module ? Init_Reloc_Opr : Asg_Opr,
06503 NULL_IDX);
06504
06505 sn_idx = SN_SIBLING_LINK(sn_idx);
06506 }
06507
06508
06509 TRACE (Func_Exit, "create_strct_tbl", NULL);
06510
06511 return(in_module ? static_tmp_idx : tmp_idx);
06512
06513 }
06514
06515
06516
06517
06518
06519
06520
06521
06522
06523
06524
06525
06526
06527
06528
06529
06530
06531
06532 static void put_string_in_tmp(char *str,
06533 int len,
06534 opnd_type *opnd)
06535
06536 {
06537 int col;
06538 int const_idx;
06539 int init_idx;
06540 int line;
06541 int list_idx;
06542 boolean ok;
06543 int save_curr_stmt_sh_idx;
06544 int tmp_idx;
06545 int type_idx;
06546
06547
06548
06549
06550
06551
06552 TRACE (Func_Entry, "put_string_in_tmp", NULL);
06553
06554 line = SH_GLB_LINE(curr_stmt_sh_idx);
06555 col = SH_COL_NUM(curr_stmt_sh_idx);
06556 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
06557 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);
06558
06559 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
06560 TYP_TYPE(TYP_WORK_IDX) = Character;
06561 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
06562 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
06563 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx;
06564 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, len);
06565 type_idx = ntr_type_tbl();
06566 const_idx = ntr_const_tbl(type_idx,
06567 TRUE,
06568 (long_type *) str);
06569
06570 tmp_idx = gen_compiler_tmp(line, col, Shared, TRUE);
06571
06572 ATD_TYPE_IDX(tmp_idx) = type_idx;
06573 ATD_SAVED(tmp_idx) = TRUE;
06574 ATD_DATA_INIT(tmp_idx) = TRUE;
06575 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
06576 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
06577
06578 OPND_FLD((*opnd)) = AT_Tbl_Idx;
06579 OPND_IDX((*opnd)) = tmp_idx;
06580 OPND_LINE_NUM((*opnd)) = line;
06581 OPND_COL_NUM((*opnd)) = col;
06582
06583 ok = gen_whole_substring(opnd, 0);
06584
06585 NTR_IR_TBL(init_idx);
06586 IR_OPR(init_idx) = Init_Opr;
06587 IR_TYPE_IDX(init_idx) = TYPELESS_DEFAULT_TYPE;
06588
06589 IR_LINE_NUM(init_idx) = line;
06590 IR_COL_NUM(init_idx) = col;
06591 IR_LINE_NUM_R(init_idx) = line;
06592 IR_COL_NUM_R(init_idx) = col;
06593
06594 COPY_OPND(IR_OPND_L(init_idx), (*opnd));
06595
06596 NTR_IR_LIST_TBL(list_idx);
06597 IR_FLD_R(init_idx) = IL_Tbl_Idx;
06598 IR_IDX_R(init_idx) = list_idx;
06599 IR_LIST_CNT_R(init_idx) = 3;
06600
06601 IL_FLD(list_idx) = CN_Tbl_Idx;
06602 IL_IDX(list_idx) = const_idx;
06603 IL_LINE_NUM(list_idx) = line;
06604 IL_COL_NUM(list_idx) = col;
06605
06606 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
06607
06608 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
06609 list_idx = IL_NEXT_LIST_IDX(list_idx);
06610 IL_FLD(list_idx) = CN_Tbl_Idx;
06611 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
06612 IL_LINE_NUM(list_idx) = line;
06613 IL_COL_NUM(list_idx) = col;
06614
06615 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
06616
06617 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
06618 list_idx = IL_NEXT_LIST_IDX(list_idx);
06619 IL_FLD(list_idx) = CN_Tbl_Idx;
06620 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
06621 IL_LINE_NUM(list_idx) = line;
06622 IL_COL_NUM(list_idx) = col;
06623
06624 gen_sh(After,
06625 Assignment_Stmt,
06626 line,
06627 col,
06628 FALSE,
06629 FALSE,
06630 TRUE);
06631
06632 SH_IR_IDX(curr_stmt_sh_idx) = init_idx;
06633 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06634 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
06635
06636 TRACE (Func_Exit, "put_string_in_tmp", NULL);
06637
06638 return;
06639
06640 }
06641
06642
06643
06644
06645
06646
06647
06648
06649
06650
06651
06652
06653
06654
06655
06656
06657
06658
06659
06660 # ifdef _INIT_RELOC_BASE_OFFSET
06661 static int change_to_base_and_offset(opnd_type *ref_opnd,
06662 opnd_type *base_opnd)
06663
06664
06665 {
06666 int col;
06667 size_offset_type cpnt_offset;
06668 int line;
06669 int offset_idx;
06670 size_offset_type offset;
06671 opnd_type opnd;
06672 boolean unused;
06673
06674
06675 TRACE (Func_Entry, "change_to_base_and_offset", NULL);
06676
06677 if (OPND_FLD((*ref_opnd)) == AT_Tbl_Idx) {
06678 offset_idx = CN_INTEGER_ZERO_IDX;
06679 COPY_OPND((*base_opnd), (*ref_opnd));
06680 }
06681 else {
06682 COPY_OPND(opnd, (*ref_opnd));
06683
06684 offset.idx = CN_INTEGER_ZERO_IDX;
06685 offset.fld = CN_Tbl_Idx;
06686
06687 while (OPND_FLD(opnd) != AT_Tbl_Idx) {
06688
06689 switch (IR_OPR(OPND_IDX(opnd))) {
06690 case Whole_Subscript_Opr :
06691 case Section_Subscript_Opr :
06692 case Subscript_Opr :
06693 case Whole_Substring_Opr :
06694 case Substring_Opr :
06695 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
06696 break;
06697
06698 case Struct_Opr :
06699
06700 cpnt_offset.idx = ATD_CPNT_OFFSET_IDX(IR_IDX_R(OPND_IDX(opnd)));
06701 cpnt_offset.fld = ATD_OFFSET_FLD(IR_IDX_R(OPND_IDX(opnd)));
06702
06703 size_offset_binary_calc(&offset,
06704 &cpnt_offset,
06705 Plus_Opr,
06706 &offset);
06707
06708 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
06709 break;
06710
06711 default :
06712 find_opnd_line_and_column(&opnd, &line, &col);
06713 PRINTMSG(line, 1048, Internal, col);
06714 break;
06715 }
06716 }
06717
06718 if (offset.fld == NO_Tbl_Idx) {
06719 offset_idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant);
06720 }
06721 else if (offset.fld == CN_Tbl_Idx) {
06722 offset_idx = offset.idx;
06723 }
06724 else {
06725 PRINTMSG(OPND_LINE_NUM(opnd), 1201, Internal, OPND_COL_NUM(opnd),
06726 AT_OBJ_NAME_PTR(IR_IDX_R(OPND_IDX(opnd))));
06727 }
06728
06729 COPY_OPND((*base_opnd), opnd);
06730
06731 if (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(opnd))) == Character) {
06732 unused = gen_whole_substring(base_opnd, 0);
06733 }
06734 }
06735
06736 TRACE (Func_Exit, "change_to_base_and_offset", NULL);
06737
06738 return(offset_idx);
06739
06740 }
06741 # endif
06742
06743
06744
06745
06746
06747
06748
06749
06750
06751
06752
06753
06754
06755
06756
06757
06758
06759
06760 static boolean do_read_namelist_semantics(opnd_type *namelist_opnd)
06761
06762 {
06763 int attr_idx;
06764 int col;
06765 int line;
06766 int namelist_attr;
06767 opnd_type opnd;
06768 boolean semantically_correct = TRUE;
06769 int sn_idx;
06770
06771
06772 TRACE (Func_Entry, "do_read_namelist_semantics", NULL);
06773
06774 namelist_attr = OPND_IDX((*namelist_opnd));
06775 line = OPND_LINE_NUM((*namelist_opnd));
06776 col = OPND_COL_NUM((*namelist_opnd));
06777
06778 sn_idx = ATN_FIRST_NAMELIST_IDX(namelist_attr);
06779
06780 while (sn_idx != NULL_IDX) {
06781 attr_idx = SN_ATTR_IDX(sn_idx);
06782 AT_DEFINED(attr_idx) = TRUE;
06783
06784 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
06785
06786 gen_opnd(&opnd, attr_idx, AT_Tbl_Idx, line, col);
06787
06788 if (! check_for_legal_define(&opnd)) {
06789 semantically_correct = FALSE;
06790 sn_idx = SN_SIBLING_LINK(sn_idx);
06791 continue;
06792 }
06793 }
06794
06795 if (AT_ATTR_LINK(attr_idx) != NULL_IDX) {
06796 AT_DEF_IN_CHILD(attr_idx) = TRUE;
06797
06798 do {
06799 attr_idx = AT_ATTR_LINK(attr_idx);
06800 AT_DEF_IN_CHILD(attr_idx) = TRUE;
06801 }
06802 while (AT_ATTR_LINK(attr_idx) != NULL_IDX);
06803 }
06804
06805 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
06806 ATD_CLASS(attr_idx) == Dummy_Argument &&
06807 ATD_INTENT(attr_idx) == Intent_In) {
06808 PRINTMSG(line, 890, Error, col, AT_OBJ_NAME_PTR(attr_idx));
06809 semantically_correct = FALSE;
06810 }
06811
06812 sn_idx = SN_SIBLING_LINK(sn_idx);
06813 }
06814
06815 TRACE (Func_Exit, "do_read_namelist_semantics", NULL);
06816
06817 return(semantically_correct);
06818
06819 }
06820
06821
06822
06823
06824
06825
06826
06827
06828
06829
06830
06831
06832
06833
06834
06835
06836
06837 static void do_write_namelist_semantics(opnd_type *namelist_opnd)
06838
06839 {
06840 int attr_idx;
06841 int namelist_attr;
06842 int sn_idx;
06843
06844 TRACE (Func_Entry, "do_write_namelist_semantics", NULL);
06845
06846 namelist_attr = OPND_IDX((*namelist_opnd));
06847
06848 sn_idx = ATN_FIRST_NAMELIST_IDX(namelist_attr);
06849
06850 while (sn_idx != NULL_IDX) {
06851 attr_idx = SN_ATTR_IDX(sn_idx);
06852 AT_REFERENCED(attr_idx) = Referenced;
06853
06854 if (AT_ATTR_LINK(attr_idx) != NULL_IDX) {
06855 AT_REF_IN_CHILD(attr_idx) = TRUE;
06856
06857 do {
06858 attr_idx = AT_ATTR_LINK(attr_idx);
06859 AT_REF_IN_CHILD(attr_idx) = TRUE;
06860 }
06861 while (AT_ATTR_LINK(attr_idx) != NULL_IDX);
06862 }
06863
06864 sn_idx = SN_SIBLING_LINK(sn_idx);
06865 }
06866
06867 TRACE (Func_Exit, "do_write_namelist_semantics", NULL);
06868
06869 return;
06870
06871 }
06872
06873
06874
06875
06876
06877
06878
06879
06880
06881
06882
06883
06884
06885
06886
06887
06888
06889
06890 static int discombobulate_structure_ref(opnd_type *base_opnd,
06891 int type_idx,
06892 int *list_idx)
06893
06894 {
06895 int attr_idx;
06896 int cnt;
06897 int col;
06898 int deref_idx;
06899 expr_arg_type exp_desc;
06900 boolean first_item = TRUE;
06901 int imp_idx;
06902 int ir_idx;
06903 int line;
06904 opnd_type loc_base_opnd;
06905 int new_list_idx;
06906 int next_list_idx;
06907 int num_items = 0;
06908 boolean ok;
06909 opnd_type opnd;
06910 int sn_idx;
06911 int struct_idx;
06912 int tmp_list_idx;
06913
06914
06915 TRACE (Func_Entry, "discombobulate_structure_ref", NULL);
06916
06917 new_list_idx = *list_idx;
06918 next_list_idx = IL_NEXT_LIST_IDX(new_list_idx);
06919
06920 attr_idx = find_base_attr(base_opnd, &line, &col);
06921
06922 sn_idx = ATT_FIRST_CPNT_IDX(type_idx);
06923
06924 COPY_OPND(loc_base_opnd, (*base_opnd));
06925
06926 while (sn_idx != NULL_IDX) {
06927 attr_idx = SN_ATTR_IDX(sn_idx);
06928
06929 NTR_IR_TBL(struct_idx);
06930 IR_OPR(struct_idx) = Struct_Opr;
06931 IR_TYPE_IDX(struct_idx) = ATD_TYPE_IDX(attr_idx);
06932 IR_LINE_NUM(struct_idx) = line;
06933 IR_COL_NUM(struct_idx) = col;
06934 COPY_OPND(IR_OPND_L(struct_idx), loc_base_opnd);
06935
06936 if (SN_SIBLING_LINK(sn_idx) != NULL_IDX) {
06937 copy_subtree(&loc_base_opnd, &loc_base_opnd);
06938 }
06939
06940 IR_FLD_R(struct_idx) = AT_Tbl_Idx;
06941 IR_IDX_R(struct_idx) = attr_idx;
06942 IR_LINE_NUM_R(struct_idx) = line;
06943 IR_COL_NUM_R(struct_idx) = col;
06944
06945 OPND_FLD(opnd) = IR_Tbl_Idx;
06946 OPND_IDX(opnd) = struct_idx;
06947
06948 if (ATD_POINTER(attr_idx)) {
06949 NTR_IR_TBL(deref_idx);
06950 IR_OPR(deref_idx) = Dv_Deref_Opr;
06951 IR_TYPE_IDX(deref_idx) = ATD_TYPE_IDX(attr_idx);
06952 IR_LINE_NUM(deref_idx) = line;
06953 IR_COL_NUM(deref_idx) = col;
06954 COPY_OPND(IR_OPND_L(deref_idx), opnd);
06955 OPND_FLD(opnd) = IR_Tbl_Idx;
06956 OPND_IDX(opnd) = deref_idx;
06957 }
06958
06959 if (ATD_ARRAY_IDX(attr_idx)) {
06960 ok = gen_whole_subscript(&opnd, &exp_desc);
06961 }
06962 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
06963 ok = gen_whole_substring(&opnd, 0);
06964 }
06965
06966 if (first_item) {
06967 first_item = FALSE;
06968 }
06969 else {
06970 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(new_list_idx));
06971 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(new_list_idx)) = new_list_idx;
06972 new_list_idx = IL_NEXT_LIST_IDX(new_list_idx);
06973 num_items++;
06974 }
06975
06976 COPY_OPND(IL_OPND(new_list_idx), opnd);
06977
06978 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure) {
06979
06980 if (ATD_ARRAY_IDX(attr_idx)) {
06981 tmp_list_idx = new_list_idx;
06982 imp_idx = change_section_to_do(&tmp_list_idx);
06983 COPY_OPND(opnd, IL_OPND(tmp_list_idx));
06984 cnt = discombobulate_structure_ref( &opnd,
06985 TYP_IDX(ATD_TYPE_IDX(attr_idx)),
06986 &tmp_list_idx);
06987 IR_LIST_CNT_L(imp_idx) += cnt;
06988 }
06989 else {
06990 num_items += discombobulate_structure_ref(
06991 &opnd,
06992 TYP_IDX(ATD_TYPE_IDX(attr_idx)),
06993 &new_list_idx);
06994 }
06995 }
06996 else {
06997
06998
06999 COPY_OPND(opnd, IL_OPND(new_list_idx));
07000
07001 NTR_IR_TBL(ir_idx);
07002 IR_OPR(ir_idx) = Io_Item_Type_Code_Opr;
07003 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
07004 IR_LINE_NUM(ir_idx) = line;
07005 IR_COL_NUM(ir_idx) = col;
07006
07007 COPY_OPND(IR_OPND_L(ir_idx), opnd);
07008 IL_FLD(new_list_idx) = IR_Tbl_Idx;
07009 IL_IDX(new_list_idx) = ir_idx;
07010 }
07011
07012 sn_idx = SN_SIBLING_LINK(sn_idx);
07013 }
07014
07015 IL_NEXT_LIST_IDX(new_list_idx) = next_list_idx;
07016 *list_idx = new_list_idx;
07017
07018 TRACE (Func_Exit, "discombobulate_structure_ref", NULL);
07019
07020 return(num_items);
07021
07022 }
07023
07024
07025
07026
07027
07028
07029
07030
07031
07032
07033
07034
07035
07036
07037
07038
07039
07040
07041 static int change_section_to_do(int *list_idx)
07042
07043 {
07044 int col;
07045 expr_arg_type exp_desc;
07046 int imp_idx;
07047 int ir_idx;
07048 int i;
07049 int k;
07050 int line;
07051 opnd_type opnd;
07052 int rank = 1;
07053 int return_imp_idx;
07054 #ifdef KEY
07055 int return_list_idx = 0;
07056 #else
07057 int return_list_idx;
07058 #endif
07059 int sub_list_idx;
07060 int tmp_idx;
07061 int tmp_list_idx;
07062 opnd_type tmp_opnd;
07063 int trip_list_idx;
07064
07065
07066 TRACE (Func_Entry, "change_section_to_do", NULL);
07067
07068 COPY_OPND(opnd, IL_OPND((*list_idx)));
07069 find_opnd_line_and_column(&opnd, &line, &col);
07070
07071 while (OPND_FLD(opnd) == IR_Tbl_Idx) {
07072
07073 ir_idx = OPND_IDX(opnd);
07074
07075 if (IR_OPR(ir_idx) == Whole_Subscript_Opr ||
07076 IR_OPR(ir_idx) == Section_Subscript_Opr) {
07077
07078 IR_OPR(ir_idx) = Subscript_Opr;
07079
07080
07081 NTR_IR_TBL(imp_idx);
07082 return_imp_idx = imp_idx;
07083 IR_OPR(imp_idx) = Implied_Do_Opr;
07084 IR_TYPE_IDX(imp_idx) = TYPELESS_DEFAULT_TYPE;
07085 IR_LINE_NUM(imp_idx) = line;
07086 IR_COL_NUM(imp_idx) = col;
07087
07088 NTR_IR_LIST_TBL(return_list_idx);
07089 IR_FLD_L(imp_idx) = IL_Tbl_Idx;
07090 IR_LIST_CNT_L(imp_idx) = 1;
07091 IR_IDX_L(imp_idx) = return_list_idx;
07092
07093 COPY_OPND(IL_OPND(return_list_idx), IL_OPND((*list_idx)));
07094 IL_FLD((*list_idx)) = IR_Tbl_Idx;
07095 IL_IDX((*list_idx)) = imp_idx;
07096
07097 sub_list_idx = IR_IDX_R(ir_idx);
07098 for (i = 0; i < IR_LIST_CNT_R(ir_idx); i++) {
07099
07100 if (IL_VECTOR_SUBSCRIPT(sub_list_idx)) {
07101
07102
07103
07104 COPY_OPND(tmp_opnd, IL_OPND(sub_list_idx));
07105
07106 trip_list_idx = NULL_IDX;
07107 while (trip_list_idx == NULL_IDX) {
07108
07109 while (OPND_FLD(tmp_opnd) == IR_Tbl_Idx) {
07110
07111 if (IR_OPR(OPND_IDX(tmp_opnd)) == Whole_Subscript_Opr ||
07112 IR_OPR(OPND_IDX(tmp_opnd)) == Section_Subscript_Opr) {
07113
07114 tmp_list_idx = IR_IDX_R(OPND_IDX(tmp_opnd));
07115
07116 for (k = 0; k < IR_LIST_CNT_R(OPND_IDX(tmp_opnd));
07117 k++) {
07118 if (IL_VECTOR_SUBSCRIPT(tmp_list_idx)) {
07119 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx));
07120 break;
07121 }
07122 else if (IL_FLD(tmp_list_idx) == IR_Tbl_Idx &&
07123 IR_OPR(IL_IDX(tmp_list_idx)) == Triplet_Opr) {
07124
07125 trip_list_idx = tmp_list_idx;
07126 break;
07127 }
07128
07129 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx);
07130 }
07131 break;
07132 }
07133
07134 COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd)));
07135 }
07136 }
07137 }
07138 else {
07139 trip_list_idx = sub_list_idx;
07140 }
07141
07142 if (IL_FLD(trip_list_idx) == IR_Tbl_Idx &&
07143 IR_OPR(IL_IDX(trip_list_idx)) == Triplet_Opr) {
07144
07145 if (rank > 1) {
07146
07147 NTR_IR_LIST_TBL(tmp_list_idx);
07148 IL_FLD(tmp_list_idx) = IR_Tbl_Idx;
07149 IL_IDX(tmp_list_idx) = imp_idx;
07150
07151 NTR_IR_TBL(imp_idx);
07152 IR_OPR(imp_idx) = Implied_Do_Opr;
07153 IR_TYPE_IDX(imp_idx) = TYPELESS_DEFAULT_TYPE;
07154 IR_LINE_NUM(imp_idx) = line;
07155 IR_COL_NUM(imp_idx) = col;
07156 IR_FLD_L(imp_idx) = IL_Tbl_Idx;
07157 IR_LIST_CNT_L(imp_idx) = 1;
07158 IR_IDX_L(imp_idx) = tmp_list_idx;
07159 IL_IDX((*list_idx)) = imp_idx;
07160 }
07161
07162
07163
07164 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
07165 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE;
07166 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
07167 AT_SEMANTICS_DONE(tmp_idx)= TRUE;
07168
07169
07170
07171 NTR_IR_LIST_TBL(tmp_list_idx);
07172 IR_FLD_R(imp_idx) = IL_Tbl_Idx;
07173 IR_LIST_CNT_R(imp_idx) = 4;
07174 IR_IDX_R(imp_idx) = tmp_list_idx;
07175
07176 IL_FLD(tmp_list_idx) = AT_Tbl_Idx;
07177 IL_IDX(tmp_list_idx) = tmp_idx;
07178 IL_LINE_NUM(tmp_list_idx) = line;
07179 IL_COL_NUM(tmp_list_idx) = col;
07180
07181
07182
07183 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(tmp_list_idx));
07184 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(tmp_list_idx)) = tmp_list_idx;
07185 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx);
07186
07187 COPY_OPND(IL_OPND(tmp_list_idx),
07188 IL_OPND(IR_IDX_L(IL_IDX(trip_list_idx))));
07189
07190 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx));
07191 set_up_exp_desc(&tmp_opnd, &exp_desc);
07192 #ifdef KEY
07193
07194
07195
07196
07197 #else
07198 cast_to_cg_default(&tmp_opnd, &exp_desc);
07199 #endif
07200 COPY_OPND(IL_OPND(tmp_list_idx), tmp_opnd);
07201
07202
07203
07204 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(tmp_list_idx));
07205 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(tmp_list_idx)) = tmp_list_idx;
07206 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx);
07207
07208 COPY_OPND(IL_OPND(tmp_list_idx),
07209 IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L(
07210 IL_IDX(trip_list_idx)))));
07211
07212 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx));
07213 set_up_exp_desc(&tmp_opnd, &exp_desc);
07214 #ifdef KEY
07215
07216
07217
07218
07219 #else
07220 cast_to_cg_default(&tmp_opnd, &exp_desc);
07221 #endif
07222 COPY_OPND(IL_OPND(tmp_list_idx), tmp_opnd);
07223
07224
07225
07226 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(tmp_list_idx));
07227 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(tmp_list_idx)) = tmp_list_idx;
07228 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx);
07229
07230 COPY_OPND(IL_OPND(tmp_list_idx),
07231 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
07232 IR_IDX_L(IL_IDX(trip_list_idx))))));
07233
07234 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx));
07235 set_up_exp_desc(&tmp_opnd, &exp_desc);
07236 #ifdef KEY
07237
07238
07239
07240
07241 #else
07242 cast_to_cg_default(&tmp_opnd, &exp_desc);
07243 #endif
07244 COPY_OPND(IL_OPND(tmp_list_idx), tmp_opnd);
07245
07246
07247
07248 IL_FLD(trip_list_idx) = AT_Tbl_Idx;
07249 IL_IDX(trip_list_idx) = tmp_idx;
07250 IL_LINE_NUM(trip_list_idx) = line;
07251 IL_COL_NUM(trip_list_idx) = col;
07252
07253 rank++;
07254 }
07255
07256
07257
07258 sub_list_idx = IL_NEXT_LIST_IDX(sub_list_idx);
07259 }
07260 break;
07261 }
07262
07263 COPY_OPND(opnd, IR_OPND_L(ir_idx));
07264 }
07265
07266 (*list_idx) = return_list_idx;
07267
07268 TRACE (Func_Exit, "change_section_to_do", NULL);
07269
07270 return(return_imp_idx);
07271
07272 }
07273
07274
07275
07276
07277
07278
07279
07280
07281
07282
07283
07284
07285
07286
07287
07288
07289
07290 static void process_deferred_io_list(void)
07291
07292 {
07293 int ir_idx;
07294 int new_root;
07295 int next_stmt_idx;
07296 int save_curr_stmt_sh_idx;
07297
07298
07299 TRACE (Func_Entry, "process_deferred_io_list", NULL);
07300
07301 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
07302
07303 alt_return_branch_idx = NULL_IDX;
07304
07305 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
07306
07307 if (io_stmt_must_be_split) {
07308
07309 if (IR_OPR(ir_idx) == Alt_Return_Opr) {
07310
07311 # ifdef _DEBUG
07312 if (IR_OPR(SH_IR_IDX(SH_NEXT_IDX(curr_stmt_sh_idx))) != Br_True_Opr) {
07313 PRINTMSG(stmt_start_line, 737, Internal, stmt_start_col);
07314 }
07315 # endif
07316 alt_return_branch_idx = SH_IR_IDX(SH_NEXT_IDX(curr_stmt_sh_idx));
07317 ir_idx = IR_IDX_R(ir_idx);
07318 }
07319 else if (IR_OPR(ir_idx) == Asg_Opr) {
07320 ir_idx = IR_IDX_R(ir_idx);
07321 }
07322
07323 new_root = copy_text_for_expansion(FL_IO_FIRST);
07324
07325 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
07326 FALSE, FALSE, TRUE);
07327
07328 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
07329 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07330
07331 if (alt_return_branch_idx) {
07332 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07333 FALSE, FALSE, TRUE);
07334
07335 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = alt_return_branch_idx;
07336 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07337 }
07338
07339 if (stmt_type == Inquire_Stmt) {
07340 IL_IDX(IR_IDX_L(ir_idx)) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
07341 FL_IO_MIDDLE);
07342 }
07343 else {
07344 IL_IDX(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)))) =
07345 C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
07346 FL_IO_MIDDLE);
07347 }
07348
07349 new_root = copy_text_for_expansion(FL_IO_LAST);
07350
07351 if (alt_return_branch_idx) {
07352 gen_sh(After, If_Stmt, stmt_start_line, stmt_start_col,
07353 FALSE, FALSE, TRUE);
07354
07355 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
07356 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07357
07358 }
07359
07360 gen_sh(After, stmt_type, stmt_start_line, stmt_start_col,
07361 FALSE, FALSE, TRUE);
07362
07363 SH_IR_IDX(curr_stmt_sh_idx) = new_root;
07364 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07365
07366 next_stmt_idx = curr_stmt_sh_idx;
07367
07368 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
07369
07370 expand_io_list();
07371
07372 curr_stmt_sh_idx = next_stmt_idx;
07373 }
07374 else {
07375 next_stmt_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
07376
07377 expand_io_list();
07378
07379 curr_stmt_sh_idx = SH_PREV_IDX(next_stmt_idx);
07380 }
07381
07382 TRACE (Func_Exit, "process_deferred_io_list", NULL);
07383
07384 return;
07385
07386 }
07387
07388
07389
07390
07391
07392
07393
07394
07395
07396
07397
07398
07399
07400
07401
07402
07403
07404 static void expand_io_list(void)
07405
07406 {
07407 int cnt = 0;
07408 expr_arg_type exp_desc;
07409 #ifndef KEY
07410 int i;
07411 #endif
07412 int imp_idx;
07413 int io_idx;
07414 int ir_idx;
07415 opnd_type left_opnd;
07416 int list_idx;
07417 int new_root;
07418 int next_stmt_idx;
07419 opnd_type opnd;
07420 int prev_list_idx;
07421 int save_curr_stmt_sh_idx;
07422 int struct_list_idx;
07423 int tmp_asg_sh_idx;
07424 int tmp_idx;
07425
07426
07427 TRACE (Func_Entry, "expand_io_list", NULL);
07428
07429 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
07430
07431 next_stmt_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
07432
07433 if (IR_OPR(ir_idx) == Alt_Return_Opr) {
07434 ir_idx = IR_IDX_R(ir_idx);
07435 next_stmt_idx = SH_NEXT_IDX(next_stmt_idx);
07436 }
07437 else if (IR_OPR(ir_idx) == Asg_Opr) {
07438 ir_idx = IR_IDX_R(ir_idx);
07439 }
07440
07441 list_idx = IR_IDX_R(ir_idx);
07442 prev_list_idx = NULL_IDX;
07443
07444 while (list_idx != NULL_IDX) {
07445 cnt++;
07446 new_root = NULL_IDX;
07447
07448 if (IL_NONDEFAULT_IMP_DO_LCV(list_idx)) {
07449
07450
07451 if (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
07452 new_root = copy_text_for_expansion(FL_IO_MIDDLE);
07453
07454 if (IR_OPR(new_root) == Alt_Return_Opr ||
07455 IR_OPR(new_root) == Asg_Opr) {
07456
07457 io_idx = IR_IDX_R(new_root);
07458 }
07459 else {
07460 io_idx = new_root;
07461 }
07462
07463 IR_FLD_R(io_idx) = IL_Tbl_Idx;
07464 IR_IDX_R(io_idx) = IL_NEXT_LIST_IDX(list_idx);
07465 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt;
07466 }
07467
07468 gen_sh(After, stmt_type, stmt_start_line, stmt_start_col,
07469 FALSE, FALSE, TRUE);
07470
07471 SH_IR_IDX(curr_stmt_sh_idx) = IL_IDX(IR_IDX_R(IL_IDX(list_idx)));
07472 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07473 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07474
07475 # ifdef _DEBUG
07476 if (IL_FLD(IR_IDX_R(IL_IDX(list_idx))) != IR_Tbl_Idx ||
07477 IR_OPR(IL_IDX(IR_IDX_R(IL_IDX(list_idx)))) != Asg_Opr ||
07478 IR_FLD_R(IL_IDX(IR_IDX_R(IL_IDX(list_idx)))) != AT_Tbl_Idx) {
07479
07480 PRINTMSG(stmt_start_line, 1050, Internal, stmt_start_col);
07481 }
07482 # endif
07483 IL_FLD(IR_IDX_R(IL_IDX(list_idx))) = AT_Tbl_Idx;
07484 IL_IDX(IR_IDX_R(IL_IDX(list_idx))) =
07485 IR_IDX_R(IL_IDX(IR_IDX_R(IL_IDX(list_idx))));
07486 IL_LINE_NUM(IR_IDX_R(IL_IDX(list_idx))) = stmt_start_line;
07487 IL_COL_NUM(IR_IDX_R(IL_IDX(list_idx))) = stmt_start_col;
07488
07489 IL_NONDEFAULT_IMP_DO_LCV(list_idx) = FALSE;
07490
07491
07492 if (new_root) {
07493
07494 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
07495
07496 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
07497 IR_LIST_CNT_R(ir_idx) = cnt;
07498
07499 curr_stmt_sh_idx = next_stmt_idx;
07500 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
07501 FALSE, FALSE, TRUE);
07502
07503 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
07504 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07505
07506 if (alt_return_branch_idx) {
07507 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07508 FALSE, FALSE, TRUE);
07509
07510 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07511 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
07512 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07513 }
07514
07515 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07516
07517 expand_io_list();
07518
07519 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
07520 }
07521 }
07522
07523
07524 if (IL_MUST_BE_LOOP(list_idx)) {
07525
07526 if (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
07527 new_root = copy_text_for_expansion(FL_IO_MIDDLE);
07528
07529 if (IR_OPR(new_root) == Alt_Return_Opr ||
07530 IR_OPR(new_root) == Asg_Opr) {
07531
07532 io_idx = IR_IDX_R(new_root);
07533 }
07534 else {
07535 io_idx = new_root;
07536 }
07537
07538 IR_FLD_R(io_idx) = IL_Tbl_Idx;
07539 IR_IDX_R(io_idx) = IL_NEXT_LIST_IDX(list_idx);
07540 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt;
07541 }
07542
07543 if (cnt == 1) {
07544 expand_imp_do(list_idx, 0);
07545 }
07546 else {
07547 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX;
07548 IR_LIST_CNT_R(ir_idx) = cnt - 1;
07549
07550 expand_imp_do(list_idx, next_stmt_idx);
07551 }
07552
07553 if (new_root) {
07554 curr_stmt_sh_idx = next_stmt_idx;
07555 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
07556 FALSE, FALSE, TRUE);
07557
07558 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
07559 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07560
07561 if (alt_return_branch_idx) {
07562 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07563 FALSE, FALSE, TRUE);
07564
07565 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07566 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
07567 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07568 }
07569
07570 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07571
07572 expand_io_list();
07573 }
07574
07575 break;
07576 }
07577 else if (stmt_type == Read_Stmt &&
07578 IL_ARG_DESC_VARIANT(list_idx) &&
07579 (arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.vector_subscript ||
07580 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.dist_reshape_ref)) {
07581
07582 COPY_OPND(opnd, IL_OPND(list_idx));
07583
07584 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
07585 IR_OPR(OPND_IDX(opnd)) == Io_Item_Type_Code_Opr) {
07586 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
07587 }
07588
07589 if (IL_HAS_FUNCTIONS(list_idx) ||
07590 three_call_model) {
07591
07592 if (cnt > 1) {
07593
07594 new_root = copy_text_for_expansion(FL_IO_MIDDLE);
07595
07596 if (IR_OPR(new_root) == Alt_Return_Opr ||
07597 IR_OPR(new_root) == Asg_Opr) {
07598 io_idx = IR_IDX_R(new_root);
07599 }
07600 else {
07601 io_idx = new_root;
07602 }
07603
07604 IR_FLD_R(io_idx) = IL_Tbl_Idx;
07605 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt + 1;
07606 IR_IDX_R(io_idx) = list_idx;
07607
07608 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX;
07609 IR_LIST_CNT_R(ir_idx) = cnt - 1;
07610
07611 curr_stmt_sh_idx = next_stmt_idx;
07612 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
07613 FALSE, FALSE, TRUE);
07614
07615 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
07616 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07617
07618 if (alt_return_branch_idx) {
07619 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07620 FALSE, FALSE, TRUE);
07621
07622 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07623 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
07624 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07625 }
07626
07627 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07628 ir_idx = io_idx;
07629 cnt = 1;
07630 new_root = NULL_IDX;
07631 }
07632 }
07633
07634 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed;
07635 process_deferred_functions(&opnd);
07636
07637 gen_runtime_checks(&opnd);
07638
07639 if (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
07640 new_root = copy_text_for_expansion(FL_IO_MIDDLE);
07641
07642 if (IR_OPR(new_root) == Alt_Return_Opr ||
07643 IR_OPR(new_root) == Asg_Opr) {
07644
07645 io_idx = IR_IDX_R(new_root);
07646 }
07647 else {
07648 io_idx = new_root;
07649 }
07650
07651 IR_FLD_R(io_idx) = IL_Tbl_Idx;
07652 IR_IDX_R(io_idx) = IL_NEXT_LIST_IDX(list_idx);
07653 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt;
07654 }
07655
07656
07657
07658
07659
07660
07661
07662
07663
07664 tmp_idx = create_tmp_asg(&opnd,
07665 &arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed,
07666 &left_opnd,
07667 Intent_In,
07668 TRUE,
07669 FALSE);
07670
07671
07672 # ifdef _DEBUG
07673 if (OPND_FLD(left_opnd) == IR_Tbl_Idx &&
07674 IR_OPR(OPND_IDX(left_opnd)) == Stmt_Expansion_Opr) {
07675 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
07676 "no Stmt_Expansion_Opr", "expand_io_list");
07677 }
07678 # endif
07679
07680 tmp_asg_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07681
07682 SH_PREV_IDX(curr_stmt_sh_idx) = SH_PREV_IDX(tmp_asg_sh_idx);
07683
07684 if (SH_PREV_IDX(curr_stmt_sh_idx)) {
07685 SH_NEXT_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = curr_stmt_sh_idx;
07686 }
07687
07688 SH_NEXT_IDX(tmp_asg_sh_idx) = SH_NEXT_IDX(curr_stmt_sh_idx);
07689 if (SH_NEXT_IDX(tmp_asg_sh_idx)) {
07690 SH_PREV_IDX(SH_NEXT_IDX(tmp_asg_sh_idx)) = tmp_asg_sh_idx;
07691 }
07692 SH_NEXT_IDX(curr_stmt_sh_idx) = tmp_asg_sh_idx;
07693 SH_PREV_IDX(tmp_asg_sh_idx) = curr_stmt_sh_idx;
07694
07695
07696 curr_stmt_sh_idx = tmp_asg_sh_idx;
07697 COPY_OPND(IR_OPND_L(SH_IR_IDX(curr_stmt_sh_idx)),
07698 IR_OPND_R(SH_IR_IDX(curr_stmt_sh_idx)));
07699 COPY_OPND(IR_OPND_R(SH_IR_IDX(curr_stmt_sh_idx)),
07700 left_opnd);
07701
07702 copy_subtree(&left_opnd, &left_opnd);
07703
07704 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
07705 IR_OPR(IL_IDX(list_idx)) == Io_Item_Type_Code_Opr) {
07706
07707 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), left_opnd);
07708 IR_TYPE_IDX(IL_IDX(list_idx)) =
07709 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type_idx;
07710 }
07711 else {
07712 COPY_OPND(IL_OPND(list_idx), left_opnd);
07713 }
07714
07715 if (new_root) {
07716
07717 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
07718 IR_LIST_CNT_R(ir_idx) = cnt;
07719
07720 curr_stmt_sh_idx = next_stmt_idx;
07721 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
07722 FALSE, FALSE, TRUE);
07723
07724 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
07725 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07726
07727 if (alt_return_branch_idx) {
07728 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07729 FALSE, FALSE, TRUE);
07730
07731 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07732 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
07733 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07734 }
07735
07736 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07737
07738 expand_io_list();
07739 }
07740
07741 if (IL_STRUCT_REF(list_idx)) {
07742
07743 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed;
07744
07745 if (exp_desc.rank > 0) {
07746 struct_list_idx = list_idx;
07747 imp_idx = change_section_to_do(&struct_list_idx);
07748 COPY_OPND(opnd, IL_OPND(struct_list_idx));
07749 #ifdef KEY
07750 int i = discombobulate_structure_ref(&opnd,
07751 TYP_IDX(exp_desc.type_idx), &struct_list_idx);
07752 cnt += i;
07753 #else
07754 i = discombobulate_structure_ref(&opnd,
07755 TYP_IDX(exp_desc.type_idx),
07756 &struct_list_idx);
07757 #endif
07758 IR_LIST_CNT_L(imp_idx) += i;
07759 }
07760 else {
07761 COPY_OPND(opnd, IL_OPND(list_idx));
07762 #ifdef KEY
07763 int i = discombobulate_structure_ref(&opnd,
07764 TYP_IDX(exp_desc.type_idx), &list_idx);
07765 cnt += i;
07766 #else
07767 i = discombobulate_structure_ref(&opnd,
07768 TYP_IDX(exp_desc.type_idx),
07769 &list_idx);
07770 #endif
07771 IR_LIST_CNT_R(ir_idx) += i;
07772 }
07773 }
07774
07775 break;
07776 }
07777 else if (IL_MUST_FLATTEN(list_idx)) {
07778
07779 COPY_OPND(opnd, IL_OPND(list_idx));
07780
07781 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
07782 IR_OPR(OPND_IDX(opnd)) == Io_Item_Type_Code_Opr) {
07783 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
07784 }
07785
07786 if (IL_HAS_FUNCTIONS(list_idx) ||
07787 three_call_model) {
07788
07789 if ((stmt_type == Read_Stmt ||
07790 three_call_model) &&
07791 cnt > 1) {
07792
07793 new_root = copy_text_for_expansion(FL_IO_MIDDLE);
07794
07795 if (IR_OPR(new_root) == Alt_Return_Opr ||
07796 IR_OPR(new_root) == Asg_Opr) {
07797 io_idx = IR_IDX_R(new_root);
07798 }
07799 else {
07800 io_idx = new_root;
07801 }
07802
07803 IR_FLD_R(io_idx) = IL_Tbl_Idx;
07804 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt + 1;
07805 IR_IDX_R(io_idx) = list_idx;
07806
07807 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX;
07808 IR_LIST_CNT_R(ir_idx) = cnt - 1;
07809
07810 curr_stmt_sh_idx = next_stmt_idx;
07811 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
07812 FALSE, FALSE, TRUE);
07813
07814 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
07815 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07816
07817 if (alt_return_branch_idx) {
07818 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07819 FALSE, FALSE, TRUE);
07820
07821 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07822 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
07823 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07824 }
07825
07826 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07827 ir_idx = io_idx;
07828 cnt = 1;
07829 }
07830
07831 }
07832
07833 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed;
07834 process_deferred_functions(&opnd);
07835
07836 gen_runtime_checks(&opnd);
07837
07838 tmp_idx = create_tmp_asg(&opnd,
07839 &arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed,
07840 &left_opnd,
07841 (stmt_type == Read_Stmt ?
07842 Intent_Out : Intent_In),
07843 TRUE,
07844 FALSE);
07845
07846 copy_subtree(&left_opnd, &left_opnd);
07847
07848 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
07849 IR_OPR(IL_IDX(list_idx)) == Io_Item_Type_Code_Opr) {
07850
07851 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), left_opnd);
07852 IR_TYPE_IDX(IL_IDX(list_idx)) =
07853 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type_idx;
07854 }
07855 else {
07856 COPY_OPND(IL_OPND(list_idx), left_opnd);
07857 }
07858 }
07859 else if (IL_HAS_FUNCTIONS(list_idx) ||
07860 three_call_model) {
07861
07862 if ((stmt_type == Read_Stmt ||
07863 three_call_model) &&
07864 cnt > 1) {
07865
07866 new_root = copy_text_for_expansion(FL_IO_MIDDLE);
07867
07868 if (IR_OPR(new_root) == Alt_Return_Opr ||
07869 IR_OPR(new_root) == Asg_Opr) {
07870
07871 io_idx = IR_IDX_R(new_root);
07872 }
07873 else {
07874 io_idx = new_root;
07875 }
07876
07877 IR_FLD_R(io_idx) = IL_Tbl_Idx;
07878 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt + 1;
07879 IR_IDX_R(io_idx) = list_idx;
07880
07881 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX;
07882 IR_LIST_CNT_R(ir_idx) = cnt - 1;
07883
07884 curr_stmt_sh_idx = next_stmt_idx;
07885 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
07886 FALSE, FALSE, TRUE);
07887
07888 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
07889 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07890
07891 if (alt_return_branch_idx) {
07892 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
07893 FALSE, FALSE, TRUE);
07894
07895 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07896 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
07897 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
07898 }
07899
07900 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07901 ir_idx = io_idx;
07902 cnt = 1;
07903 }
07904
07905 COPY_OPND(opnd, IL_OPND(list_idx));
07906 process_deferred_functions(&opnd);
07907 COPY_OPND(IL_OPND(list_idx), opnd);
07908
07909 gen_runtime_checks(&opnd);
07910 }
07911 else if (IL_HAS_CONSTRUCTOR(list_idx)) {
07912 COPY_OPND(opnd, IL_OPND(list_idx));
07913 process_deferred_functions(&opnd);
07914 COPY_OPND(IL_OPND(list_idx), opnd);
07915
07916 gen_runtime_checks(&opnd);
07917 }
07918
07919 if (IL_STRUCT_REF(list_idx)) {
07920
07921 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed;
07922
07923 if (exp_desc.rank > 0) {
07924 struct_list_idx = list_idx;
07925 imp_idx = change_section_to_do(&struct_list_idx);
07926 COPY_OPND(opnd, IL_OPND(struct_list_idx));
07927 #ifdef KEY
07928 int i = discombobulate_structure_ref(&opnd,
07929 TYP_IDX(exp_desc.type_idx), &struct_list_idx);
07930 cnt += i;
07931 #else
07932 i = discombobulate_structure_ref(&opnd,
07933 TYP_IDX(exp_desc.type_idx),
07934 &struct_list_idx);
07935 #endif
07936 IR_LIST_CNT_L(imp_idx) += i;
07937 }
07938 else {
07939 COPY_OPND(opnd, IL_OPND(list_idx));
07940 #ifdef KEY
07941 int i = discombobulate_structure_ref(&opnd,
07942 TYP_IDX(exp_desc.type_idx), &list_idx);
07943 cnt += i;
07944 #else
07945 i = discombobulate_structure_ref(&opnd,
07946 TYP_IDX(exp_desc.type_idx),
07947 &list_idx);
07948 #endif
07949 IR_LIST_CNT_R(ir_idx) += i;
07950 }
07951 }
07952
07953 prev_list_idx = list_idx;
07954 list_idx = IL_NEXT_LIST_IDX(list_idx);
07955 }
07956
07957 TRACE (Func_Exit, "expand_io_list", NULL);
07958
07959 return;
07960
07961 }
07962
07963
07964
07965
07966
07967
07968
07969
07970
07971
07972
07973
07974
07975
07976
07977
07978
07979 static void expand_imp_do(int top_list_idx,
07980 int next_stmt_idx)
07981
07982 {
07983 opnd_type end_opnd;
07984 int imp_do_idx;
07985 opnd_type inc_opnd;
07986 int io_idx;
07987 int ir_idx;
07988 int lcv_attr;
07989 int list_idx;
07990 int new_root;
07991 opnd_type start_opnd;
07992
07993
07994 TRACE (Func_Entry, "expand_imp_do", NULL);
07995
07996 # ifdef _DEBUG
07997 if (! io_stmt_must_be_split) {
07998 PRINTMSG(stmt_start_line, 433, Internal, stmt_start_col);
07999 }
08000 # endif
08001
08002 imp_do_idx = IL_IDX(top_list_idx);
08003
08004 ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
08005
08006 if (IR_OPR(ir_idx) == Alt_Return_Opr ||
08007 IR_OPR(ir_idx) == Asg_Opr) {
08008
08009 ir_idx = IR_IDX_R(ir_idx);
08010 }
08011
08012 if (next_stmt_idx) {
08013
08014 new_root = copy_text_for_expansion(FL_IO_MIDDLE);
08015
08016 if (IR_OPR(new_root) == Alt_Return_Opr ||
08017 IR_OPR(new_root) == Asg_Opr) {
08018
08019 io_idx = IR_IDX_R(new_root);
08020 }
08021 else {
08022 io_idx = new_root;
08023 }
08024
08025 COPY_OPND(IR_OPND_R(io_idx), IR_OPND_L(imp_do_idx));
08026
08027 curr_stmt_sh_idx = next_stmt_idx;
08028 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col,
08029 FALSE, FALSE, TRUE);
08030
08031 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root;
08032 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08033
08034 if (alt_return_branch_idx) {
08035 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col,
08036 FALSE, FALSE, TRUE);
08037
08038 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
08039 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx;
08040 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
08041 }
08042
08043 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
08044
08045 }
08046 else {
08047
08048
08049
08050 COPY_OPND(IR_OPND_R(ir_idx), IR_OPND_L(imp_do_idx));
08051 }
08052
08053
08054
08055 list_idx = IR_IDX_R(imp_do_idx);
08056 lcv_attr = IL_IDX(list_idx);
08057 list_idx = IL_NEXT_LIST_IDX(list_idx);
08058 COPY_OPND(start_opnd, IL_OPND(list_idx));
08059
08060 if (IL_HAS_FUNCTIONS(list_idx)) {
08061 process_deferred_functions(&start_opnd);
08062 COPY_OPND(IL_OPND(list_idx), start_opnd);
08063 }
08064
08065 gen_runtime_checks(&start_opnd);
08066
08067 list_idx = IL_NEXT_LIST_IDX(list_idx);
08068 COPY_OPND(end_opnd, IL_OPND(list_idx));
08069
08070 if (IL_HAS_FUNCTIONS(list_idx)) {
08071 process_deferred_functions(&end_opnd);
08072 COPY_OPND(IL_OPND(list_idx), end_opnd);
08073 }
08074
08075 gen_runtime_checks(&end_opnd);
08076
08077 list_idx = IL_NEXT_LIST_IDX(list_idx);
08078 COPY_OPND(inc_opnd, IL_OPND(list_idx));
08079
08080 if (IL_HAS_FUNCTIONS(list_idx)) {
08081 process_deferred_functions(&inc_opnd);
08082 COPY_OPND(IL_OPND(list_idx), inc_opnd);
08083 }
08084
08085 gen_runtime_checks(&inc_opnd);
08086
08087 create_loop_stmts(lcv_attr, &start_opnd, &end_opnd, &inc_opnd,
08088 curr_stmt_sh_idx,
08089 (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Alt_Return_Opr ?
08090 SH_NEXT_IDX(curr_stmt_sh_idx) : curr_stmt_sh_idx));
08091
08092 expand_io_list();
08093
08094 TRACE (Func_Exit, "expand_imp_do", NULL);
08095
08096 return;
08097
08098 }
08099
08100
08101
08102
08103
08104
08105
08106
08107
08108
08109
08110
08111
08112
08113
08114
08115
08116 static int copy_text_for_expansion(int flflag)
08117
08118 {
08119 int new_alt_idx;
08120 int new_io_idx;
08121 int new_root;
08122 int old_alt_idx;
08123 int old_io_idx;
08124 opnd_type opnd;
08125
08126
08127 TRACE (Func_Entry, "copy_text_for_expansion", NULL);
08128
08129 # ifdef _DEBUG
08130 if (! io_stmt_must_be_split) {
08131 PRINTMSG(stmt_start_line, 433, Internal, stmt_start_col);
08132 }
08133 # endif
08134
08135 if (alt_return_branch_idx ||
08136 stmt_type == Inquire_Stmt) {
08137
08138 NTR_IR_TBL(new_alt_idx);
08139 old_alt_idx = SH_IR_IDX(curr_stmt_sh_idx);
08140 COPY_TBL_NTRY(ir_tbl, new_alt_idx, old_alt_idx);
08141 NTR_IR_TBL(new_io_idx);
08142 old_io_idx = IR_IDX_R(old_alt_idx);
08143 COPY_TBL_NTRY(ir_tbl, new_io_idx, old_io_idx);
08144 IR_OPND_R(new_io_idx) = null_opnd;
08145 IR_IDX_R(new_alt_idx) = new_io_idx;
08146 new_root = new_alt_idx;
08147 }
08148 else {
08149 NTR_IR_TBL(new_io_idx);
08150 old_io_idx = SH_IR_IDX(curr_stmt_sh_idx);
08151 COPY_TBL_NTRY(ir_tbl, new_io_idx, old_io_idx);
08152 IR_OPND_R(new_io_idx) = null_opnd;
08153 new_root = new_io_idx;
08154 }
08155
08156 copy_subtree(&IR_OPND_L(old_io_idx), &opnd);
08157 COPY_OPND(IR_OPND_L(new_io_idx), opnd);
08158
08159 if (stmt_type == Inquire_Stmt) {
08160 IL_IDX(IR_IDX_L(new_io_idx)) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08161 flflag);
08162 }
08163 else {
08164 IL_IDX(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(new_io_idx)))) =
08165 C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08166 flflag);
08167 }
08168
08169 TRACE (Func_Exit, "copy_text_for_expansion", NULL);
08170
08171 return(new_root);
08172
08173 }
08174
08175
08176
08177
08178
08179
08180
08181
08182
08183
08184
08185
08186
08187
08188
08189
08190
08191
08192 static void create_io_call_descriptor(int call_idx,
08193 io_descriptor_type call_type)
08194
08195 {
08196 int asg_idx;
08197 int bd_idx;
08198 int col;
08199 boolean gen_descriptor;
08200 int item_cnt;
08201 int line;
08202 int list_idx;
08203 int list2_idx;
08204 int loc_idx;
08205 int offset;
08206 int shift_idx;
08207 int subscript_idx;
08208 long64 the_constant;
08209 int tmp_idx;
08210 int type_idx;
08211 int version_cn_idx;
08212
08213 # define IO_CALL_VERSION 0
08214
08215
08216 TRACE (Func_Entry, "create_io_call_descriptor", NULL);
08217
08218 col = IR_COL_NUM(call_idx);
08219 line = IR_LINE_NUM(call_idx);
08220
08221 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
08222 type_idx = SA_INTEGER_DEFAULT_TYPE;
08223 # else
08224 type_idx = CG_INTEGER_DEFAULT_TYPE;
08225 # endif
08226
08227 version_cn_idx = C_INT_TO_CN(type_idx, IO_CALL_VERSION);
08228
08229 # if defined(_FILE_IO_OPRS)
08230 if (call_type == Buffer_Desc) {
08231 gen_descriptor = TRUE;
08232 }
08233 else {
08234 gen_descriptor = FALSE;
08235 }
08236 # else
08237 gen_descriptor = TRUE;
08238 # endif
08239
08240 if (! gen_descriptor) {
08241
08242 NTR_IR_LIST_TBL(list_idx);
08243 IL_NEXT_LIST_IDX(list_idx) = IR_IDX_R(call_idx);
08244 IR_IDX_R(call_idx) = list_idx;
08245 IR_LIST_CNT_R(call_idx) += 1;
08246
08247 IL_FLD(list_idx) = CN_Tbl_Idx;
08248 IL_IDX(list_idx) = version_cn_idx;
08249 IL_LINE_NUM(list_idx) = line;
08250 IL_COL_NUM(list_idx) = col;
08251
08252 }
08253 else {
08254
08255
08256 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
08257 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
08258 ATD_TYPE_IDX(tmp_idx) = type_idx;
08259 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
08260
08261 bd_idx = reserve_array_ntry(1);
08262 BD_RANK(bd_idx) = 1;
08263 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape;
08264 BD_ARRAY_SIZE(bd_idx) = Constant_Size;
08265 BD_LINE_NUM(bd_idx) = line;
08266 BD_COLUMN_NUM(bd_idx) = col;
08267 BD_RESOLVED(bd_idx) = TRUE;
08268
08269 if (two_word_fcd) {
08270 the_constant = descriptor_size_tbl[call_type];
08271 }
08272 else {
08273 the_constant = 1 + IR_LIST_CNT_R(call_idx);
08274 }
08275
08276 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
08277
08278 if (TYP_LINEAR(type_idx) == Integer_4) {
08279 the_constant++;
08280 }
08281 # endif
08282
08283 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx;
08284 BD_LEN_IDX(bd_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08285 the_constant);
08286
08287 BD_LB_FLD(bd_idx, 1) = CN_Tbl_Idx;
08288 BD_LB_IDX(bd_idx, 1) = CN_INTEGER_ONE_IDX;
08289
08290 BD_UB_FLD(bd_idx, 1) = CN_Tbl_Idx;
08291 BD_UB_IDX(bd_idx, 1) = BD_LEN_IDX(bd_idx);
08292
08293 BD_XT_FLD(bd_idx, 1) = CN_Tbl_Idx;
08294 BD_XT_IDX(bd_idx, 1) = BD_LEN_IDX(bd_idx);
08295
08296 BD_SM_FLD(bd_idx, 1) = CN_Tbl_Idx;
08297 BD_SM_IDX(bd_idx, 1) = CN_INTEGER_ONE_IDX;
08298
08299 ATD_ARRAY_IDX(tmp_idx) = ntr_array_in_bd_tbl(bd_idx);
08300
08301
08302
08303
08304 item_cnt = 0;
08305
08306 NTR_IR_TBL(asg_idx);
08307 IR_OPR(asg_idx) = Asg_Opr;
08308 IR_TYPE_IDX(asg_idx) = type_idx;
08309 IR_LINE_NUM(asg_idx) = line;
08310 IR_COL_NUM(asg_idx) = col;
08311 NTR_IR_TBL(subscript_idx);
08312 IR_OPR(subscript_idx) = Subscript_Opr;
08313 IR_TYPE_IDX(subscript_idx) = type_idx;
08314 IR_LINE_NUM(subscript_idx) = line;
08315 IR_COL_NUM(subscript_idx) = col;
08316 IR_FLD_L(subscript_idx) = AT_Tbl_Idx;
08317 IR_IDX_L(subscript_idx) = tmp_idx;
08318 IR_LINE_NUM_L(subscript_idx) = line;
08319 IR_COL_NUM_L(subscript_idx) = col;
08320
08321 NTR_IR_LIST_TBL(list2_idx);
08322 IR_FLD_R(subscript_idx) = IL_Tbl_Idx;
08323 IR_LIST_CNT_R(subscript_idx) = 1;
08324 IR_IDX_R(subscript_idx) = list2_idx;
08325 IL_FLD(list2_idx) = CN_Tbl_Idx;
08326 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX;
08327 IL_LINE_NUM(list2_idx) = line;
08328 IL_COL_NUM(list2_idx) = col;
08329
08330 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
08331 IR_IDX_L(asg_idx) = subscript_idx;
08332
08333 IR_FLD_R(asg_idx) = CN_Tbl_Idx;
08334 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
08335 if (TYP_LINEAR(type_idx) == Integer_4) {
08336 IR_IDX_R(asg_idx) = CN_INTEGER_ZERO_IDX;
08337 }
08338 else {
08339 IR_IDX_R(asg_idx) = version_cn_idx;
08340 }
08341 # else
08342 IR_IDX_R(asg_idx) = version_cn_idx;
08343 # endif
08344 IR_LINE_NUM_R(asg_idx) = line;
08345 IR_COL_NUM_R(asg_idx) = col;
08346
08347 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
08348 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08349 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08350
08351 item_cnt++;
08352 the_constant = 2;
08353
08354 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
08355 if (TYP_LINEAR(type_idx) == Integer_4) {
08356 NTR_IR_TBL(asg_idx);
08357 IR_OPR(asg_idx) = Asg_Opr;
08358 IR_TYPE_IDX(asg_idx) = type_idx;
08359 IR_LINE_NUM(asg_idx) = line;
08360 IR_COL_NUM(asg_idx) = col;
08361 NTR_IR_TBL(subscript_idx);
08362 IR_OPR(subscript_idx) = Subscript_Opr;
08363 IR_TYPE_IDX(subscript_idx) = type_idx;
08364 IR_LINE_NUM(subscript_idx) = line;
08365 IR_COL_NUM(subscript_idx) = col;
08366 IR_FLD_L(subscript_idx) = AT_Tbl_Idx;
08367 IR_IDX_L(subscript_idx) = tmp_idx;
08368 IR_LINE_NUM_L(subscript_idx) = line;
08369 IR_COL_NUM_L(subscript_idx) = col;
08370
08371 NTR_IR_LIST_TBL(list2_idx);
08372 IR_FLD_R(subscript_idx) = IL_Tbl_Idx;
08373 IR_LIST_CNT_R(subscript_idx) = 1;
08374 IR_IDX_R(subscript_idx) = list2_idx;
08375 IL_FLD(list2_idx) = CN_Tbl_Idx;
08376 IL_IDX(list2_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08377 the_constant);
08378 IL_LINE_NUM(list2_idx) = line;
08379 IL_COL_NUM(list2_idx) = col;
08380
08381 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
08382 IR_IDX_L(asg_idx) = subscript_idx;
08383
08384 IR_FLD_R(asg_idx) = CN_Tbl_Idx;
08385 IR_IDX_R(asg_idx) = version_cn_idx;
08386 IR_LINE_NUM_R(asg_idx) = line;
08387 IR_COL_NUM_R(asg_idx) = col;
08388
08389 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
08390 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08391 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08392
08393 the_constant++;
08394 }
08395 # endif
08396
08397 list_idx = IR_IDX_R(call_idx);
08398
08399 while (list_idx) {
08400
08401 NTR_IR_TBL(asg_idx);
08402 IR_OPR(asg_idx) = Asg_Opr;
08403 IR_TYPE_IDX(asg_idx) = type_idx;
08404 IR_LINE_NUM(asg_idx) = line;
08405 IR_COL_NUM(asg_idx) = col;
08406 NTR_IR_TBL(subscript_idx);
08407 IR_OPR(subscript_idx) = Subscript_Opr;
08408 IR_TYPE_IDX(subscript_idx) = type_idx;
08409 IR_LINE_NUM(subscript_idx) = line;
08410 IR_COL_NUM(subscript_idx) = col;
08411 IR_FLD_L(subscript_idx) = AT_Tbl_Idx;
08412 IR_IDX_L(subscript_idx) = tmp_idx;
08413 IR_LINE_NUM_L(subscript_idx) = line;
08414 IR_COL_NUM_L(subscript_idx) = col;
08415
08416 NTR_IR_LIST_TBL(list2_idx);
08417 IR_FLD_R(subscript_idx) = IL_Tbl_Idx;
08418 IR_LIST_CNT_R(subscript_idx) = 1;
08419 IR_IDX_R(subscript_idx) = list2_idx;
08420 IL_FLD(list2_idx) = CN_Tbl_Idx;
08421 IL_IDX(list2_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08422 the_constant);
08423 IL_LINE_NUM(list2_idx) = line;
08424 IL_COL_NUM(list2_idx) = col;
08425
08426 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
08427 IR_IDX_L(asg_idx) = subscript_idx;
08428
08429 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
08430 IR_OPR(IL_IDX(list_idx)) == Aloc_Opr) {
08431
08432 IR_OPR(IL_IDX(list_idx)) = Loc_Opr;
08433 }
08434
08435 COPY_OPND(IR_OPND_R(asg_idx), IL_OPND(list_idx));
08436
08437 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
08438 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08439 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08440
08441 offset = offset_tbl[call_type][item_cnt];
08442
08443 if (two_word_fcd) {
08444
08445 if (IL_FLD(list_idx) != IR_Tbl_Idx ||
08446 IR_OPR(IL_IDX(list_idx)) != Loc_Opr ||
08447 TYP_LINEAR(IR_TYPE_IDX(IL_IDX(list_idx))) != CRI_Ch_Ptr_8) {
08448
08449 the_constant += offset;
08450 }
08451 else {
08452 the_constant++;
08453
08454 if (offset == 2) {
08455
08456 NTR_IR_TBL(asg_idx);
08457 IR_OPR(asg_idx) = Asg_Opr;
08458 IR_TYPE_IDX(asg_idx) = type_idx;
08459 IR_LINE_NUM(asg_idx) = line;
08460 IR_COL_NUM(asg_idx) = col;
08461 NTR_IR_TBL(subscript_idx);
08462 IR_OPR(subscript_idx) = Subscript_Opr;
08463 IR_TYPE_IDX(subscript_idx) = type_idx;
08464 IR_LINE_NUM(subscript_idx) = line;
08465 IR_COL_NUM(subscript_idx) = col;
08466 IR_FLD_L(subscript_idx) = AT_Tbl_Idx;
08467 IR_IDX_L(subscript_idx) = tmp_idx;
08468 IR_LINE_NUM_L(subscript_idx) = line;
08469 IR_COL_NUM_L(subscript_idx) = col;
08470
08471 NTR_IR_LIST_TBL(list2_idx);
08472 IR_FLD_R(subscript_idx) = IL_Tbl_Idx;
08473 IR_LIST_CNT_R(subscript_idx) = 1;
08474 IR_IDX_R(subscript_idx) = list2_idx;
08475 IL_FLD(list2_idx) = CN_Tbl_Idx;
08476 IL_IDX(list2_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08477 the_constant);
08478 IL_LINE_NUM(list2_idx) = line;
08479 IL_COL_NUM(list2_idx) = col;
08480
08481 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
08482 IR_IDX_L(asg_idx) = subscript_idx;
08483
08484 # ifdef _DEBUG
08485 if (IL_FLD(list_idx) != IR_Tbl_Idx ||
08486 IR_OPR(IL_IDX(list_idx)) != Loc_Opr ||
08487 IR_FLD_L(IL_IDX(list_idx)) != IR_Tbl_Idx ||
08488 (IR_OPR(IR_IDX_L(IL_IDX(list_idx))) != Substring_Opr &&
08489 IR_OPR(IR_IDX_L(IL_IDX(list_idx))) !=
08490 Whole_Substring_Opr)) {
08491
08492 PRINTMSG(line, 1022, Internal, col);
08493 }
08494 # endif
08495
08496 if (char_len_in_bytes) {
08497
08498 COPY_OPND(IR_OPND_R(asg_idx),
08499 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(
08500 IR_IDX_L(IL_IDX(list_idx)))))));
08501 }
08502 else {
08503
08504 NTR_IR_TBL(shift_idx);
08505 IR_OPR(shift_idx) = Shiftl_Opr;
08506 IR_TYPE_IDX(shift_idx) = type_idx;
08507 IR_LINE_NUM(shift_idx) = line;
08508 IR_COL_NUM(shift_idx) = col;
08509
08510 NTR_IR_LIST_TBL(list2_idx);
08511 IR_FLD_L(shift_idx) = IL_Tbl_Idx;
08512 IR_IDX_L(shift_idx) = list2_idx;
08513 IR_LIST_CNT_L(shift_idx) = 2;
08514
08515 COPY_OPND(IL_OPND(list2_idx),
08516 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(
08517 IR_IDX_L(IL_IDX(list_idx)))))));
08518
08519 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
08520 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
08521 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
08522
08523 IL_LINE_NUM(list2_idx) = line;
08524 IL_COL_NUM(list2_idx) = col;
08525 IL_FLD(list2_idx) = CN_Tbl_Idx;
08526 IL_IDX(list2_idx) = CN_INTEGER_THREE_IDX;
08527 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
08528 IR_IDX_R(asg_idx) = shift_idx;
08529 }
08530
08531 gen_sh(Before,Assignment_Stmt,line,col,FALSE,FALSE,TRUE);
08532 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08533 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08534
08535 the_constant++;
08536 }
08537 }
08538 }
08539 else {
08540 the_constant++;
08541 }
08542
08543 list_idx = IL_NEXT_LIST_IDX(list_idx);
08544 item_cnt++;
08545 }
08546
08547
08548
08549 # if 0
08550 if (IR_IDX_L(call_idx) == glb_tbl_idx[Buffer_In_Attr_Idx] ||
08551 IR_IDX_L(call_Idx) == glb_tbl_idx[Buffer_Out_Attr_Idx]) {
08552
08553 list_idx = IR_IDX_R(call_idx);
08554 }
08555 else {
08556 IR_LIST_CNT_R(call_idx) = 1;
08557 NTR_IR_LIST_TBL(list_idx);
08558 IR_IDX_R(call_idx) = list_idx;
08559 }
08560 # else
08561
08562 IR_LIST_CNT_R(call_idx) = 1;
08563 NTR_IR_LIST_TBL(list_idx);
08564 IR_IDX_R(call_idx) = list_idx;
08565
08566 # endif
08567
08568 NTR_IR_TBL(loc_idx);
08569 IR_OPR(loc_idx) = Aloc_Opr;
08570 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
08571 IR_LINE_NUM(loc_idx) = line;
08572 IR_COL_NUM(loc_idx) = col;
08573
08574 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
08575 IR_IDX_L(loc_idx) = tmp_idx;
08576 IR_LINE_NUM_L(loc_idx) = line;
08577 IR_COL_NUM_L(loc_idx) = col;
08578
08579 IL_FLD(list_idx) = IR_Tbl_Idx;
08580 IL_IDX(list_idx) = loc_idx;
08581
08582 }
08583
08584 TRACE (Func_Exit, "create_io_call_descriptor", NULL);
08585
08586 return;
08587
08588 }
08589
08590
08591
08592
08593
08594
08595
08596
08597
08598
08599
08600
08601
08602
08603
08604
08605
08606 void set_sb_first_attr_idx(int attr_idx)
08607
08608 {
08609 int tmp_idx;
08610 int type_idx;
08611
08612 TRACE (Func_Entry, "set_sb_first_attr_idx", NULL);
08613
08614 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
08615 TYP_TYPE(TYP_WORK_IDX) = Typeless;
08616 TYP_LINEAR(TYP_WORK_IDX) = Long_Typeless;
08617 TYP_BIT_LEN(TYP_WORK_IDX) = CHAR_BIT;
08618 type_idx = ntr_type_tbl();
08619
08620 tmp_idx = gen_compiler_tmp(stmt_start_line, stmt_start_col, Priv, TRUE);
08621
08622 ATD_TYPE_IDX(tmp_idx) = type_idx;
08623 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
08624 ATD_OFFSET_ASSIGNED(tmp_idx) = TRUE;
08625 ATD_OFFSET_IDX(tmp_idx) = CN_INTEGER_ZERO_IDX;
08626 ATD_OFFSET_FLD(tmp_idx) = CN_Tbl_Idx;
08627
08628 ATD_STOR_BLK_IDX(tmp_idx) = ATD_STOR_BLK_IDX(attr_idx);
08629
08630 SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) = tmp_idx;
08631
08632 TRACE (Func_Exit, "set_sb_first_attr_idx", NULL);
08633
08634 return;
08635
08636 }
08637
08638
08639
08640
08641
08642
08643
08644
08645
08646
08647
08648
08649
08650
08651
08652
08653
08654 # ifdef _NO_IO_ALTERNATE_RETURN
08655 static void add_alt_return_lbl(int ir_idx,
08656 int lbl_attr_idx)
08657
08658 {
08659
08660 int list_idx;
08661
08662 TRACE (Func_Entry, "add_alt_return_lbl", NULL);
08663
08664 list_idx = IR_IDX_R(ir_idx);
08665 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
08666 list_idx = IL_NEXT_LIST_IDX(list_idx);
08667 }
08668
08669 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
08670 IL_ARG_DESC_VARIANT(IL_NEXT_LIST_IDX(list_idx)) = TRUE;
08671 list_idx = IL_NEXT_LIST_IDX(list_idx);
08672
08673 if (lbl_attr_idx != NULL_IDX) {
08674 IL_FLD(list_idx) = AT_Tbl_Idx;
08675 IL_IDX(list_idx) = lbl_attr_idx;
08676 }
08677 IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx);
08678 IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx);
08679
08680 IR_LIST_CNT_R(ir_idx) += 1;
08681
08682 TRACE (Func_Exit, "add_alt_return_lbl", NULL);
08683
08684 return;
08685
08686 }
08687 # endif
08688
08689
08690
08691
08692
08693
08694
08695
08696
08697
08698
08699
08700
08701
08702
08703
08704
08705 static boolean item_has_bounds_chk(opnd_type *top_opnd)
08706
08707 {
08708
08709 boolean bounds_chk = FALSE;
08710 int ir_idx;
08711 int list_idx;
08712 opnd_type opnd;
08713
08714 TRACE (Func_Entry, "item_has_bounds_chk", NULL);
08715
08716 switch (OPND_FLD((*top_opnd))) {
08717 case IR_Tbl_Idx:
08718 ir_idx = OPND_IDX((*top_opnd));
08719
08720 if (IR_OPR(ir_idx) == Substring_Opr &&
08721 cmd_line_flags.runtime_substring &&
08722 ATD_CLASS(find_left_attr(&IR_OPND_L(ir_idx))) != Compiler_Tmp) {
08723
08724 bounds_chk = TRUE;
08725 }
08726 else if ((IR_OPR(ir_idx) == Subscript_Opr ||
08727 IR_OPR(ir_idx) == Section_Subscript_Opr) &&
08728 needs_bounds_check(ir_idx)) {
08729
08730 bounds_chk = TRUE;
08731 }
08732 else if (IR_OPR(ir_idx) == Dv_Deref_Opr &&
08733 cmd_line_flags.runtime_ptr_chk &&
08734 ATD_CLASS(find_left_attr(&IR_OPND_L(ir_idx))) != Compiler_Tmp) {
08735
08736 bounds_chk = TRUE;
08737 }
08738 else {
08739 COPY_OPND(opnd, IR_OPND_L(ir_idx));
08740 bounds_chk = item_has_bounds_chk(&opnd);
08741
08742 if (! bounds_chk) {
08743 COPY_OPND(opnd, IR_OPND_R(ir_idx));
08744 bounds_chk = item_has_bounds_chk(&opnd);
08745 }
08746 }
08747 break;
08748
08749 case IL_Tbl_Idx:
08750 list_idx = OPND_IDX((*top_opnd));
08751
08752 while (list_idx) {
08753 COPY_OPND(opnd, IL_OPND(list_idx));
08754
08755 if (item_has_bounds_chk(&opnd)) {
08756 bounds_chk = TRUE;
08757 break;
08758 }
08759 list_idx = IL_NEXT_LIST_IDX(list_idx);
08760 }
08761 break;
08762 }
08763
08764 TRACE (Func_Exit, "item_has_bounds_chk", NULL);
08765
08766 return(bounds_chk);
08767
08768 }
08769
08770
08771
08772
08773
08774
08775
08776
08777
08778
08779
08780
08781
08782
08783
08784
08785
08786 static void gen_array_element_init(int attr_idx,
08787 long_type *idx_constant,
08788 opnd_type *rhs_opnd,
08789 int opr,
08790 int offset)
08791
08792 {
08793 #ifdef KEY
08794 int asg_idx = 0;
08795 #else
08796 int asg_idx;
08797 #endif
08798 opnd_type opnd[2];
08799 int col;
08800 int i;
08801 int line;
08802 int list_idx;
08803 int num_values = 1;
08804 int sub_idx;
08805 int type_idx;
08806
08807 TRACE (Func_Entry, "gen_array_element_init", NULL);
08808
08809 find_opnd_line_and_column(rhs_opnd, &line, &col);
08810
08811 type_idx = ATD_TYPE_IDX(attr_idx);
08812
08813 if (OPND_FLD((*rhs_opnd)) == CN_Tbl_Idx) {
08814
08815 if (TYP_LINEAR(type_idx) == Integer_4 &&
08816 (sizeof(long_type) == 4 || Is_Target_32bit()) &&
08817 TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*rhs_opnd)))) == Integer_8) {
08818
08819
08820
08821
08822
08823
08824
08825 int* the_constant = (int *) &CP_CONSTANT(CN_POOL_IDX(
08826 OPND_IDX((*rhs_opnd))));
08827 gen_opnd(&(opnd[0]),
08828 ntr_const_tbl(Integer_4,
08829 FALSE,
08830 the_constant),
08831 CN_Tbl_Idx,
08832 line,
08833 col);
08834 gen_opnd(&(opnd[1]),
08835 ntr_const_tbl(Integer_4,
08836 FALSE,
08837 the_constant + 1),
08838 CN_Tbl_Idx,
08839 line,
08840 col);
08841 num_values = 2;
08842 }
08843 else {
08844 opnd[0] = *rhs_opnd;
08845 }
08846 }
08847 else {
08848 opnd[0] = *rhs_opnd;
08849 }
08850
08851 # ifdef _DEBUG
08852 # ifndef _INIT_RELOC_BASE_OFFSET
08853 if (offset) {
08854 PRINTMSG(line, 626, Internal, col,
08855 "offset == 0", "gen_array_element_init");
08856 }
08857 # endif
08858 # endif
08859
08860 for (i = 0; i < num_values; i++) {
08861 NTR_IR_TBL(sub_idx);
08862 IR_OPR(sub_idx) = Subscript_Opr;
08863 IR_TYPE_IDX(sub_idx) = type_idx;
08864 IR_LINE_NUM(sub_idx) = line;
08865 IR_COL_NUM(sub_idx) = col;
08866
08867 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
08868 IR_IDX_L(sub_idx) = attr_idx;
08869 IR_LINE_NUM_L(sub_idx) = line;
08870 IR_COL_NUM_L(sub_idx) = col;
08871
08872 list_idx = gen_il(1,
08873 FALSE,
08874 line,
08875 col,
08876 CN_Tbl_Idx,
08877 ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE,
08878 FALSE,
08879 idx_constant));
08880
08881 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
08882 IR_IDX_R(sub_idx) = list_idx;
08883 IR_LIST_CNT_R(sub_idx) = 1;
08884
08885
08886 if (opr == Asg_Opr) {
08887 asg_idx = gen_ir(IR_Tbl_Idx, sub_idx,
08888 Asg_Opr, type_idx, line, col,
08889 OPND_FLD(opnd[i]), OPND_IDX(opnd[i]));
08890 }
08891 else if (opr == Init_Opr) {
08892 asg_idx = gen_ir(IR_Tbl_Idx, sub_idx,
08893 Init_Opr, type_idx, line, col,
08894 IL_Tbl_Idx, gen_il(3,
08895 FALSE,
08896 line,
08897 col,
08898 OPND_FLD(opnd[i]),
08899 OPND_IDX(opnd[i]),
08900 CN_Tbl_Idx,
08901 CN_INTEGER_ONE_IDX,
08902 CN_Tbl_Idx,
08903 CN_INTEGER_ZERO_IDX));
08904 }
08905 else if (opr == Init_Reloc_Opr) {
08906 asg_idx = gen_ir(IR_Tbl_Idx, sub_idx,
08907 Init_Reloc_Opr, type_idx, line, col,
08908 IL_Tbl_Idx, gen_il(2,
08909 FALSE,
08910 line,
08911 col,
08912 OPND_FLD(opnd[i]),
08913 OPND_IDX(opnd[i]),
08914 CN_Tbl_Idx,
08915 offset ? offset
08916 : CN_INTEGER_ZERO_IDX));
08917 }
08918 else {
08919 PRINTMSG(line, 626, Internal, col,
08920 "Asg_Opr or Init_Opr", "gen_array_element_init");
08921 }
08922
08923 gen_sh(After, Assignment_Stmt, line, col,
08924 FALSE, FALSE, TRUE);
08925 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
08926 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
08927
08928 *idx_constant += 1;
08929 }
08930
08931 TRACE (Func_Exit, "gen_array_element_init", NULL);
08932
08933 return;
08934
08935 }
