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
00046
00047
00048 static char USMID[] = "\n@(#)5.0_pl/sources/s_call.c 5.15 10/19/99 17:14:30\n";
00049
00050 # include "defines.h"
00051
00052 # include "host.m"
00053 # include "host.h"
00054 # include "target.m"
00055 # include "target.h"
00056
00057 # include "globals.m"
00058 # include "tokens.m"
00059 # include "sytb.m"
00060 # include "s_globals.m"
00061 # include "debug.m"
00062 # include "s_call.m"
00063
00064 # include "globals.h"
00065 # include "tokens.h"
00066 # include "sytb.h"
00067 # include "s_globals.h"
00068 # include "s_call.h"
00069
00070 # ifdef KEY
00071 extern boolean LANG_Read_Write_Const;
00072 extern boolean LANG_Copy_Inout;
00073 extern unsigned int LANG_Copy_Inout_Level;
00074 # endif
00075 #ifdef KEY
00076 extern boolean LANG_Ignore_Target_Attribute;
00077 #endif
00078 boolean variable_size_func_expr = FALSE;
00079 #ifdef KEY
00080 #define MAX_DIMENSION 14
00081 #endif
00082
00083 #ifdef KEY
00084
00085
00086
00087
00088 static int stop_recursion = FALSE;
00089
00090 #ifdef _DEBUG
00091
00092 static int check_contig_flag_count = 0;
00093 static int copy_in_make_dv_count = 0;
00094 static int make_dv_count = 0;
00095 static int copy_in_copy_out_count = 0;
00096 static int copy_in_count = 0;
00097 static int pass_dv_copy_count = 0;
00098 static int pass_dv_count = 0;
00099 static int pass_address_from_dv_count = 0;
00100 static int pass_section_address_count = 0;
00101 static int pass_address_count = 0;
00102 static int copy_inout_make_dv_count = 0;
00103
00104 static int move_copyinout_alloc_count = 0;
00105
00106 static int runtime_copyinout_count = 0;
00107
00108 void print_arg_passing(FILE *fd) {
00109 if (0 == fd) {
00110 fd = stderr;
00111 }
00112 fprintf(fd, "check_contig_flag:\t%d\n", check_contig_flag_count);
00113 fprintf(fd, "copy_in_make_dv:\t%d\n", copy_in_make_dv_count);
00114 fprintf(fd, "make_dv:\t%d\n", make_dv_count);
00115 fprintf(fd, "copy_in_copy_out:\t%d\n", copy_in_copy_out_count);
00116 fprintf(fd, "copy_in:\t%d\n", copy_in_count);
00117 fprintf(fd, "pass_dv_copy:\t%d\n", pass_dv_copy_count);
00118 fprintf(fd, "pass_dv:\t%d\n", pass_dv_count);
00119 fprintf(fd, "pass_address_from_dv:\t%d\n", pass_address_from_dv_count);
00120 fprintf(fd, "pass_section_address:\t%d\n", pass_section_address_count);
00121 fprintf(fd, "pass_address:\t%d\n", pass_address_count);
00122 fprintf(fd, "copy_inout_make_dv:\t%d\n", copy_inout_make_dv_count);
00123 fprintf(fd, "move_copyinout_alloc:\t%d\n", move_copyinout_alloc_count);
00124 fprintf(fd, "runtime_copyinout:\t%d\n", runtime_copyinout_count);
00125 }
00126 #endif
00127 #endif
00128
00129
00130
00131
00132
00133 static boolean compare_darg_to_actual_arg(int, int, int, opnd_type,
00134 int, int);
00135 static boolean compare_func_result(int,int,int,int,int,int,int,int);
00136 static int copy_and_replace_tmps (int);
00137 static int create_tmp_DV_asg (int, int);
00138 static int create_tmp_from_stmt_func (int);
00139 static void determine_num_elements (opnd_type *, expr_arg_type *,
00140 int, int);
00141 static int expand_user_bound (int);
00142 static void find_attrs_in_il(int);
00143 static void find_attrs_in_ir(int);
00144 static void find_attrs_used_in_bound(int);
00145 static dummy_arg_type get_dummy_arg_type (int);
00146 static void make_new_bd_entries (int, int *, int *);
00147 static void save_array_syntax_subscripts (int);
00148 static void set_at_actual_arg (int);
00149 static void process_variable_size_func (int, int, int,
00150 int, int *, int *);
00151 static void check_bd_typ_for_dargs(int, int, opnd_type *);
00152 static void search_expr_for_dargs(opnd_type *, opnd_type *);
00153 static int gen_arg_type_descriptor(int, boolean, int, int);
00154 static int gen_call_type_descriptor(int, int, boolean, int, int);
00155 static long_type get_arg_type(int, boolean);
00156 static int create_struct_argchck_tbl(int);
00157 static int determine_struct_tbl_size(int);
00158 static void fill_in_struct_argchck_const(int, int, int *);
00159 static void make_base_assumed_size(opnd_type *, opnd_type *);
00160 static void check_call_for_global_def(int, int, int);
00161 static void ntr_ref_in_global_tbl(int, int, int, int *, int);
00162
00163 void gen_dbg_write_stmt(opnd_type *, sh_position_type);
00164 #ifdef KEY
00165 static boolean check_elemental_conformance(int, expr_arg_type *, int);
00166 #else
00167 static boolean check_elemental_conformance(int, expr_arg_type *);
00168 #endif
00169 static void check_for_constructors(opnd_type *, expr_arg_type *);
00170 static void check_for_elementals(int);
00171 static void check_expr_for_elementals(opnd_type *);
00172 static boolean check_arg_for_co_array(opnd_type *);
00173 static void update_components(opnd_type *);
00174
00175 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00176 static void set_inline_state(int, int);
00177 # endif
00178 #ifdef KEY
00179 static void Type_Converstion_to_Real(int ir_idx, int list_idx, int *prev_list_idx){
00180
00181 int tmp_idx = IL_NEXT_LIST_IDX(list_idx);
00182 int list1_idx, idx, type_idx;
00183 int info_idx = IL_ARG_DESC_IDX(list_idx);
00184
00185 NTR_IR_LIST_TBL(list1_idx);
00186 IL_FLD(list1_idx) = IR_Tbl_Idx;
00187 IL_ARG_DESC_VARIANT(list1_idx) = TRUE;
00188 IL_LINE_NUM(list1_idx) = IL_LINE_NUM(list_idx);
00189 IL_COL_NUM(list1_idx) = IL_COL_NUM(list_idx);
00190 if (IR_IDX_R(ir_idx) == list_idx)
00191 IR_IDX_R(ir_idx) = list1_idx;
00192 IL_NEXT_LIST_IDX(list1_idx) = IL_NEXT_LIST_IDX(list_idx);
00193 if (*prev_list_idx != NULL_IDX)
00194 IL_NEXT_LIST_IDX(*prev_list_idx) = list1_idx;
00195 NTR_IR_TBL(idx);
00196 IR_TYPE_IDX(idx) = REAL_DEFAULT_TYPE;
00197 IR_RANK(idx) = IR_RANK(ir_idx);
00198 IR_LINE_NUM(idx) = IR_LINE_NUM(ir_idx);
00199 IR_COL_NUM(idx) = IR_COL_NUM(ir_idx);
00200 IR_OPR(idx) = Real_Opr;
00201 IR_FLD_L(idx) = IL_Tbl_Idx;
00202 IR_IDX_L(idx) = list_idx;
00203 IR_OPND_R(idx) = null_opnd;
00204 IR_LIST_CNT_L(idx) = 1;
00205 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
00206 IL_ARG_DESC_IDX(list1_idx) = info_idx;
00207
00208 expr_arg_type exp_desc;
00209 opnd_type opnd;
00210 COPY_OPND(opnd, IL_OPND(list1_idx));
00211 exp_desc.rank = 0;
00212 expr_semantics(&opnd, &exp_desc);
00213 COPY_OPND(IL_OPND(list1_idx), opnd);
00214 type_idx = REAL_DEFAULT_TYPE;
00215 exp_desc.type = TYP_TYPE(type_idx);
00216 exp_desc.linear_type = TYP_LINEAR(type_idx);
00217 exp_desc.type_idx = type_idx;
00218 arg_info_list[info_idx].ed = exp_desc;
00219 IL_IDX(list1_idx) = idx;
00220 *prev_list_idx = list1_idx;
00221
00222 }
00223 #endif
00224
00225
00226
00227
00228
00229
00230
00231
00232
00233
00234
00235
00236
00237
00238
00239
00240
00241
00242
00243 boolean call_list_semantics(opnd_type *result_opnd,
00244 expr_arg_type *res_exp_desc,
00245 boolean is_function)
00246
00247 {
00248
00249 int arg_attr;
00250 int alt_return_tmp;
00251 int arg_idx;
00252 int asg_idx;
00253 int attr_idx;
00254 int br_idx_idx;
00255 int col;
00256 expr_arg_type exp_desc;
00257 boolean found = FALSE;
00258 int gen_idx;
00259 boolean has_symbolic = FALSE;
00260 boolean host_associated = FALSE;
00261 int i;
00262 int idx;
00263 int info_idx;
00264 int ir_idx;
00265 int label_cnt = 0;
00266 int label_list_head = NULL_IDX;
00267 int label_list_tail = NULL_IDX;
00268 long_type length;
00269 int line;
00270 int list_cnt;
00271 int list_idx;
00272 int list_idx2;
00273 int loc_idx;
00274 int name_idx;
00275 int new_sn_idx;
00276 int num_registers;
00277 boolean locked_in;
00278 boolean reset_expr_mode;
00279 int loc_info_idx;
00280 #ifdef KEY
00281 int msg_num = 0;
00282 #else
00283 int msg_num;
00284 #endif
00285 int new_attr_idx;
00286 int num_args;
00287 boolean ok = TRUE;
00288 opnd_type opnd;
00289 int opnd_column;
00290 int opnd_line;
00291 int rslt_idx;
00292 #ifdef KEY
00293 opnd_type save_char_len = INIT_OPND_TYPE;
00294 #else
00295 opnd_type save_char_len;
00296 #endif
00297 int save_curr_stmt_sh_idx;
00298 boolean save_defer_stmt_expansion;
00299 #ifdef KEY
00300 expr_mode_type save_expr_mode = 0;
00301 #else
00302 expr_mode_type save_expr_mode;
00303 #endif
00304 boolean save_foldable;
00305 boolean save_in_call_list;
00306 boolean save_io_item_must_flatten;
00307 opnd_type save_result_opnd;
00308 int save_where_ir_idx;
00309 boolean save_will_fold_later;
00310 cif_usage_code_type save_xref_state;
00311 #ifdef KEY
00312 int save_rank = 0;
00313 #else
00314 int save_rank;
00315 #endif
00316 opnd_type save_shape[7];
00317 boolean save_shape_known;
00318 int sn_idx;
00319 int spec_sn_idx = NULL_IDX;
00320 int spec_count;
00321 int spec_idx;
00322 int type_idx;
00323
00324 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00325 int false_list_idx = NULL_IDX;
00326 # endif
00327 #ifdef KEY
00328
00329
00330
00331 boolean saw_constant_ptr = FALSE;
00332 #endif
00333
00334 TRACE (Func_Entry, "call_list_semantics", NULL);
00335
00336 stmt_expansion_control_start();
00337 save_defer_stmt_expansion = defer_stmt_expansion;
00338 defer_stmt_expansion = FALSE;
00339 save_result_opnd = null_opnd;
00340
00341 ir_idx = OPND_IDX((*result_opnd));
00342
00343
00344
00345 if (max_call_list_size >= arg_list_size) {
00346 enlarge_call_list_tables();
00347 }
00348
00349 arg_info_list_base = arg_info_list_top;
00350
00351 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
00352
00353 if (arg_info_list_top >= arg_info_list_size) {
00354 enlarge_info_list_table();
00355 }
00356
00357 loc_info_idx = arg_info_list_base;
00358
00359 attr_idx = IR_IDX_L(ir_idx);
00360 locked_in = AT_LOCKED_IN(attr_idx);
00361 AT_LOCKED_IN(attr_idx) = TRUE;
00362
00363 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00364 IR_INLINE_STATE(ir_idx) = Not_Specified_Sgi;
00365 set_inline_state(ir_idx, attr_idx);
00366 # endif
00367
00368 if (AT_ATTR_LINK(attr_idx)) {
00369 host_associated = TRUE;
00370 }
00371
00372 while (AT_ATTR_LINK(attr_idx) &&
00373 ! AT_IGNORE_ATTR_LINK(attr_idx)) {
00374
00375 attr_idx = AT_ATTR_LINK(attr_idx);
00376 locked_in = locked_in || AT_LOCKED_IN(attr_idx);
00377 AT_LOCKED_IN(attr_idx) = TRUE;
00378
00379 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00380 set_inline_state(ir_idx, attr_idx);
00381 # endif
00382
00383 }
00384
00385 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
00386 ATP_PROC(attr_idx) == Dummy_Proc &&
00387 ATP_DUMMY_PROC_LINK(attr_idx) != NULL_IDX) {
00388
00389 attr_idx = ATP_DUMMY_PROC_LINK(attr_idx);
00390
00391 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00392 set_inline_state(ir_idx, attr_idx);
00393 # endif
00394
00395 }
00396
00397 IR_IDX_L(ir_idx) = attr_idx;
00398 spec_idx = attr_idx;
00399 gen_idx = attr_idx;
00400 line = IR_LINE_NUM_L(ir_idx);
00401 col = IR_COL_NUM_L(ir_idx);
00402
00403 if ((cif_flags & XREF_RECS) != 0 && xref_state != CIF_No_Usage_Rec) {
00404 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00405 }
00406
00407 if (cdir_switches.parallel_region &&
00408 AT_OBJ_CLASS(gen_idx) == Pgm_Unit &&
00409 ATP_PROC(gen_idx) == Dummy_Proc &&
00410 ! cdir_switches.autoscope &&
00411 #ifdef KEY
00412 ! cdir_switches.single &&
00413 #endif
00414 ! ATP_TASK_SHARED(gen_idx)) {
00415
00416 PRINTMSG(line, 1041, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00417 ok = FALSE;
00418 }
00419
00420 if (expr_mode == Restricted_Imp_Do_Expr) {
00421 PRINTMSG(line, 658, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00422 ok = FALSE;
00423 goto DONE;
00424 }
00425
00426 save_where_ir_idx = where_ir_idx;
00427 save_io_item_must_flatten = io_item_must_flatten;
00428
00429 if (! AT_ELEMENTAL_INTRIN(gen_idx)) {
00430 where_ir_idx = NULL_IDX;
00431 }
00432
00433 if (AT_OBJ_CLASS(gen_idx) == Pgm_Unit) {
00434
00435 if (expr_mode == Initialization_Expr) {
00436 fnd_semantic_err(Obj_Use_Init_Expr,
00437 line,
00438 col,
00439 gen_idx,
00440 TRUE);
00441 ok = FALSE;
00442 goto EXIT;
00443 }
00444
00445 if (expr_mode == Specification_Expr) {
00446
00447 if (fnd_semantic_err(Obj_Use_Spec_Expr,
00448 line,
00449 col,
00450 gen_idx,
00451 TRUE)) {
00452 ok = FALSE;
00453 goto EXIT;
00454 }
00455
00456 if (ATD_IM_A_DOPE(ATP_RSLT_IDX(gen_idx)) ||
00457 ATD_ARRAY_IDX(ATP_RSLT_IDX(gen_idx)) != NULL_IDX) {
00458
00459 PRINTMSG(line, 240, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00460 ok = FALSE;
00461 }
00462 else {
00463
00464
00465
00466
00467 if (
00468 #ifdef KEY
00469
00470 !(ATP_PURE(gen_idx) || ATP_ELEMENTAL(gen_idx)) ||
00471 #else
00472 !ATP_PURE(gen_idx) ||
00473 #endif
00474 (ATP_PROC(gen_idx) == Intern_Proc) ||
00475 ATP_RECURSIVE(gen_idx)) {
00476 PRINTMSG(line, 520, Ansi, col, AT_OBJ_NAME_PTR(gen_idx));
00477 }
00478 }
00479
00480 if (ATP_PROC(gen_idx) == Dummy_Proc && AT_ALT_DARG(gen_idx)) {
00481
00482
00483
00484
00485
00486 list_idx = SCP_TMP_LIST(curr_scp_idx);
00487
00488 while (list_idx != NULL_IDX && gen_idx != AL_ATTR_IDX(list_idx)) {
00489 list_idx = AL_NEXT_IDX(list_idx);
00490 }
00491
00492 if (list_idx == NULL_IDX) {
00493 NTR_ATTR_LIST_TBL(list_idx);
00494 AL_NEXT_IDX(list_idx) = SCP_TMP_LIST(curr_scp_idx);
00495 AL_ATTR_IDX(list_idx) = gen_idx;
00496 SCP_TMP_LIST(curr_scp_idx) = list_idx;
00497 }
00498 }
00499 }
00500
00501 spec_count = 0;
00502 found = TRUE;
00503
00504 if (is_function) {
00505
00506 if (ATP_PGM_UNIT(gen_idx) != Function &&
00507 ATP_PGM_UNIT(gen_idx) != Pgm_Unknown) {
00508
00509 switch (ATP_PGM_UNIT(gen_idx)) {
00510 case Subroutine :
00511 msg_num = 452;
00512 break;
00513 case Program :
00514 msg_num = 453;
00515 break;
00516 case Module :
00517 msg_num = 455;
00518 break;
00519 case Blockdata :
00520 msg_num = 454;
00521 break;
00522 }
00523 PRINTMSG(line, msg_num, Error, col,
00524 AT_OBJ_NAME_PTR(gen_idx));
00525 ok = FALSE;
00526 goto EXIT;
00527 }
00528 else if (ATP_PGM_UNIT(gen_idx) == Pgm_Unknown) {
00529
00530 if (ATP_SCP_IDX(gen_idx) == NULL_IDX &&
00531 ATP_RSLT_IDX(gen_idx) == NULL_IDX) {
00532 PRINTMSG(line, 970, Internal, col);
00533 }
00534
00535 ATP_PGM_UNIT(gen_idx) = Function;
00536
00537 if (ATP_RSLT_IDX(gen_idx) == NULL_IDX) {
00538
00539 CREATE_FUNC_RSLT(gen_idx, new_attr_idx);
00540
00541 AT_REFERENCED(new_attr_idx) = Referenced;
00542
00543 SET_IMPL_TYPE_IN_SCP(new_attr_idx, ATP_SCP_IDX(gen_idx));
00544 }
00545 }
00546 }
00547 else {
00548 if (ATP_PGM_UNIT(gen_idx) != Subroutine &&
00549 ATP_PGM_UNIT(gen_idx) != Pgm_Unknown) {
00550
00551 switch (ATP_PGM_UNIT(gen_idx)) {
00552 case Function :
00553 msg_num = 335;
00554 break;
00555 case Program :
00556 msg_num = 456;
00557 break;
00558 case Module :
00559 msg_num = 458;
00560 break;
00561 case Blockdata :
00562 msg_num = 457;
00563 break;
00564 }
00565 PRINTMSG(line, msg_num, Error, col,
00566 AT_OBJ_NAME_PTR(gen_idx));
00567 ok = FALSE;
00568 goto EXIT;
00569 }
00570 else if (ATP_PGM_UNIT(gen_idx) == Pgm_Unknown) {
00571 ATP_PGM_UNIT(gen_idx) = Subroutine;
00572 }
00573 }
00574 }
00575 else if (AT_OBJ_CLASS(gen_idx) == Interface) {
00576 spec_count = ATI_NUM_SPECIFICS(gen_idx);
00577
00578 if (spec_count == 0) {
00579 goto EXIT;
00580 }
00581
00582 if (is_function) {
00583
00584 if (ATI_INTERFACE_CLASS(gen_idx) != Generic_Unknown_Interface &&
00585 ATI_INTERFACE_CLASS(gen_idx) != Generic_Function_Interface) {
00586
00587 PRINTMSG(line, 398, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00588 ok = FALSE;
00589 found = TRUE;
00590 goto EXIT;
00591 }
00592 }
00593 else {
00594
00595 if (ATI_INTERFACE_CLASS(gen_idx) != Generic_Unknown_Interface &&
00596 ATI_INTERFACE_CLASS(gen_idx) != Generic_Subroutine_Interface) {
00597
00598 PRINTMSG(line, 397, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00599 ok = FALSE;
00600 found = TRUE;
00601 goto EXIT;
00602 }
00603 }
00604 }
00605 else {
00606
00607 spec_count = 0;
00608 found = TRUE;
00609
00610 AT_REFERENCED(gen_idx) = Not_Referenced;
00611
00612 if (fnd_semantic_err((is_function ? Obj_Use_Extern_Func :
00613 Obj_Use_Extern_Subr),
00614 line, col, gen_idx, TRUE)) {
00615 ok = FALSE;
00616 goto EXIT;
00617 }
00618 else if (is_function && AT_OBJ_CLASS(gen_idx) == Pgm_Unit &&
00619 ATP_PROC(gen_idx) != Dummy_Proc &&
00620 ATP_RSLT_IDX(gen_idx) != NULL_IDX &&
00621 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(gen_idx))) == Character &&
00622 TYP_CHAR_CLASS(ATD_TYPE_IDX(ATP_RSLT_IDX(gen_idx))) ==
00623 Assumed_Size_Char) {
00624 PRINTMSG(line, 939, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00625 ok = FALSE;
00626 goto EXIT;
00627 }
00628
00629 AT_REFERENCED(gen_idx) = Referenced;
00630
00631 if (locked_in) {
00632
00633
00634 if (is_function) {
00635 PRINTMSG(line, 511, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00636 }
00637 else {
00638 PRINTMSG(line, 568, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00639 }
00640 ok = FALSE;
00641 goto EXIT;
00642 }
00643
00644 if (AT_USE_ASSOCIATED(gen_idx)) {
00645 PRINTMSG(line, 898, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00646 ok = FALSE;
00647 goto EXIT;
00648 }
00649 else {
00650 PRINTMSG(line, 971, Internal, col);
00651 }
00652 }
00653
00654 if (cdir_switches.no_internal_calls &&
00655 AT_OBJ_CLASS(gen_idx) == Pgm_Unit &&
00656 ATP_PROC(gen_idx) == Intern_Proc) {
00657 PRINTMSG(line, 821, Error, col);
00658 }
00659
00660
00661
00662
00663 list_idx = IR_IDX_R(ir_idx);
00664
00665 save_in_call_list = in_call_list;
00666
00667 reset_expr_mode = FALSE;
00668
00669
00670
00671 if ((strcmp(AT_OBJ_NAME_PTR(gen_idx), "LBOUND") == 0) ||
00672 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "UBOUND") == 0) ||
00673 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "SIZE") == 0) ||
00674 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "SHAPE") == 0) ||
00675 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "KIND") == 0) ||
00676 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "BIT_SIZE") == 0) ||
00677 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "DIGITS") == 0) ||
00678 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "PRECISION") == 0) ||
00679 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "EPSILON") == 0) ||
00680 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "HUGE") == 0) ||
00681 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "MAXEXPONENT") == 0) ||
00682 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "MINEXPONENT") == 0) ||
00683 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "RADIX") == 0) ||
00684 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "RANGE") == 0) ||
00685 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "LEN") == 0) ||
00686 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "TINY") == 0)) {
00687 save_expr_mode = expr_mode;
00688 if (expr_mode == Initialization_Expr ||
00689 expr_mode == Specification_Expr) {
00690 need_pure_function = TRUE;
00691 }
00692 expr_mode = Regular_Expr;
00693 reset_expr_mode = TRUE;
00694 }
00695
00696 for (i = loc_info_idx + 1;
00697 i <= loc_info_idx + IR_LIST_CNT_R(ir_idx);
00698 i++) {
00699
00700 arg_info_list[i] = init_arg_info;
00701
00702 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
00703 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {
00704
00705 PRINTMSG(IR_LINE_NUM(IL_IDX(list_idx)), 197, Error,
00706 IR_COL_NUM(IL_IDX(list_idx)),", or )", ":");
00707 ok = FALSE;
00708 goto EXIT;
00709 }
00710
00711 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
00712 IR_OPR(IL_IDX(list_idx)) == Kwd_Opr) {
00713
00714 if (spec_count == 0 &&
00715 ! ATP_EXPL_ITRFC(gen_idx)) {
00716 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
00717 &opnd_line,
00718 &opnd_column);
00719 PRINTMSG(opnd_line, 333, Error, opnd_column);
00720 ok = FALSE;
00721 }
00722 arg_info_list[i].kwd = IR_IDX_L(IL_IDX(list_idx));
00723 COPY_OPND(IL_OPND(list_idx),IR_OPND_R(IL_IDX(list_idx)));
00724 }
00725 else {
00726 arg_info_list[i].kwd = NULL_IDX;
00727 }
00728
00729 COPY_OPND(opnd, IL_OPND(list_idx));
00730
00731 # ifdef _F_MINUS_MINUS
00732 if (cmd_line_flags.co_array_fortran) {
00733 ok &= check_arg_for_co_array(&opnd);
00734 }
00735 # endif
00736
00737 in_call_list = TRUE;
00738 exp_desc.rank = 0;
00739 save_xref_state = xref_state;
00740
00741 label_allowed = TRUE;
00742
00743 if (xref_state != CIF_No_Usage_Rec) {
00744 xref_state = CIF_Symbol_Reference;
00745 }
00746
00747 #ifdef KEY
00748
00749
00750
00751
00752
00753
00754
00755 int save_constant_ptr_ok = constant_ptr_ok;
00756 constant_ptr_ok = TRUE;
00757 #endif
00758 ok = expr_semantics(&opnd, &exp_desc) && ok;
00759 #ifdef KEY
00760 constant_ptr_ok = save_constant_ptr_ok;
00761 #endif
00762
00763 # ifdef KEY
00764 {
00765 int o_idx = OPND_IDX(opnd);
00766 if (OPND_FLD(opnd) == AT_Tbl_Idx &&
00767
00768
00769 (AT_OBJ_CLASS(o_idx) == Data_Obj ||
00770 AT_OBJ_CLASS(o_idx) == Pgm_Unit) &&
00771 ATD_F2C_ABI_VAR(OPND_IDX(opnd)) == TRUE &&
00772 TYP_LINEAR(ATD_TYPE_IDX(OPND_IDX(opnd))) != exp_desc.linear_type) {
00773 exp_desc.type_idx = ATD_TYPE_IDX(OPND_IDX(opnd));
00774 exp_desc.linear_type = TYP_LINEAR(ATD_TYPE_IDX(OPND_IDX(opnd)));
00775 }
00776 }
00777 # endif
00778
00779 label_allowed = FALSE;
00780
00781 has_symbolic |= exp_desc.has_symbolic;
00782
00783 find_opnd_line_and_column(&opnd, &opnd_line, &opnd_column);
00784 arg_info_list[i].line = opnd_line;
00785 arg_info_list[i].col = opnd_column;
00786
00787 #ifdef KEY
00788
00789 if (OPND_FLD(IL_OPND(list_idx)) == IR_Tbl_Idx && OPND_FLD(opnd) == AT_Tbl_Idx &&
00790 (IR_OPR(IL_IDX(list_idx)) == Mult_Opr ||
00791 IR_OPR(IL_IDX(list_idx)) == Div_Opr ||
00792 IR_OPR(IL_IDX(list_idx)) == Uplus_Opr ||
00793 IR_OPR(IL_IDX(list_idx)) == Uminus_Opr ||
00794 IR_OPR(IL_IDX(list_idx)) == Plus_Opr ||
00795 IR_OPR(IL_IDX(list_idx)) == Minus_Opr ))
00796 ;
00797 else
00798 #endif
00799 COPY_OPND(IL_OPND(list_idx), opnd);
00800
00801 xref_state = save_xref_state;
00802
00803 arg_info_list[i].ed = exp_desc;
00804 arg_info_list[i].maybe_modified = TRUE;
00805
00806 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00807 IL_ARG_DESC_IDX(list_idx) = i;
00808
00809 if (AT_IS_INTRIN(gen_idx)) {
00810
00811 switch (expr_mode) {
00812 case Regular_Expr:
00813 case Stmt_Func_Expr:
00814 break;
00815
00816 case Initialization_Expr:
00817 if (exp_desc.type != Integer &&
00818 exp_desc.type != Character &&
00819 AT_ELEMENTAL_INTRIN(gen_idx)) {
00820
00821 if (strcmp(AT_OBJ_NAME_PTR(gen_idx), "NINT") == 0 ||
00822 strcmp(AT_OBJ_NAME_PTR(gen_idx), "INT") == 0) {
00823 PRINTMSG(arg_info_list[i].line,
00824 274,
00825 Ansi,
00826 arg_info_list[i].col);
00827 }
00828 # if defined(_USE_FOLD_DOT_f)
00829 else if (strcmp(AT_OBJ_NAME_PTR(gen_idx), "SQRT") == 0) {
00830
00831 }
00832 # endif
00833 else {
00834 PRINTMSG(arg_info_list[i].line,
00835 1456,
00836 Error,
00837 arg_info_list[i].col);
00838 ok = FALSE;
00839 }
00840 }
00841 break;
00842
00843 case Specification_Expr:
00844 default:
00845 if (exp_desc.type != Integer && exp_desc.type != Character) {
00846 PRINTMSG(arg_info_list[i].line, 274, Ansi, arg_info_list[i].col);
00847 }
00848 break;
00849 }
00850 }
00851
00852 if (IL_FLD(list_idx) == AT_Tbl_Idx &&
00853 AT_OBJ_CLASS(IL_IDX(list_idx)) == Pgm_Unit) {
00854
00855
00856
00857 if (ATP_DCL_EXTERNAL(IL_IDX(list_idx)) ||
00858 ATP_IN_INTERFACE_BLK(IL_IDX(list_idx)) ||
00859 AT_IS_INTRIN(IL_IDX(list_idx)) ||
00860 ATP_SCP_ALIVE(IL_IDX(list_idx)) ||
00861 ATP_PROC(IL_IDX(list_idx)) == Module_Proc) {
00862
00863 arg_info_list[i].pgm_unit = TRUE;
00864
00865 if (ATP_PGM_UNIT(IL_IDX(list_idx)) == Pgm_Unknown) {
00866 type_idx = IM_TYPE_IDX(ATP_SCP_IDX(IL_IDX(list_idx)),
00867 IMPL_IDX(AT_OBJ_NAME(IL_IDX(list_idx))));
00868
00869
00870
00871 arg_info_list[i].ed.type = TYP_TYPE(type_idx);
00872 arg_info_list[i].ed.type_idx = type_idx;
00873 arg_info_list[i].ed.linear_type = TYP_LINEAR(type_idx);
00874 arg_info_list[i].ed.rank = 0;
00875 }
00876 }
00877 else {
00878
00879
00880
00881
00882 PRINTMSG(IL_LINE_NUM(list_idx), 379, Error,
00883 IL_COL_NUM(list_idx),
00884 AT_OBJ_NAME_PTR(IL_IDX(list_idx)));
00885 ok = FALSE;
00886 goto EXIT;
00887 }
00888 }
00889 else {
00890 arg_info_list[i].pgm_unit = FALSE;
00891 }
00892
00893 if (exp_desc.label) {
00894
00895 label_cnt++;
00896
00897 if (label_list_head == NULL_IDX) {
00898 NTR_IR_LIST_TBL(label_list_head);
00899 label_list_tail = label_list_head;
00900 }
00901 else {
00902 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(label_list_tail));
00903 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(label_list_tail)) =
00904 label_list_tail;
00905 label_list_tail = IL_NEXT_LIST_IDX(label_list_tail);
00906 }
00907
00908 COPY_OPND(IL_OPND(label_list_tail), IL_OPND(list_idx));
00909
00910 if (spec_count == 0 &&
00911 ! ATP_EXPL_ITRFC(gen_idx)) {
00912
00913 ATP_HAS_ALT_RETURN(gen_idx) = TRUE;
00914 }
00915 }
00916
00917 #ifdef KEY
00918 if (arg_info_list[i].ed.pointer && arg_info_list[i].ed.constant) {
00919 saw_constant_ptr = TRUE;
00920 }
00921 #endif
00922 list_idx = IL_NEXT_LIST_IDX(list_idx);
00923 }
00924
00925 need_pure_function = FALSE;
00926
00927 if (reset_expr_mode) {
00928 expr_mode = save_expr_mode;
00929 }
00930
00931 #ifdef KEY
00932
00933 if (IR_OPR(ir_idx) == Call_Opr &&
00934 strcmp(AT_OBJ_NAME_PTR(IR_OPND_L(ir_idx).idx),"FLUSH")==0 ){
00935 int list_idx = IR_IDX_R(ir_idx);
00936 if (IL_FLD(list_idx) == CN_Tbl_Idx){
00937 int op_idx = IL_IDX(list_idx);
00938 if ( TYP_LINEAR(CN_TYPE_IDX(op_idx)) == Integer_4 )
00939 IL_IDX(list_idx) = C_INT_TO_CN(double_linear_type[0], CN_CONST(op_idx));
00940 }
00941 }
00942
00943 if (IR_OPR(ir_idx) == Call_Opr &&
00944 (strcmp(AT_OBJ_NAME_PTR(IR_OPND_L(ir_idx).idx),"MAX")==0 ||
00945 strcmp(AT_OBJ_NAME_PTR(IR_OPND_L(ir_idx).idx),"MIN")==0 )){
00946
00947 int list_idx = IR_IDX_R(ir_idx);
00948 int info_idx = IL_ARG_DESC_IDX(list_idx);
00949 int type_idx = arg_info_list[info_idx].ed.type;
00950 boolean conversion = FALSE;
00951 list_idx = IL_NEXT_LIST_IDX(list_idx);
00952 while (list_idx != NULL_IDX) {
00953 if (arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type != type_idx){
00954 conversion = TRUE;
00955 break;
00956 }
00957 list_idx = IL_NEXT_LIST_IDX(list_idx);
00958 }
00959
00960 list_idx = IR_IDX_R(ir_idx);
00961 int old_idx = NULL_IDX;
00962 while (conversion == TRUE && list_idx != NULL_IDX) {
00963 int tmp_idx = IL_NEXT_LIST_IDX(list_idx);
00964 info_idx = IL_ARG_DESC_IDX(list_idx);
00965 if (arg_info_list[info_idx].ed.type == Integer)
00966 Type_Converstion_to_Real(ir_idx, list_idx, &old_idx);
00967 else
00968 old_idx = list_idx;
00969 list_idx = tmp_idx;
00970 }
00971 }
00972 #endif
00973
00974
00975
00976
00977
00978 if (! AT_IS_INTRIN(gen_idx)) {
00979 io_item_must_flatten = save_io_item_must_flatten;
00980 }
00981
00982 in_call_list = save_in_call_list;
00983
00984 if (!ok) {
00985 goto EXIT;
00986 }
00987
00988
00989 if (spec_count > 0 || ATP_EXPL_ITRFC(gen_idx)) {
00990
00991 do {
00992
00993 if (spec_count > 0) {
00994
00995 if (spec_sn_idx == NULL_IDX) {
00996 spec_sn_idx = ATI_FIRST_SPECIFIC_IDX(gen_idx);
00997 }
00998 else {
00999 spec_sn_idx = SN_SIBLING_LINK(spec_sn_idx);
01000 }
01001 spec_idx = SN_ATTR_IDX(spec_sn_idx);
01002 }
01003 else {
01004 spec_idx = gen_idx;
01005 }
01006
01007 num_args = ATP_NUM_DARGS(spec_idx);
01008
01009 if (ATP_EXTRA_DARG(spec_idx)) {
01010 num_args--;
01011 }
01012
01013 # ifdef _DEBUG
01014 if (num_args >= arg_list_size) {
01015 PRINTMSG(1,245,Internal,0);
01016 }
01017
01018 # endif
01019 for (arg_idx = 0; arg_idx <= num_args + 1; arg_idx++) {
01020 arg_list[arg_idx] = 0;
01021 }
01022
01023 list_idx = IR_IDX_R(ir_idx);
01024
01025 info_idx = loc_info_idx;
01026
01027 for (list_cnt = 1; list_cnt <= IR_LIST_CNT_R(ir_idx); list_cnt++) {
01028 info_idx++;
01029 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
01030 &opnd_line,
01031 &opnd_column);
01032
01033 if (arg_info_list[info_idx].kwd != NULL_IDX) {
01034 length = (long_type) CN_INT_TO_C(
01035 TYP_IDX(CN_TYPE_IDX(arg_info_list[info_idx].kwd)));
01036 arg_attr = srch_kwd_name(
01037 (char *)&CN_CONST(arg_info_list[info_idx].kwd),
01038 length,
01039 spec_idx,
01040 &sn_idx);
01041
01042 if (arg_attr) {
01043
01044 if (ATP_EXTRA_DARG(spec_idx)) {
01045 arg_idx = sn_idx - ATP_FIRST_IDX(spec_idx);
01046 }
01047 else {
01048 arg_idx = sn_idx - ATP_FIRST_IDX(spec_idx) + 1;
01049 }
01050
01051 if (arg_list[arg_idx]) {
01052
01053 if (spec_count == 0) {
01054
01055
01056
01057 PRINTMSG(opnd_line, 330, Error, opnd_column);
01058 ok = FALSE;
01059 list_idx = IL_NEXT_LIST_IDX(list_idx);
01060 continue;
01061 }
01062 else {
01063 goto CYCLE;
01064 }
01065 }
01066 }
01067 else {
01068
01069 if (spec_count == 0) {
01070
01071
01072
01073 PRINTMSG(opnd_line, 277, Error, opnd_column,
01074 (char *)&CN_CONST(arg_info_list[info_idx].kwd),
01075 AT_OBJ_NAME_PTR(spec_idx));
01076 ok = FALSE;
01077 list_idx = IL_NEXT_LIST_IDX(list_idx);
01078 continue;
01079 }
01080 else {
01081 goto CYCLE;
01082 }
01083 }
01084 }
01085 else {
01086
01087 if (ATP_EXTRA_DARG(spec_idx)) {
01088 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + list_cnt);
01089 }
01090 else {
01091 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + list_cnt-1);
01092 }
01093 arg_idx = list_cnt;
01094
01095
01096 if (arg_list[arg_idx]) {
01097
01098 if (spec_count == 0) {
01099
01100
01101
01102 PRINTMSG(opnd_line, 330, Error, opnd_column);
01103 ok = FALSE;
01104 list_idx = IL_NEXT_LIST_IDX(list_idx);
01105 continue;
01106 }
01107 else {
01108 goto CYCLE;
01109 }
01110 }
01111 else if (arg_idx > num_args) {
01112
01113 if (ATP_PROC(spec_idx) == Intrin_Proc) {
01114
01115 if ((ATP_INTRIN_ENUM(spec_idx) == Ranf_Intrinsic) ||
01116 (ATP_INTRIN_ENUM(spec_idx) == Date_Intrinsic) ||
01117 #ifdef KEY
01118 (ATP_INTRIN_ENUM(spec_idx) == Fdate_Intrinsic) ||
01119 #endif
01120 (ATP_INTRIN_ENUM(spec_idx) == Jdate_Intrinsic) ||
01121 (ATP_INTRIN_ENUM(spec_idx) == Rtc_Intrinsic) ||
01122 (ATP_INTRIN_ENUM(spec_idx) == Irtc_Intrinsic) ||
01123 (ATP_INTRIN_ENUM(spec_idx) == Clock_Intrinsic) ||
01124 #ifdef KEY
01125 (ATP_INTRIN_ENUM(spec_idx) == Numarg_Intrinsic) ||
01126 (ATP_INTRIN_ENUM(spec_idx) == Time4_Intrinsic) ||
01127 (ATP_INTRIN_ENUM(spec_idx) == Time8_Intrinsic)) {
01128 #else
01129 (ATP_INTRIN_ENUM(spec_idx) == Numarg_Intrinsic)) {
01130 #endif
01131 PRINTMSG(opnd_line, 739, Warning, opnd_column,
01132 AT_OBJ_NAME_PTR(gen_idx));
01133 break;
01134 }
01135 }
01136
01137 if (spec_count == 0) {
01138 PRINTMSG(opnd_line, 331, Error, opnd_column,
01139 list_cnt);
01140 ok = FALSE;
01141 list_idx = IL_NEXT_LIST_IDX(list_idx);
01142 continue;
01143 }
01144 else {
01145 goto CYCLE;
01146 }
01147 }
01148 }
01149
01150
01151
01152
01153
01154 arg_list[arg_idx] = list_idx;
01155
01156
01157
01158 if (AT_COMPILER_GEND(arg_attr) && AT_IS_DARG(arg_attr)) {
01159
01160
01161
01162 ATP_HAS_ALT_RETURN(spec_idx) = TRUE;
01163
01164 if (IL_FLD(list_idx) != AT_Tbl_Idx ||
01165 AT_OBJ_CLASS(IL_IDX(list_idx)) != Label) {
01166
01167 if (spec_count == 0) {
01168 PRINTMSG(opnd_line, 338, Error, opnd_column);
01169 ok = FALSE;
01170 }
01171 else {
01172 goto CYCLE;
01173 }
01174 }
01175
01176 list_idx = IL_NEXT_LIST_IDX(list_idx);
01177 continue;
01178 }
01179 else if (IL_FLD(list_idx) == AT_Tbl_Idx &&
01180 AT_OBJ_CLASS(IL_IDX(list_idx)) == Label) {
01181
01182 if (spec_count == 0) {
01183 PRINTMSG(opnd_line, 504, Error, opnd_column,
01184 AT_OBJ_NAME_PTR(IL_IDX(list_idx)),
01185 AT_OBJ_NAME_PTR(arg_attr));
01186 ok = FALSE;
01187 }
01188 else {
01189 goto CYCLE;
01190 }
01191 list_idx = IL_NEXT_LIST_IDX(list_idx);
01192 continue;
01193 }
01194
01195
01196
01197 if (!compare_darg_to_actual_arg(gen_idx,
01198 spec_idx,
01199 arg_attr,
01200 IL_OPND(list_idx),
01201 info_idx,
01202 spec_count)) {
01203
01204 if (spec_count == 0) {
01205 ok = FALSE;
01206 }
01207 else {
01208 goto CYCLE;
01209 }
01210 }
01211 list_idx = IL_NEXT_LIST_IDX(list_idx);
01212 }
01213
01214 for (arg_idx = 1; arg_idx <= num_args; arg_idx++) {
01215
01216 if (arg_list[arg_idx] == NULL_IDX) {
01217
01218
01219
01220 if (ATP_EXTRA_DARG(spec_idx)) {
01221 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + arg_idx);
01222 }
01223 else {
01224 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + arg_idx - 1);
01225 }
01226
01227 if (!AT_OPTIONAL(arg_attr)) {
01228
01229 if (spec_count == 0) {
01230
01231
01232
01233 if (AT_COMPILER_GEND(arg_attr)) {
01234 PRINTMSG(line, 209, Error, col, arg_idx);
01235 }
01236 else {
01237 PRINTMSG(line, 332, Error, col,
01238 AT_OBJ_NAME_PTR(arg_attr));
01239 }
01240 ok = FALSE;
01241 goto EXIT;
01242 }
01243 else {
01244 goto CYCLE;
01245 }
01246 }
01247 }
01248 }
01249
01250
01251
01252
01253 for (arg_idx = 1; arg_idx <= num_args; arg_idx++) {
01254
01255 if (arg_list[arg_idx] == NULL_IDX) {
01256 NTR_IR_LIST_TBL(list_idx);
01257 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
01258 arg_list[arg_idx] = list_idx;
01259 }
01260
01261 if (arg_idx > 1){
01262 IL_NEXT_LIST_IDX(arg_list[arg_idx - 1]) = arg_list[arg_idx];
01263 }
01264 }
01265
01266 IL_NEXT_LIST_IDX(arg_list[num_args]) = NULL_IDX;
01267
01268 IR_LIST_CNT_R(ir_idx) = num_args;
01269 IR_IDX_R(ir_idx) = arg_list[1];
01270
01271
01272
01273 IR_IDX_L(ir_idx) = spec_idx;
01274
01275 found = TRUE;
01276 goto EXIT;
01277
01278 CYCLE:
01279
01280 spec_count--;
01281 }
01282 while (spec_count > 0);
01283
01284 }
01285 else {
01286
01287 spec_idx = gen_idx;
01288 }
01289
01290 EXIT:
01291
01292 if (found) {
01293
01294 if (ok) {
01295
01296
01297
01298
01299
01300 if ((cif_flags & MISC_RECS) != 0 && xref_state != CIF_No_Usage_Rec) {
01301 cif_call_site_rec(ir_idx, gen_idx);
01302 }
01303
01304 if (AT_OBJ_CLASS(spec_idx) == Pgm_Unit &&
01305 ATP_SCP_ALIVE(spec_idx)) {
01306
01307 if (ATP_PGM_UNIT(spec_idx) == Function &&
01308 !ATP_RSLT_NAME(spec_idx)) {
01309 PRINTMSG(line, 344, Ansi, col);
01310 }
01311
01312 if (!ATP_RECURSIVE(spec_idx) && !AT_DCL_ERR(spec_idx) &&
01313 !on_off_flags.recursive) {
01314 PRINTMSG(line, 343, Error, col);
01315 ok = FALSE;
01316 }
01317 }
01318
01319 if (AT_NOT_VISIBLE(gen_idx)) {
01320 PRINTMSG(line, 486, Error, col,
01321 AT_OBJ_NAME_PTR(gen_idx),
01322 AT_OBJ_NAME_PTR(AT_MODULE_IDX((gen_idx))));
01323 ok = FALSE;
01324 goto DONE;
01325 }
01326 else if (AT_NOT_VISIBLE(spec_idx)) {
01327 PRINTMSG(line, 486, Error, col,
01328 AT_OBJ_NAME_PTR(spec_idx),
01329 AT_OBJ_NAME_PTR(AT_MODULE_IDX((spec_idx))));
01330 ok = FALSE;
01331 goto DONE;
01332 }
01333
01334 if (AT_DCL_ERR(spec_idx)) {
01335
01336
01337 ok = FALSE;
01338 goto DONE;
01339 }
01340
01341 if (ok && found &&
01342 #ifdef KEY
01343
01344 (ATP_PURE(spec_idx) || ATP_ELEMENTAL(spec_idx)) &&
01345 #else
01346 ATP_PURE(spec_idx) &&
01347 #endif
01348 ATP_PROC(spec_idx) != Intrin_Proc) {
01349
01350
01351
01352 list_idx = IR_IDX_R(ir_idx);
01353
01354 if (ATP_EXTRA_DARG(spec_idx)) {
01355 arg_idx = ATP_FIRST_IDX(spec_idx) + 1;
01356 num_args = ATP_NUM_DARGS(spec_idx) - 1;
01357 }
01358 else {
01359 arg_idx = ATP_FIRST_IDX(spec_idx);
01360 num_args = ATP_NUM_DARGS(spec_idx);
01361 }
01362
01363 for (;num_args > 0; num_args--) {
01364
01365 if (OPND_FLD(IL_OPND(list_idx)) == AT_Tbl_Idx &&
01366 AT_OBJ_CLASS(OPND_IDX(IL_OPND(list_idx))) == Pgm_Unit &&
01367 #ifdef KEY
01368
01369
01370
01371 !(ATP_PURE(OPND_IDX(IL_OPND(list_idx))) || ATP_ELEMENTAL(OPND_IDX(IL_OPND(list_idx))))
01372 #else
01373 !ATP_PURE(OPND_IDX(IL_OPND(list_idx))) == Pgm_Unit
01374 #endif
01375 ) {
01376 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx)].line,
01377 1642, Error,
01378 arg_info_list[IL_ARG_DESC_IDX(list_idx)].col,
01379 AT_OBJ_NAME_PTR(SN_ATTR_IDX(arg_idx)),
01380 AT_OBJ_NAME_PTR(OPND_IDX(IL_OPND(list_idx))));
01381 break;
01382 }
01383 arg_idx++;
01384 list_idx = IL_NEXT_LIST_IDX(list_idx);
01385 }
01386 }
01387
01388
01389 if (ATP_PROC(spec_idx) == Intrin_Proc) {
01390
01391 if (ATP_INTRIN_ENUM(spec_idx) != Unknown_Intrinsic) {
01392 ATP_INTERFACE_IDX(spec_idx) = gen_idx;
01393
01394 #ifdef KEY
01395
01396
01397
01398
01399
01400 intrinsic_type intype = ATP_INTRIN_ENUM(spec_idx);
01401 if (saw_constant_ptr && intype != Associated_Intrinsic &&
01402 intype != Null_Intrinsic) {
01403 PRINTMSG(opnd_line, 1677, Error, opnd_column);
01404 }
01405 #endif
01406 (*(void (*)())intrinsic_semantics[ATP_INTRIN_ENUM(spec_idx)])
01407 (result_opnd,
01408 res_exp_desc,
01409 &spec_idx);
01410 if (ATP_EXTERNAL_INTRIN(spec_idx)) {
01411 goto CONTINUE;
01412 }
01413 else {
01414
01415 if (res_exp_desc->rank &&
01416 OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
01417 IR_OPR(OPND_IDX((*result_opnd))) != Subscript_Opr &&
01418 IR_OPR(OPND_IDX((*result_opnd))) != Whole_Subscript_Opr&&
01419 IR_OPR(OPND_IDX((*result_opnd)))!=Section_Subscript_Opr&&
01420 IR_OPR(OPND_IDX((*result_opnd))) != Substring_Opr &&
01421 IR_OPR(OPND_IDX((*result_opnd))) != Whole_Substring_Opr&&
01422 IR_OPR(OPND_IDX((*result_opnd))) != Struct_Opr) {
01423 IR_ARRAY_SYNTAX(OPND_IDX((*result_opnd))) = TRUE;
01424 io_item_must_flatten = TRUE;
01425 }
01426 else if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx) {
01427 IR_ARRAY_SYNTAX(OPND_IDX((*result_opnd))) = FALSE;
01428 }
01429
01430
01431
01432
01433
01434
01435
01436
01437
01438
01439
01440
01441
01442
01443
01444
01445
01446
01447
01448
01449
01450
01451
01452
01453
01454 if (is_function &&
01455 (cif_flags & MISC_RECS) != 0 &&
01456 xref_state != CIF_No_Usage_Rec &&
01457 ! ATI_USER_SPECIFIED(gen_idx)) {
01458 cif_object_rec_for_func_result(spec_idx);
01459 ATI_CIF_SEEN_IN_CALL(gen_idx) = TRUE;
01460 }
01461
01462 goto DONE;
01463 }
01464 }
01465 else {
01466
01467 CONTINUE:
01468
01469
01470
01471
01472
01473
01474 if (is_function &&
01475 ! ATI_USER_SPECIFIED(gen_idx) &&
01476 (cif_flags & MISC_RECS) != 0 &&
01477 xref_state != CIF_No_Usage_Rec) {
01478 cif_object_rec_for_func_result(spec_idx);
01479 }
01480
01481
01482
01483 NTR_ATTR_TBL(new_attr_idx);
01484 COPY_ATTR_NTRY(new_attr_idx, spec_idx);
01485 AT_CIF_SYMBOL_ID(new_attr_idx) = 0;
01486 ADD_ATTR_TO_LOCAL_LIST(new_attr_idx);
01487 AT_REFERENCED(new_attr_idx) = Referenced;
01488 AT_DEF_IN_CHILD(new_attr_idx) = FALSE;
01489 AT_REF_IN_CHILD(new_attr_idx) = FALSE;
01490 AT_HOST_ASSOCIATED(new_attr_idx) = FALSE;
01491 ATP_INTERFACE_IDX(new_attr_idx) = gen_idx;
01492 spec_idx = new_attr_idx;
01493
01494 if (ATP_PGM_UNIT(spec_idx) == Function) {
01495
01496
01497
01498
01499 NTR_ATTR_TBL(new_attr_idx);
01500 COPY_ATTR_NTRY(new_attr_idx, ATP_RSLT_IDX(spec_idx));
01501 AT_CIF_SYMBOL_ID(new_attr_idx) = 0;
01502 AT_REFERENCED(new_attr_idx) = Referenced;
01503 AT_COMPILER_GEND(new_attr_idx) = TRUE;
01504 AT_DEF_IN_CHILD(new_attr_idx) = FALSE;
01505 AT_REF_IN_CHILD(new_attr_idx) = FALSE;
01506 AT_HOST_ASSOCIATED(new_attr_idx) = FALSE;
01507 ATD_STOR_BLK_IDX(new_attr_idx) = SCP_SB_STACK_IDX(
01508 curr_scp_idx);
01509 ATP_RSLT_IDX(spec_idx) = new_attr_idx;
01510 ATD_FUNC_IDX(new_attr_idx) = spec_idx;
01511 }
01512
01513 IR_IDX_L(ir_idx) = spec_idx;
01514 rslt_idx = ATP_RSLT_IDX(spec_idx);
01515
01516 if (rslt_idx != NULL_IDX &&
01517 #ifdef KEY
01518 FUNCTION_MUST_BE_SUBROUTINE(spec_idx, rslt_idx)
01519 #else
01520 FUNCTION_MUST_BE_SUBROUTINE(rslt_idx)
01521 #endif
01522 ) {
01523
01524 ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_DARG_IDX(curr_scp_idx);
01525
01526
01527
01528 if (!ATP_EXTRA_DARG(spec_idx)) {
01529 ATP_EXTRA_DARG(spec_idx) = TRUE;
01530
01531 sn_idx = ATP_FIRST_IDX(spec_idx);
01532
01533 NTR_SN_TBL(new_sn_idx);
01534 ATP_FIRST_IDX(spec_idx) = new_sn_idx;
01535 SN_NAME_LEN(new_sn_idx) = AT_NAME_LEN(rslt_idx);
01536 SN_NAME_IDX(new_sn_idx) = AT_NAME_IDX(rslt_idx);
01537 SN_ATTR_IDX(new_sn_idx) = rslt_idx;
01538
01539 for (i = 0; i < ATP_NUM_DARGS(spec_idx); i++) {
01540 NTR_SN_TBL(new_sn_idx);
01541 COPY_TBL_NTRY(sec_name_tbl, new_sn_idx, sn_idx);
01542 sn_idx++;
01543 }
01544
01545 ATP_NUM_DARGS(spec_idx) += 1;
01546 }
01547 }
01548 }
01549 }
01550 else if (spec_idx != gen_idx) {
01551
01552 if (ATP_SCP_IDX(spec_idx) != curr_scp_idx ||
01553 AT_NOT_VISIBLE(spec_idx)) {
01554
01555
01556
01557
01558
01559 new_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(spec_idx),
01560 AT_NAME_LEN(spec_idx),
01561 &name_idx);
01562
01563 if (new_attr_idx != spec_idx) {
01564
01565
01566
01567
01568
01569 ADD_ATTR_TO_LOCAL_LIST(spec_idx);
01570
01571 }
01572 }
01573
01574 if (host_associated) {
01575 host_associated_attr_semantics(spec_idx, FALSE);
01576 }
01577 AT_REFERENCED(spec_idx) = Referenced;
01578 }
01579
01580 if (save_where_ir_idx != NULL_IDX && ATP_VFUNCTION(spec_idx)) {
01581 PRINTMSG(line, 897, Error, col,
01582 AT_OBJ_NAME_PTR(spec_idx));
01583 ok = FALSE;
01584 goto DONE;
01585 }
01586
01587 SCP_HAS_CALLS(curr_scp_idx) = TRUE;
01588
01589 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01590 num_args = IR_LIST_CNT_R(ir_idx);
01591
01592 if (is_function) {
01593 rslt_idx = ATP_RSLT_IDX(spec_idx);
01594 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(rslt_idx);
01595
01596 save_shape_known = res_exp_desc->shape_known;
01597
01598 if (save_shape_known) {
01599 save_rank = res_exp_desc->rank;
01600
01601 COPY_SHAPE(save_shape, (res_exp_desc->shape), save_rank);
01602 }
01603
01604 if (! AT_ELEMENTAL_INTRIN(spec_idx)) {
01605 save_foldable = res_exp_desc->foldable;
01606 save_will_fold_later = res_exp_desc->will_fold_later;
01607 COPY_OPND(save_char_len, (res_exp_desc->char_len));
01608
01609 (*res_exp_desc) = init_exp_desc;
01610
01611 res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx);
01612 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx);
01613 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
01614 res_exp_desc->pointer = ATD_POINTER(rslt_idx);
01615 res_exp_desc->target = ATD_TARGET(rslt_idx);
01616 res_exp_desc->allocatable = ATD_ALLOCATABLE(rslt_idx);
01617 res_exp_desc->dope_vector = ATD_IM_A_DOPE(rslt_idx);
01618
01619 res_exp_desc->will_fold_later = save_will_fold_later;
01620 res_exp_desc->foldable = save_foldable;
01621
01622 if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX) {
01623 res_exp_desc->assumed_shape =
01624 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Shape);
01625 res_exp_desc->assumed_size =
01626 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Size);
01627
01628 IR_RANK(ir_idx) = BD_RANK(ATD_ARRAY_IDX(rslt_idx));
01629 res_exp_desc->rank = IR_RANK(ir_idx);
01630 res_exp_desc->contig_array = TRUE;
01631 }
01632 else {
01633 IR_RANK(ir_idx) = 0;
01634 }
01635 }
01636
01637 res_exp_desc->tmp_reference = TRUE;
01638
01639 if (! no_func_expansion) {
01640
01641 if (AT_IS_INTRIN(spec_idx) &&
01642 res_exp_desc->will_fold_later) {
01643
01644 copy_subtree(result_opnd, &save_result_opnd);
01645
01646 list_idx = IR_IDX_R(ir_idx);
01647
01648 while (list_idx) {
01649 arg_info_list_base = arg_info_list_top;
01650 arg_info_list_top = arg_info_list_base + 1;
01651
01652 if (arg_info_list_top >= arg_info_list_size) {
01653 enlarge_info_list_table();
01654 }
01655
01656 arg_info_list[arg_info_list_top] =
01657 arg_info_list[IL_ARG_DESC_IDX(list_idx)];
01658
01659 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top;
01660
01661 list_idx = IL_NEXT_LIST_IDX(list_idx);
01662 }
01663 }
01664
01665 flatten_function_call(result_opnd);
01666
01667 if (ATP_ELEMENTAL(spec_idx) &&
01668 ATP_PROC(spec_idx) != Intrin_Proc) {
01669
01670 attr_idx = find_base_attr(result_opnd, &line, &col);
01671 res_exp_desc->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx));
01672 }
01673
01674
01675
01676
01677
01678
01679 if (ATP_PROC(spec_idx) == Intrin_Proc &&
01680 ! ATI_USER_SPECIFIED(gen_idx) &&
01681 (cif_flags & MISC_RECS) != 0 &&
01682 xref_state != CIF_No_Usage_Rec) {
01683 cif_object_rec_for_func_result(spec_idx);
01684 }
01685
01686 if (res_exp_desc->type == Character || res_exp_desc->rank) {
01687
01688 attr_idx = find_base_attr(result_opnd, &line, &col);
01689
01690 if (res_exp_desc->type == Character) {
01691 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
01692 res_exp_desc->type_idx = ATD_TYPE_IDX(attr_idx);
01693 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx);
01694 res_exp_desc->linear_type =
01695 TYP_LINEAR(res_exp_desc->type_idx);
01696
01697 if (ATP_PROC(spec_idx) == Intrin_Proc) {
01698 COPY_OPND(res_exp_desc->char_len, save_char_len);
01699 }
01700 else {
01701 get_char_len(result_opnd, &(res_exp_desc->char_len));
01702 }
01703 }
01704
01705 if (res_exp_desc->rank && !AT_ELEMENTAL_INTRIN(spec_idx)) {
01706 get_shape_from_attr(res_exp_desc,
01707 attr_idx,
01708 res_exp_desc->rank,
01709 line,
01710 col);
01711 }
01712 }
01713 }
01714 else if (!AT_ELEMENTAL_INTRIN(spec_idx)) {
01715 set_shape_for_deferred_funcs(res_exp_desc, ir_idx);
01716
01717 if (AT_IS_INTRIN(spec_idx) &&
01718 (ATP_INTRIN_ENUM(spec_idx) == Transfer_Intrinsic ||
01719 ATP_INTRIN_ENUM(spec_idx) == Trim_Intrinsic)) {
01720 COPY_OPND((res_exp_desc->char_len), save_char_len);
01721 }
01722 }
01723
01724 if (save_shape_known) {
01725 res_exp_desc->shape_known = save_shape_known;
01726 res_exp_desc->rank = save_rank;
01727 COPY_SHAPE((res_exp_desc->shape), save_shape, save_rank);
01728 }
01729 }
01730 else if (label_cnt != 0 || ATP_HAS_ALT_RETURN(spec_idx)) {
01731
01732 NTR_IR_TBL(br_idx_idx);
01733 IR_OPR(br_idx_idx) = Br_Index_Opr;
01734 IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE;
01735
01736 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
01737 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
01738 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
01739 AT_REFERENCED(alt_return_tmp) = Referenced;
01740 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01741 AT_DEFINED(alt_return_tmp) = TRUE;
01742
01743 NTR_IR_TBL(asg_idx);
01744 IR_OPR(asg_idx) = Alt_Return_Opr;
01745 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
01746 IR_LINE_NUM(asg_idx) = line;
01747 IR_COL_NUM(asg_idx) = col;
01748 IR_LINE_NUM_L(asg_idx) = line;
01749 IR_COL_NUM_L(asg_idx) = col;
01750 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
01751 IR_IDX_L(asg_idx) = alt_return_tmp;
01752
01753 COPY_OPND(IR_OPND_R(asg_idx), (*result_opnd));
01754
01755 if (label_cnt != 0) {
01756 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
01757
01758 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
01759 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01760 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
01761
01762 IR_FLD_L(br_idx_idx) = AT_Tbl_Idx;
01763 IR_IDX_L(br_idx_idx) = alt_return_tmp;
01764 IR_LINE_NUM(br_idx_idx) = line;
01765 IR_COL_NUM(br_idx_idx) = col;
01766 IR_LINE_NUM_L(br_idx_idx) = line;
01767 IR_COL_NUM_L(br_idx_idx) = col;
01768 IR_FLD_R(br_idx_idx) = IL_Tbl_Idx;
01769 IR_IDX_R(br_idx_idx) = label_list_head;
01770 IR_LIST_CNT_R(br_idx_idx) = label_cnt;
01771
01772 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01773 OPND_IDX((*result_opnd)) = br_idx_idx;
01774
01775 list_idx2 = label_list_head;
01776 while (list_idx2) {
01777 AT_REFERENCED( IL_IDX(list_idx2)) = Referenced;
01778 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
01779 }
01780 }
01781 else {
01782 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01783 OPND_IDX((*result_opnd)) = asg_idx;
01784 }
01785 }
01786
01787 if (! no_func_expansion) {
01788
01789 if (! is_function) {
01790
01791 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01792 ok = final_arg_work(&opnd, spec_idx, num_args, NULL) && ok;
01793 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01794 }
01795
01796 if (ATP_PROC(spec_idx) != Dummy_Proc &&
01797 ATP_PROC(spec_idx) != Intrin_Proc &&
01798 ! ATP_VFUNCTION(spec_idx) &&
01799 (cmd_line_flags.runtime_argument ||
01800 cmd_line_flags.runtime_arg_call)) {
01801
01802 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01803 list_idx = IR_IDX_R(ir_idx);
01804 list_idx2 = NULL_IDX;
01805
01806 idx = 0;
01807
01808 while (list_idx) {
01809 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
01810 IR_OPR(IL_IDX(list_idx)) == False_Parm_Opr) {
01811
01812 false_list_idx = list_idx;
01813
01814 IL_NEXT_LIST_IDX(list_idx2) = NULL_IDX;
01815 break;
01816 }
01817
01818 list_idx2 = list_idx;
01819 list_idx = IL_NEXT_LIST_IDX(list_idx);
01820 idx++;
01821 }
01822
01823 IR_LIST_CNT_R(ir_idx) = idx;
01824 # endif
01825 ATP_ARGCHCK_CALL(spec_idx) = TRUE;
01826
01827 NTR_IR_TBL(loc_idx);
01828 IR_OPR(loc_idx) = Aloc_Opr;
01829 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
01830 IR_LINE_NUM(loc_idx) = line;
01831 IR_COL_NUM(loc_idx) = col;
01832 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
01833
01834 OPND_FLD(opnd) = IR_Tbl_Idx;
01835 OPND_IDX(opnd) = ir_idx;
01836 idx = create_argchck_descriptor(&opnd);
01837 IR_IDX_L(loc_idx) = idx;
01838 IR_LINE_NUM_L(loc_idx) = line;
01839 IR_COL_NUM_L(loc_idx) = col;
01840
01841 NTR_IR_LIST_TBL(list_idx2);
01842 IL_ARG_DESC_VARIANT(list_idx2) = TRUE;
01843 IL_FLD(list_idx2) = IR_Tbl_Idx;
01844 IL_IDX(list_idx2) = loc_idx;
01845
01846 if (IR_LIST_CNT_R(ir_idx) == 0) {
01847 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
01848 IR_IDX_R(ir_idx) = list_idx2;
01849 IR_LIST_CNT_R(ir_idx) = 1;
01850 }
01851 else {
01852 list_idx = IR_IDX_R(ir_idx);
01853 while (IL_NEXT_LIST_IDX(list_idx)) {
01854 list_idx = IL_NEXT_LIST_IDX(list_idx);
01855 }
01856
01857 IL_NEXT_LIST_IDX(list_idx) = list_idx2;
01858 (IR_LIST_CNT_R(ir_idx))++;
01859 }
01860
01861 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01862 if (false_list_idx) {
01863 IL_NEXT_LIST_IDX(list_idx2) = false_list_idx;
01864 list_idx = false_list_idx;
01865 while (list_idx) {
01866 (IR_LIST_CNT_R(ir_idx))++;
01867 list_idx = IL_NEXT_LIST_IDX(list_idx);
01868 }
01869 }
01870 # endif
01871 }
01872 }
01873
01874 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01875
01876 if (AT_OBJ_CLASS(gen_idx) == Interface &&
01877 ATP_PROC(spec_idx) != Intrin_Proc) {
01878
01879 PRINTMSG(line, 399, Comment, col, AT_OBJ_NAME_PTR(gen_idx),
01880 AT_OBJ_NAME_PTR(spec_idx));
01881 }
01882 }
01883 }
01884 else if (ok) {
01885
01886 if (AT_IS_INTRIN(gen_idx)) {
01887 PRINTMSG(line,
01888 700,
01889 Error,
01890 col,
01891 AT_OBJ_NAME_PTR(gen_idx));
01892 }
01893 else {
01894 PRINTMSG(line,
01895 389,
01896 Error,
01897 col,
01898 AT_OBJ_NAME_PTR(gen_idx));
01899 }
01900 ok = FALSE;
01901 }
01902
01903 DONE:
01904
01905 if (ok && found && (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01906 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) {
01907
01908 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))) {
01909
01910 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
01911 PRINTMSG(IR_LINE_NUM_L(ir_idx), 1274, Error, IR_COL_NUM_L(ir_idx),
01912 AT_OBJ_NAME_PTR(spec_idx),
01913 "pure or elemental",
01914 "pure");
01915
01916 }
01917 }
01918 else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
01919
01920 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
01921 PRINTMSG(IR_LINE_NUM_L(ir_idx), 1274, Error, IR_COL_NUM_L(ir_idx),
01922 AT_OBJ_NAME_PTR(spec_idx),
01923 "pure or elemental",
01924 "elemental");
01925
01926 }
01927 }
01928
01929
01930
01931
01932 list_idx = IR_IDX_R(ir_idx);
01933
01934 if (ATP_EXTRA_DARG(spec_idx)) {
01935 arg_idx = ATP_FIRST_IDX(spec_idx) + 1;
01936 num_args = ATP_NUM_DARGS(spec_idx) - 1;
01937 }
01938 else {
01939 arg_idx = ATP_FIRST_IDX(spec_idx);
01940 num_args = ATP_NUM_DARGS(spec_idx);
01941 }
01942 for (;num_args > 0; num_args--) {
01943
01944 if (AT_OBJ_CLASS(SN_ATTR_IDX(arg_idx)) == Data_Obj &&
01945 (ATD_POINTER(SN_ATTR_IDX(arg_idx)) ||
01946 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Inout ||
01947 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Out)) {
01948 COPY_OPND(opnd, IL_OPND(list_idx));
01949
01950 if (! check_for_legal_define(&opnd)) {
01951 ok = FALSE;
01952 }
01953 }
01954 arg_idx++;
01955 list_idx = IL_NEXT_LIST_IDX(list_idx);
01956 }
01957 }
01958
01959 if (ok && found && ATP_VFUNCTION(spec_idx)) {
01960 num_registers = 0;
01961 list_idx = IR_IDX_R(ir_idx);
01962
01963 while (list_idx) {
01964
01965 if (IL_ARG_DESC_IDX(list_idx) == NULL_IDX) {
01966 list_idx = IL_NEXT_LIST_IDX(list_idx);
01967 continue;
01968 }
01969
01970 if (arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type == Character ||
01971 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type == Structure) {
01972
01973 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx)].line,
01974 910, Error,
01975 arg_info_list[IL_ARG_DESC_IDX(list_idx)].col);
01976 ok = FALSE;
01977 break;
01978 }
01979 else {
01980 num_registers += TARGET_BITS_TO_WORDS(storage_bit_size_tbl[
01981 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.linear_type]);
01982 }
01983
01984 if (num_registers > 7) {
01985 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx)].line,
01986 909, Error,
01987 arg_info_list[IL_ARG_DESC_IDX(list_idx)].col);
01988 ok = FALSE;
01989 break;
01990 }
01991
01992 list_idx = IL_NEXT_LIST_IDX(list_idx);
01993 }
01994 }
01995
01996 if (ok && found && (ATP_PROC(spec_idx) == Intrin_Proc)) {
01997
01998 if (expr_mode == Specification_Expr) {
01999
02000 if (!AT_ELEMENTAL_INTRIN(spec_idx)) {
02001
02002 switch (ATP_INTRIN_ENUM(spec_idx)) {
02003
02004 # if defined(_F_MINUS_MINUS)
02005 case Num_Images_Intrinsic:
02006 case Log2_Images_Intrinsic:
02007 case Rem_Images_Intrinsic:
02008
02009 if (!cmd_line_flags.co_array_fortran) {
02010 PRINTMSG(line, 870, Error, col, AT_OBJ_NAME_PTR(gen_idx));
02011 ok = FALSE;
02012 break;
02013 }
02014 else if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
02015 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
02016 PRINTMSG(line, 1580, Error, col,
02017 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)),
02018 AT_OBJ_NAME_PTR(gen_idx));
02019 ok = FALSE;
02020 break;
02021 }
02022
02023
02024 # endif
02025
02026 case SIK_Intrinsic:
02027 case SRK_Intrinsic:
02028 case Lbound_Intrinsic:
02029 case Ubound_Intrinsic:
02030 case Size_Intrinsic:
02031 case Bit_Size_Intrinsic:
02032 case Len_Intrinsic:
02033 case Kind_Intrinsic:
02034 case Digits_Intrinsic:
02035 case Huge_Intrinsic:
02036 case Maxexponent_Intrinsic:
02037 case Minexponent_Intrinsic:
02038 case Precision_Intrinsic:
02039 case Radix_Intrinsic:
02040 case Range_Intrinsic:
02041 case Transfer_Intrinsic:
02042 case Merge_Intrinsic:
02043
02044
02045 if ((TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Integer &&
02046 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Character) ||
02047 res_exp_desc->rank > 1) {
02048 PRINTMSG(line, 1070, Error, col, AT_OBJ_NAME_PTR(gen_idx));
02049 ok = FALSE;
02050 }
02051 break;
02052
02053 default:
02054 PRINTMSG(line, 870, Error, col, AT_OBJ_NAME_PTR(gen_idx));
02055 ok = FALSE;
02056 break;
02057 }
02058 }
02059 else {
02060 if ((TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Integer &&
02061 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Character &&
02062 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Real &&
02063 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Typeless) ||
02064 res_exp_desc->rank > 1) {
02065 PRINTMSG(line, 1070, Error, col, AT_OBJ_NAME_PTR(gen_idx));
02066 ok = FALSE;
02067 }
02068 else {
02069 if (TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) == Real ||
02070 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) == Typeless) {
02071 PRINTMSG(line, 1392, Ansi, col);
02072 }
02073 }
02074 }
02075 }
02076 else if (expr_mode == Initialization_Expr) {
02077
02078 if (!AT_ELEMENTAL_INTRIN(spec_idx) &&
02079 (ATP_INTRIN_ENUM(spec_idx) != SIK_Intrinsic) &&
02080 (ATP_INTRIN_ENUM(spec_idx) != SRK_Intrinsic) &&
02081 (ATP_INTRIN_ENUM(spec_idx) != Repeat_Intrinsic) &&
02082 (ATP_INTRIN_ENUM(spec_idx) != Reshape_Intrinsic) &&
02083 (ATP_INTRIN_ENUM(spec_idx) != Lbound_Intrinsic) &&
02084 (ATP_INTRIN_ENUM(spec_idx) != Ubound_Intrinsic) &&
02085 (ATP_INTRIN_ENUM(spec_idx) != Size_Intrinsic) &&
02086 (ATP_INTRIN_ENUM(spec_idx) != Shape_Intrinsic) &&
02087 (ATP_INTRIN_ENUM(spec_idx) != Transfer_Intrinsic) &&
02088 (ATP_INTRIN_ENUM(spec_idx) != Null_Intrinsic) &&
02089 (ATP_INTRIN_ENUM(spec_idx) != Trim_Intrinsic)) {
02090 PRINTMSG(line, 329, Error, col, AT_OBJ_NAME_PTR(gen_idx));
02091 ok = FALSE;
02092 }
02093 }
02094 }
02095
02096 if (ok &&
02097 ATP_PROC(spec_idx) != Intrin_Proc) {
02098
02099 #ifdef KEY
02100
02101 if (! (ATP_PURE(spec_idx) || ATP_ELEMENTAL(spec_idx)))
02102 #else
02103 if (! ATP_PURE(spec_idx))
02104 #endif
02105 {
02106 if (within_forall_mask_expr) {
02107 PRINTMSG(line, 1611, Error, col, AT_OBJ_NAME_PTR(spec_idx),
02108 "forall scalar-mask-expr");
02109 ok = FALSE;
02110 }
02111 else if (within_forall_construct) {
02112 PRINTMSG(line, 1611, Error, col, AT_OBJ_NAME_PTR(spec_idx),
02113 "forall-body-construct");
02114 ok = FALSE;
02115 }
02116 }
02117 }
02118
02119 res_exp_desc->has_symbolic = has_symbolic;
02120
02121 defer_stmt_expansion = save_defer_stmt_expansion;
02122 stmt_expansion_control_end(result_opnd);
02123
02124 if (OPND_FLD(save_result_opnd) != NO_Tbl_Idx &&
02125 OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
02126 IR_OPR(OPND_IDX((*result_opnd))) == Stmt_Expansion_Opr) {
02127
02128 list_idx = IR_IDX_R(OPND_IDX((*result_opnd)));
02129
02130 while (IL_NEXT_LIST_IDX(list_idx)) {
02131 list_idx = IL_NEXT_LIST_IDX(list_idx);
02132 }
02133
02134 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02135 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02136 list_idx = IL_NEXT_LIST_IDX(list_idx);
02137
02138 COPY_OPND(IL_OPND(list_idx), save_result_opnd);
02139
02140 IR_LIST_CNT_R(OPND_IDX((*result_opnd))) += 1;
02141 }
02142
02143 if (save_where_ir_idx != NULL_IDX &&
02144 where_ir_idx == NULL_IDX) {
02145
02146 where_ir_idx = save_where_ir_idx;
02147
02148 if (ATP_ELEMENTAL(spec_idx)) {
02149 check_for_elementals(find_left_attr(result_opnd));
02150 }
02151 }
02152 else {
02153 where_ir_idx = save_where_ir_idx;
02154 }
02155
02156 TRACE (Func_Exit, "call_list_semantics", NULL);
02157
02158 return(ok);
02159
02160 }
02161
02162
02163
02164
02165
02166
02167
02168
02169
02170
02171
02172
02173
02174
02175
02176
02177
02178 static void check_for_elementals(int attr_idx)
02179
02180 {
02181 int asg_idx;
02182 int call_idx;
02183 int col;
02184 int line;
02185 int list_idx;
02186 opnd_type opnd;
02187 int tmp_idx;
02188
02189 TRACE (Func_Entry, "check_for_elementals", NULL);
02190
02191 line = AT_DEF_LINE(attr_idx);
02192 col = AT_DEF_COLUMN(attr_idx);
02193
02194 # ifdef _DEBUG
02195 if (ATD_FLD(attr_idx) != IR_Tbl_Idx) {
02196 PRINTMSG(line, 626, Internal, col,
02197 "ATD_FLD(attr_idx) == IR_Tbl_Idx", "check_for_elementals");
02198 }
02199 # endif
02200
02201
02202 asg_idx = ATD_TMP_IDX(attr_idx);
02203
02204 # ifdef _DEBUG
02205 if (IR_FLD_R(asg_idx) != IR_Tbl_Idx ||
02206 IR_OPR(IR_IDX_R(asg_idx)) != Call_Opr ||
02207 ! ATP_ELEMENTAL(IR_IDX_L(IR_IDX_R(asg_idx)))) {
02208
02209 PRINTMSG(line, 626, Internal, col,
02210 "elemental function", "check_for_elementals");
02211 }
02212 # endif
02213
02214 call_idx = IR_IDX_R(asg_idx);
02215
02216 change_asg_to_where(asg_idx);
02217
02218
02219
02220
02221
02222 list_idx = IR_IDX_R(call_idx);
02223
02224 while (list_idx) {
02225
02226 tmp_idx = find_left_attr(&IL_OPND(list_idx));
02227 line = AT_DEF_LINE(tmp_idx);
02228 col = AT_DEF_COLUMN(tmp_idx);
02229
02230 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj &&
02231 ATD_CLASS(tmp_idx) == Compiler_Tmp &&
02232 ATD_FLD(tmp_idx) == IR_Tbl_Idx &&
02233 ATD_ARRAY_IDX(tmp_idx) != NULL_IDX &&
02234 (ATD_ELEMENTAL_CALL_TMP(tmp_idx) ||
02235 ATD_ASG_TMP(tmp_idx))) {
02236
02237 asg_idx = ATD_TMP_IDX(tmp_idx);
02238
02239 # ifdef _DEBUG
02240 if (IR_OPR(asg_idx) != Asg_Opr) {
02241 PRINTMSG(line, 626, Internal, col,
02242 "Asg_Opr", "check_for_elementals");
02243 }
02244 # endif
02245
02246 if (ATD_ELEMENTAL_CALL_TMP(tmp_idx)) {
02247 check_for_elementals(tmp_idx);
02248 }
02249 else if (ATD_ASG_TMP(tmp_idx)) {
02250 COPY_OPND(opnd, IR_OPND_R(asg_idx));
02251 check_expr_for_elementals(&opnd);
02252
02253 change_asg_to_where(asg_idx);
02254 }
02255 }
02256
02257 list_idx = IL_NEXT_LIST_IDX(list_idx);
02258 }
02259
02260 TRACE (Func_Exit, "check_for_elementals", NULL);
02261
02262 return;
02263
02264 }
02265
02266
02267
02268
02269
02270
02271
02272
02273
02274
02275
02276
02277
02278
02279
02280
02281
02282 static void check_expr_for_elementals(opnd_type *top_opnd)
02283
02284 {
02285 int attr_idx;
02286 int ir_idx;
02287 int list_idx;
02288 opnd_type opnd;
02289
02290 TRACE (Func_Entry, "check_expr_for_elementals", NULL);
02291
02292 switch (OPND_FLD((*top_opnd))) {
02293 case AT_Tbl_Idx:
02294 attr_idx = OPND_IDX((*top_opnd));
02295
02296 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
02297 ATD_CLASS(attr_idx) == Compiler_Tmp &&
02298 ATD_ELEMENTAL_CALL_TMP(attr_idx)) {
02299
02300 check_for_elementals(attr_idx);
02301 }
02302 break;
02303
02304 case IR_Tbl_Idx:
02305 ir_idx = OPND_IDX((*top_opnd));
02306 COPY_OPND(opnd, IR_OPND_L(ir_idx));
02307 check_expr_for_elementals(&opnd);
02308 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02309 check_expr_for_elementals(&opnd);
02310 break;
02311
02312 case IL_Tbl_Idx:
02313 list_idx = OPND_IDX((*top_opnd));
02314 while (list_idx) {
02315 COPY_OPND(opnd, IL_OPND(list_idx));
02316 check_expr_for_elementals(&opnd);
02317 list_idx = IL_NEXT_LIST_IDX(list_idx);
02318 }
02319 break;
02320
02321 case CN_Tbl_Idx:
02322 case NO_Tbl_Idx:
02323 case SH_Tbl_Idx:
02324 break;
02325 }
02326
02327 TRACE (Func_Exit, "check_expr_for_elementals", NULL);
02328
02329 return;
02330
02331 }
02332
02333
02334
02335
02336
02337
02338
02339
02340
02341
02342
02343
02344
02345
02346
02347
02348
02349 void change_asg_to_where(int asg_idx)
02350
02351 {
02352 int list_idx;
02353
02354 TRACE (Func_Entry, "change_asg_to_where", NULL);
02355
02356 if (IR_OPR(asg_idx) == Call_Opr) {
02357
02358
02359 NTR_IR_LIST_TBL(list_idx);
02360 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(asg_idx));
02361 IR_FLD_L(asg_idx) = IL_Tbl_Idx;
02362 IR_IDX_L(asg_idx) = list_idx;
02363 IR_LIST_CNT_L(asg_idx) = 4;
02364
02365
02366
02367 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02368 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02369 list_idx = IL_NEXT_LIST_IDX(list_idx);
02370
02371 COPY_OPND(IL_OPND(list_idx),
02372 IL_OPND(IR_IDX_R(asg_idx)));
02373
02374
02375
02376 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02377 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02378 list_idx = IL_NEXT_LIST_IDX(list_idx);
02379
02380 IL_FLD(list_idx) = IR_Tbl_Idx;
02381 IL_IDX(list_idx) = where_ir_idx;
02382
02383
02384
02385 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02386 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02387 list_idx = IL_NEXT_LIST_IDX(list_idx);
02388
02389 COPY_OPND(IL_OPND(list_idx),
02390 IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(asg_idx))));
02391 }
02392 else {
02393
02394
02395 NTR_IR_LIST_TBL(list_idx);
02396 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(asg_idx));
02397 IR_FLD_L(asg_idx) = IL_Tbl_Idx;
02398 IR_IDX_L(asg_idx) = list_idx;
02399 IR_LIST_CNT_L(asg_idx) = 3;
02400
02401
02402
02403 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02404 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02405 list_idx = IL_NEXT_LIST_IDX(list_idx);
02406
02407 IL_FLD(list_idx) = IR_Tbl_Idx;
02408 IL_IDX(list_idx) = where_ir_idx;
02409
02410
02411
02412 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02413 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02414 list_idx = IL_NEXT_LIST_IDX(list_idx);
02415
02416 COPY_OPND(IL_OPND(list_idx), IR_OPND_R(asg_idx));
02417 }
02418
02419 IR_OPR(asg_idx) = Where_Opr;
02420 IR_OPND_R(asg_idx) = null_opnd;
02421
02422 TRACE (Func_Exit, "change_asg_to_where", NULL);
02423
02424 return;
02425
02426 }
02427
02428 #ifdef KEY
02429 static boolean inside_loop(int stmt_sh_idx)
02430 {
02431 while (stmt_sh_idx != NULL_IDX){
02432 if ( SH_STMT_TYPE(stmt_sh_idx) == Do_Iterative_Stmt ||
02433 SH_STMT_TYPE(stmt_sh_idx) == Do_While_Stmt)
02434 return TRUE;
02435 else if (IR_OPR(SH_IR_IDX(stmt_sh_idx)) == Label_Opr ||
02436 SH_STMT_TYPE(stmt_sh_idx) == End_Do_Stmt ||
02437 SH_STMT_TYPE(stmt_sh_idx) == End_Forall_Stmt)
02438 return FALSE;
02439 stmt_sh_idx = SH_PREV_IDX(stmt_sh_idx);
02440 }
02441 return FALSE;
02442 }
02443 static boolean stride_access_greater_than_1(opnd_type * opnd, char *dim)
02444 {
02445 int ir_idx = OPND_IDX((*opnd));
02446
02447 if (ir_idx == NULL_IDX) return FALSE;
02448
02449 if (OPND_FLD((*opnd)) != IR_Tbl_Idx || IR_RANK(ir_idx) < 1)
02450 return FALSE;
02451
02452 if (IR_FLD_R(ir_idx) != IL_Tbl_Idx)
02453 return FALSE;
02454
02455 int list_idx = IR_IDX_R(ir_idx);
02456 int counter = 1;
02457 boolean flag = FALSE;
02458
02459 while (list_idx != NULL_IDX) {
02460
02461 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
02462 IR_RANK(IL_IDX(list_idx)) > 0){
02463 (*dim) ++;
02464 if (counter > 1)
02465 flag = TRUE;
02466 }
02467
02468 list_idx = IL_NEXT_LIST_IDX(list_idx);
02469 dim ++;
02470 counter ++;
02471 }
02472 return flag;
02473 }
02474 #ifndef KEY
02475 static void generate_max_bound(opnd_type *opnd, int ir_idx, int attr_idx, int dim)
02476 {
02477 int plus_idx, sub_idx, div_idx, plus_idx1, minus_idx, attr_bd_idx,
02478 max_idx, list_idx, dv_idx, dv_low_idx, deref_idx, deref_fld;
02479 int line, col;
02480
02481 max_idx = IR_IDX_R(ir_idx);
02482 list_idx = IR_IDX_L(max_idx);
02483 line = IR_LINE_NUM(max_idx);
02484 col = IR_COL_NUM(max_idx);
02485
02486 NTR_IR_TBL(plus_idx);
02487 IR_OPR(plus_idx) = Plus_Opr;
02488 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE;
02489 IR_LINE_NUM(plus_idx) = line;
02490 IR_COL_NUM(plus_idx) = col;
02491
02492 NTR_IR_TBL(sub_idx);
02493 IR_OPR(sub_idx) = Minus_Opr;
02494 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
02495 IR_LINE_NUM(sub_idx) = line;
02496 IR_COL_NUM(sub_idx) = col;
02497
02498 NTR_IR_TBL(div_idx);
02499 IR_OPR(div_idx) = Div_Opr;
02500 IR_TYPE_IDX(div_idx) = CG_INTEGER_DEFAULT_TYPE;
02501 IR_LINE_NUM(div_idx) = line;
02502 IR_COL_NUM(div_idx) = col;
02503
02504 IL_IDX(list_idx) = div_idx;
02505 IR_FLD_L(div_idx) = IR_Tbl_Idx;
02506 IR_IDX_L(div_idx) = plus_idx;
02507
02508 IR_FLD_L(plus_idx) = IR_Tbl_Idx;
02509 IR_IDX_L(plus_idx) = sub_idx;
02510
02511 IR_FLD_R(plus_idx) = CN_Tbl_Idx;
02512 IR_IDX_R(plus_idx) = CN_INTEGER_ONE_IDX;
02513 IR_LINE_NUM_R(plus_idx) = line;
02514 IR_COL_NUM_R(plus_idx) = col;
02515
02516 if (ATD_CLASS(attr_idx) == Variable)
02517 attr_bd_idx = ATD_ARRAY_IDX(attr_idx);
02518
02519 if (ATD_CLASS(attr_idx) == Dummy_Argument ||
02520 #ifdef KEY
02521 ATD_CLASS(attr_idx) == Function_Result ||
02522 #endif
02523 ATD_CLASS(attr_idx) == Variable){
02524 attr_bd_idx = ATD_ARRAY_IDX(attr_idx);
02525 if (attr_bd_idx &&
02526 (BD_ARRAY_CLASS(attr_bd_idx) == Assumed_Shape ||
02527 BD_ARRAY_CLASS(attr_bd_idx) == Explicit_Shape)){
02528 IR_FLD_R(sub_idx) = BD_LB_FLD(attr_bd_idx,dim);
02529 IR_IDX_R(sub_idx) = BD_LB_IDX(attr_bd_idx,dim);
02530 }
02531 else{
02532 deref_idx = IR_IDX_L(IR_IDX_L(OPND_IDX((*opnd))));
02533 deref_fld = IR_FLD_L(IR_IDX_L(OPND_IDX((*opnd))));
02534 dv_low_idx = gen_ir(deref_fld, deref_idx,
02535 Dv_Access_Low_Bound, SA_INTEGER_DEFAULT_TYPE, line, col,
02536 NO_Tbl_Idx, NULL_IDX);
02537 IR_DV_DIM(dv_low_idx) = dim;
02538 IR_FLD_R(sub_idx) = IR_Tbl_Idx;
02539 IR_IDX_R(sub_idx) = dv_low_idx;
02540 }
02541 IR_LINE_NUM_R(sub_idx) = line;
02542 IR_COL_NUM_R(sub_idx) = col;
02543 }
02544
02545 IR_FLD_R(div_idx) = CN_Tbl_Idx;
02546 IR_IDX_R(div_idx) = CN_INTEGER_ONE_IDX;
02547 IR_LINE_NUM_R(div_idx) = line;
02548 IR_COL_NUM_R(div_idx) = col;
02549
02550 if (ATD_CLASS(attr_idx) == Dummy_Argument ||
02551 #ifdef KEY
02552 ATD_CLASS(attr_idx) == Function_Result ||
02553 #endif
02554 ATD_CLASS(attr_idx) == Variable){
02555 attr_bd_idx = ATD_ARRAY_IDX(attr_idx);
02556 if (BD_ARRAY_CLASS(attr_bd_idx) == Explicit_Shape){
02557 IR_FLD_L(sub_idx) = BD_UB_FLD(attr_bd_idx,dim);
02558 IR_IDX_L(sub_idx) = BD_UB_IDX(attr_bd_idx,dim);
02559 }
02560 else{
02561 deref_idx = IR_IDX_L(IR_IDX_L(OPND_IDX((*opnd))));
02562 deref_fld = IR_FLD_L(IR_IDX_L(OPND_IDX((*opnd))));
02563 dv_idx = gen_ir(deref_fld, deref_idx,
02564 Dv_Access_Extent,SA_INTEGER_DEFAULT_TYPE,line,col,
02565 NO_Tbl_Idx, NULL_IDX);
02566
02567 IR_DV_DIM(dv_idx) = dim;
02568
02569 if (attr_bd_idx &&
02570 BD_ARRAY_CLASS(attr_bd_idx) == Assumed_Shape)
02571 plus_idx1 = gen_ir(BD_LB_FLD(attr_bd_idx,dim), BD_LB_IDX(attr_bd_idx,dim),
02572 Plus_Opr,SA_INTEGER_DEFAULT_TYPE,line,col,
02573 IR_Tbl_Idx, dv_idx);
02574 else{
02575 deref_idx = IR_IDX_L(IR_IDX_L(OPND_IDX((*opnd))));
02576 deref_fld = IR_FLD_L(IR_IDX_L(OPND_IDX((*opnd))));
02577 dv_low_idx = gen_ir(deref_fld, deref_idx,
02578 Dv_Access_Low_Bound, SA_INTEGER_DEFAULT_TYPE, line, col,
02579 NO_Tbl_Idx, NULL_IDX);
02580 IR_DV_DIM(dv_low_idx) = dim;
02581 plus_idx1 = gen_ir(IR_Tbl_Idx, dv_low_idx,
02582 Plus_Opr,SA_INTEGER_DEFAULT_TYPE,line,col,
02583 IR_Tbl_Idx, dv_idx);
02584 }
02585 minus_idx = gen_ir(IR_Tbl_Idx, plus_idx1,
02586 Minus_Opr,SA_INTEGER_DEFAULT_TYPE,line,col,
02587 CN_Tbl_Idx, CN_INTEGER_ONE_IDX);
02588 IR_FLD_L(sub_idx) = IR_Tbl_Idx;
02589 IR_IDX_L(sub_idx) = minus_idx;
02590 }
02591 }
02592
02593 IR_LINE_NUM_L(sub_idx) = line;
02594 IR_COL_NUM_L(sub_idx) = col;
02595
02596 }
02597 #endif
02598
02599 #ifdef KEY
02600
02601
02602
02603
02604
02605
02606
02607
02608 static boolean check_leaves(fld_type fld, int idx, int array_idx) {
02609 switch(fld) {
02610 case AT_Tbl_Idx:
02611 return idx == array_idx;
02612 case IR_Tbl_Idx:
02613 return check_leaves(IR_FLD_L(idx), IR_IDX_L(idx), array_idx) &&
02614 check_leaves(IR_FLD_R(idx), IR_IDX_R(idx), array_idx);
02615 case IL_Tbl_Idx:
02616 for (; NULL_IDX != idx; idx = IL_NEXT_LIST_IDX(idx)) {
02617 if (!check_leaves(IL_FLD(idx), IL_IDX(idx), array_idx)) {
02618 return FALSE;
02619 }
02620 }
02621 }
02622 return TRUE;
02623 }
02624
02625
02626
02627
02628
02629
02630
02631 static boolean safe_to_move_copyinout_alloc(opnd_type *opnd)
02632 {
02633
02634
02635 int sso_idx = OPND_IDX((*opnd));
02636 int array_idx;
02637 if (Section_Subscript_Opr != IR_OPR(sso_idx)) return FALSE;
02638 if (AT_Tbl_Idx == IR_FLD_L(sso_idx)) {
02639 array_idx = IR_IDX_L(sso_idx);
02640 }
02641 else {
02642 if (IR_Tbl_Idx != IR_FLD_L(sso_idx)) return FALSE;
02643 int dvdro_idx = IR_IDX_L(sso_idx);
02644 if (Dv_Deref_Opr != IR_OPR(dvdro_idx)) return FALSE;
02645 if (AT_Tbl_Idx != IR_FLD_L(dvdro_idx)) return FALSE;
02646 array_idx = IR_IDX_L(dvdro_idx);
02647 }
02648
02649
02650
02651
02652
02653
02654
02655
02656
02657
02658
02659
02660 if (IL_Tbl_Idx != IR_FLD_R(sso_idx)) return FALSE;
02661 for (int list_idx = IR_IDX_R(sso_idx); NULL_IDX != list_idx;
02662 list_idx = IL_NEXT_LIST_IDX(list_idx)) {
02663 int subscr_idx = IL_IDX(list_idx);
02664 if (IR_Tbl_Idx != IL_FLD(list_idx) || Triplet_Opr != IR_OPR(subscr_idx)) {
02665 continue;
02666 }
02667 if (IL_Tbl_Idx != IR_FLD_L(subscr_idx)) return FALSE;
02668 for (int tlist_idx = IR_IDX_L(subscr_idx); NULL_IDX != tlist_idx;
02669 tlist_idx = IL_NEXT_LIST_IDX(tlist_idx)) {
02670 if (!check_leaves(IL_FLD(tlist_idx), IL_IDX(tlist_idx), array_idx)) {
02671 return FALSE;
02672 }
02673 }
02674 }
02675
02676 return TRUE;
02677 }
02678 #endif
02679
02680
02681
02682
02683
02684
02685
02686
02687
02688
02689
02690 static void move_tmp_alloc_assignment(int old_stmt_sh_idx, int attr_idx)
02691 {
02692 int entry_stmt_sh_idx, next_stmt_sh_idx,
02693 first_stmt_sh_idx, last_stmt_sh_idx, entry_list_idx,
02694 new_start_sh_idx, new_end_sh_idx, entry_attr_idx;
02695
02696 #ifdef _DEBUG
02697 move_copyinout_alloc_count += 1;
02698 #endif
02699
02700
02701
02702
02703
02704
02705
02706 for (entry_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);
02707 entry_stmt_sh_idx != NULL_IDX;
02708 entry_stmt_sh_idx = SH_NEXT_IDX(entry_stmt_sh_idx)){
02709 if (IR_OPR(SH_IR_IDX(entry_stmt_sh_idx)) == Entry_Opr) {
02710 break;
02711 }
02712 }
02713
02714 if (entry_stmt_sh_idx == NULL_IDX)
02715 PRINTMSG (stmt_start_line, 1044, Internal, SH_COL_NUM(old_stmt_sh_idx),
02716 "No Entry_Opr");
02717
02718
02719 while (IR_OPR(SH_IR_IDX(SH_NEXT_IDX(entry_stmt_sh_idx)))
02720 != User_Code_Start_Opr)
02721 entry_stmt_sh_idx = SH_NEXT_IDX(entry_stmt_sh_idx);
02722
02723 #ifndef KEY
02724 . for (dim_counter = 0; dim_counter < MAX_DIMENSION; dim_counter ++)
02725 . if (dim[dim_counter] > 0)
02726 . break;
02727 #endif
02728
02729
02730
02731
02732 last_stmt_sh_idx = NULL_IDX;
02733 for (int stmt_sh_idx = first_stmt_sh_idx = SH_NEXT_IDX(old_stmt_sh_idx);
02734 stmt_sh_idx != curr_stmt_sh_idx;
02735 stmt_sh_idx = SH_NEXT_IDX(stmt_sh_idx)) {
02736 #ifndef KEY
02737 . if (IR_OPR(SH_IR_IDX(stmt_sh_idx)) == Asg_Opr &&
02738 . IR_OPR(IR_IDX_R(SH_IR_IDX(stmt_sh_idx))) == Max_Opr && dim_counter < MAX_DIMENSION){
02739 .
02740
02741
02742
02743
02744
02745 . generate_max_bound(opnd, SH_IR_IDX(stmt_sh_idx), attr_idx, dim_counter+1);
02746 . dim_counter ++;
02747 . for (;dim_counter < MAX_DIMENSION; dim_counter ++)
02748 . if (dim[dim_counter] > 0)
02749 . break;
02750 . }
02751 #endif
02752 if (IR_OPR(SH_IR_IDX(stmt_sh_idx)) == Asg_Opr &&
02753 IR_OPR(IR_IDX_R(SH_IR_IDX(stmt_sh_idx))) == Alloc_Opr){
02754 last_stmt_sh_idx = stmt_sh_idx;
02755 break;
02756 }
02757 }
02758
02759 if (last_stmt_sh_idx == NULL_IDX)
02760 return;
02761
02762 SH_NEXT_IDX(SH_PREV_IDX(first_stmt_sh_idx)) = SH_NEXT_IDX(last_stmt_sh_idx);
02763 SH_PREV_IDX(SH_NEXT_IDX(last_stmt_sh_idx)) = SH_PREV_IDX(first_stmt_sh_idx);
02764
02765 next_stmt_sh_idx = SH_NEXT_IDX(entry_stmt_sh_idx);
02766 SH_NEXT_IDX(entry_stmt_sh_idx) = first_stmt_sh_idx;
02767 SH_PREV_IDX(first_stmt_sh_idx) = entry_stmt_sh_idx;
02768 SH_NEXT_IDX(last_stmt_sh_idx) = next_stmt_sh_idx;
02769 SH_PREV_IDX(next_stmt_sh_idx) = last_stmt_sh_idx;
02770
02771 #ifdef KEY
02772
02773
02774
02775
02776
02777 if (AT_OPTIONAL(attr_idx)) {
02778 gen_present_ir(attr_idx, first_stmt_sh_idx, last_stmt_sh_idx);
02779 }
02780 #endif
02781
02782 entry_list_idx = SCP_ENTRY_IDX(curr_scp_idx);
02783 while (entry_list_idx != NULL_IDX) {
02784 entry_attr_idx = AL_ATTR_IDX(entry_list_idx);
02785 entry_stmt_sh_idx = ATP_FIRST_SH_IDX(entry_attr_idx);
02786 next_stmt_sh_idx = SH_NEXT_IDX(entry_stmt_sh_idx);
02787 copy_entry_exit_sh_list(first_stmt_sh_idx,
02788 last_stmt_sh_idx,
02789 &new_start_sh_idx,
02790 &new_end_sh_idx);
02791
02792 if (new_start_sh_idx != NULL_IDX) {
02793 SH_NEXT_IDX(entry_stmt_sh_idx) = new_start_sh_idx;
02794 SH_PREV_IDX(new_start_sh_idx) = entry_stmt_sh_idx;
02795
02796 entry_stmt_sh_idx = new_end_sh_idx;
02797
02798 SH_PREV_IDX(next_stmt_sh_idx) = entry_stmt_sh_idx;
02799 SH_NEXT_IDX(entry_stmt_sh_idx) = next_stmt_sh_idx;
02800 ATP_FIRST_SH_IDX(entry_attr_idx) = entry_stmt_sh_idx;
02801 entry_list_idx = AL_NEXT_IDX(entry_list_idx);
02802 }
02803 }
02804
02805 return;
02806 }
02807 #endif
02808 #ifdef KEY
02809
02810
02811
02812
02813
02814
02815
02816
02817
02818 static int clear_pt_unique_mem(int dummy) {
02819 if (LANG_Ignore_Target_Attribute) {
02820 return 0;
02821 }
02822 return dummy && (AT_OBJ_CLASS(dummy) == Data_Obj) && ATD_TARGET(dummy);
02823 }
02824 #endif
02825 #ifdef KEY
02826 extern int create_tmp_asg_or_call(opnd_type *r_opnd, expr_arg_type *exp_desc,
02827 opnd_type *left_opnd, int intent, boolean stmt_tmp,
02828 boolean save_where_dealloc_stmt, int info_idx, dummy_arg_type a_type,
02829 dummy_arg_type d_type);
02830 static int common_create_tmp_asg(opnd_type *r_opnd, expr_arg_type *exp_desc,
02831 opnd_type *left_opnd, int intent, boolean stmt_tmp,
02832 boolean save_where_dealloc_stmt, boolean call);
02833
02834
02835
02836
02837
02838 int
02839 pass_by_ref(fld_type fld, int idx, int line, int col) {
02840 int ir_idx;
02841 NTR_IR_TBL(ir_idx);
02842 IR_OPR(ir_idx) = Aloc_Opr;
02843 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
02844 IR_LINE_NUM(ir_idx) = line;
02845 IR_COL_NUM(ir_idx) = col;
02846 IR_FLD_L(ir_idx) = fld;
02847 IR_IDX_L(ir_idx) = idx;
02848 IR_LINE_NUM_L(ir_idx) = line;
02849 IR_COL_NUM_L(ir_idx) = col;
02850 return ir_idx;
02851 }
02852
02853
02854
02855
02856
02857
02858
02859
02860
02861
02862 static int
02863 get_variable_reference(opnd_type *opnd, fld_type *fld) {
02864 fld_type ft = opnd->fld;
02865 Uint idx = opnd->idx;
02866 for (;;) {
02867 switch (ft) {
02868 case AT_Tbl_Idx:
02869 *fld = AT_Tbl_Idx;
02870 return idx;
02871 break;
02872 case IR_Tbl_Idx:
02873 if (IR_OPR(idx) == Struct_Opr) {
02874 *fld = IR_Tbl_Idx;
02875 return idx;
02876 }
02877 ft = IR_FLD_L(idx);
02878 idx = IR_IDX_L(idx);
02879 break;
02880 default:
02881 return NULL_IDX;
02882 }
02883 }
02884 }
02885
02886
02887
02888
02889
02890
02891
02892
02893 static int
02894 build_copyinout_call(glb_tbl_idx_type which_call, char *name,
02895 fld_type dest_fld, int dest_idx, fld_type src_fld, int src_idx, int line,
02896 int column)
02897 {
02898 int arg_list_idx = gen_il(2, TRUE, line, column,
02899 IR_Tbl_Idx, pass_by_ref(dest_fld, dest_idx, line, column),
02900 IR_Tbl_Idx, pass_by_ref(src_fld, src_idx, line, column));
02901
02902 return build_call(which_call, name, arg_list_idx, line, column);
02903 }
02904 #endif
02905
02906 #ifdef KEY
02907
02908
02909
02910
02911
02912
02913
02914
02915
02916
02917
02918 int
02919 build_call(glb_tbl_idx_type which_call, char *name, int arg_list_idx, int line,
02920 int column) {
02921
02922
02923
02924 if (glb_tbl_idx[which_call] == NULL_IDX) {
02925 glb_tbl_idx[which_call] = create_lib_entry_attr(name, strlen(name), line,
02926 column);
02927 ATP_PURE(glb_tbl_idx[which_call]) = TRUE;
02928 }
02929 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[which_call]);
02930
02931
02932 int call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[which_call], Call_Opr,
02933 TYPELESS_DEFAULT_TYPE, line, column, IL_Tbl_Idx, arg_list_idx);
02934
02935
02936 opnd_type opnd;
02937 gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, column);
02938 cif_usage_code_type save_xref_state = xref_state;
02939 xref_state = CIF_No_Usage_Rec;
02940 expr_mode_type save_expr_mode = expr_mode;
02941 expr_mode = Regular_Expr;
02942 expr_arg_type exp_desc = init_exp_desc;
02943 stop_recursion = TRUE;
02944 call_list_semantics(&opnd, &exp_desc, FALSE);
02945 stop_recursion = FALSE;
02946 xref_state = save_xref_state;
02947 expr_mode = save_expr_mode;
02948
02949 return call_idx;
02950 }
02951
02952
02953
02954
02955
02956
02957
02958
02959
02960
02961
02962
02963 static int
02964 gen_ieee_save_or_restore(glb_tbl_idx_type which_call, char *name,
02965 int arg_idx, int line, int column)
02966 {
02967 int curr_stmt_sh_idx = ntr_sh_tbl();
02968 SH_STMT_TYPE(curr_stmt_sh_idx) = Call_Stmt;
02969 SH_GLB_LINE(curr_stmt_sh_idx) = line;
02970 SH_COL_NUM(curr_stmt_sh_idx) = column;
02971 SH_COMPILER_GEN(curr_stmt_sh_idx) = TRUE;
02972 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02973
02974 int arg_list_idx = gen_il(1, TRUE, line, column,
02975 IR_Tbl_Idx, pass_by_ref(AT_Tbl_Idx, arg_idx, line, column));
02976
02977 SH_IR_IDX(curr_stmt_sh_idx) = build_call(which_call, name, arg_list_idx, line,
02978 column);
02979
02980 return curr_stmt_sh_idx;
02981 }
02982
02983
02984
02985
02986
02987
02988
02989
02990
02991
02992
02993 int
02994 gen_ieee_save_and_restore(int curr_scp_idx, int line, int column) {
02995
02996
02997 int tmp_idx = gen_compiler_tmp(line, column, Priv, TRUE);
02998 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
02999 TYP_TYPE(TYP_WORK_IDX) = Typeless;
03000 int ieee_save_size = WORD_ALIGNED_BIT_LENGTH(CHAR_BIT * IEEE_SAVE_SIZE);
03001 TYP_LINEAR(TYP_WORK_IDX) = (ieee_save_size <= MAX_SHORT_TYPELESS_BITS) ?
03002 Short_Typeless_Const :
03003 Long_Typeless ;
03004 TYP_BIT_LEN(TYP_WORK_IDX) = ieee_save_size;
03005 ATD_TYPE_IDX(tmp_idx) = ntr_type_tbl();
03006 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03007 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
03008 AT_DEFINED(tmp_idx) = TRUE;
03009
03010
03011 int curr_stmt_sh_idx = gen_ieee_save_or_restore(Ieee_Save_Attr_Idx,
03012 IEEE_SAVE_ENTRY, tmp_idx, line, column);
03013 int entry_stmt_sh_idx = entry_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);
03014 for (; entry_stmt_sh_idx != NULL_IDX &&
03015 IR_OPR(SH_IR_IDX(entry_stmt_sh_idx)) != Entry_Opr;
03016 entry_stmt_sh_idx = SH_NEXT_IDX(entry_stmt_sh_idx))
03017 ;
03018 if (entry_stmt_sh_idx == NULL_IDX) {
03019 PRINTMSG (line, 1044, Internal, column, "No Entry_Opr");
03020 }
03021 SH_PREV_IDX(SH_NEXT_IDX(entry_stmt_sh_idx)) = curr_stmt_sh_idx;
03022 SH_NEXT_IDX(curr_stmt_sh_idx) = SH_NEXT_IDX(entry_stmt_sh_idx);
03023 SH_NEXT_IDX(entry_stmt_sh_idx) = curr_stmt_sh_idx;
03024 SH_PREV_IDX(curr_stmt_sh_idx) = entry_stmt_sh_idx;
03025
03026
03027 curr_stmt_sh_idx = gen_ieee_save_or_restore(Ieee_Restore_Attr_Idx,
03028 IEEE_RESTORE_ENTRY, tmp_idx, line, column);
03029 SH_NEXT_IDX(curr_stmt_sh_idx) = SCP_EXIT_IR_SH_IDX(curr_scp_idx);
03030 SCP_EXIT_IR_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;
03031 }
03032 #endif
03033
03034 #ifdef KEY
03035
03036
03037
03038
03039
03040 static boolean
03041 lower_bounds_match(int actual_il_idx, int dummy_idx) {
03042
03043 if (IR_Tbl_Idx != IL_FLD(actual_il_idx)) {
03044 return FALSE;
03045 }
03046 int actual_ir_idx = IL_IDX(actual_il_idx);
03047 if (IR_OPR(actual_ir_idx) != Whole_Subscript_Opr ||
03048 IR_FLD_L(actual_ir_idx) != IR_Tbl_Idx) {
03049 return FALSE;
03050 }
03051 int dv_deref_idx = IR_IDX_L(actual_ir_idx);
03052 if (IR_OPR(dv_deref_idx) != Dv_Deref_Opr ||
03053 IR_FLD_L(dv_deref_idx) != AT_Tbl_Idx) {
03054 return FALSE;
03055 }
03056 int at_idx = IR_IDX_L(dv_deref_idx);
03057 int actual_array_idx = ATD_ARRAY_IDX(at_idx);
03058
03059 int dummy_array_idx = ATD_ARRAY_IDX(dummy_idx);
03060 if (NULL_IDX == dummy_array_idx ||
03061 Assumed_Shape != BD_ARRAY_CLASS(dummy_array_idx)) {
03062 return FALSE;
03063 }
03064 for (int i = 1; i <= BD_RANK(dummy_array_idx); i++) {
03065
03066 if (BD_LB_FLD(actual_array_idx, i) != BD_LB_FLD(dummy_array_idx, i) ||
03067 BD_LB_IDX(actual_array_idx, i) != BD_LB_IDX(dummy_array_idx, i)) {
03068 return FALSE;
03069 }
03070 }
03071 return TRUE;
03072 }
03073 #endif
03074 #ifdef KEY
03075
03076
03077
03078
03079
03080
03081 static int
03082 pass_by_value(int spec_idx, int info_idx, int dummy_idx) {
03083 return ATP_VFUNCTION(spec_idx) ||
03084 arg_info_list[info_idx].ed.percent_val_arg ||
03085 (dummy_idx != NULL_IDX && ATD_VALUE_ATTR(dummy_idx));
03086 }
03087 #endif
03088
03089
03090
03091
03092
03093
03094
03095
03096
03097
03098
03099
03100
03101
03102
03103
03104
03105
03106
03107
03108
03109 boolean final_arg_work(opnd_type *list_opnd,
03110 int spec_idx,
03111 int num_args,
03112 expr_arg_type *elemental_exp_desc)
03113
03114 {
03115 act_arg_type a_type;
03116 int addr_tmp_idx;
03117 int asg_idx;
03118 int association;
03119 #ifdef KEY
03120 int attr_idx = 0;
03121 #else
03122 int attr_idx;
03123 #endif
03124 opnd_type base_opnd;
03125 long64 char_len;
03126 char *char_ptr1;
03127 char *char_ptr2;
03128 int col;
03129 dummy_arg_type d_type;
03130 int debug_count;
03131 int dummy;
03132 int dummy_idx;
03133 opnd_type dv_opnd;
03134 expr_arg_type exp_desc;
03135 boolean explicit;
03136 int false_list_idx = NULL_IDX;
03137 int false_parm_idx;
03138 int fcd_idx;
03139 int i;
03140 int info_idx;
03141 int intent;
03142 boolean io_call = FALSE;
03143 int ir_idx;
03144 long k;
03145 opnd_type len_opnd;
03146 int line;
03147 int list_idx;
03148 int list_idx2;
03149 opnd_type l_opnd;
03150 int mult_idx;
03151 boolean ok = TRUE;
03152 int old_cn_idx;
03153 opnd_type opnd;
03154 int opnd_column;
03155 int opnd_line;
03156 int present_idx;
03157 opnd_type r_opnd;
03158 int save_defer_stmt_expansion;
03159 expr_mode_type save_expr_mode;
03160 cif_usage_code_type save_xref_state;
03161 long_type the_constant;
03162 int tmp_idx;
03163 int tmp_dv_idx;
03164 int tmp_loc_idx;
03165 int unused1;
03166 int unused2;
03167 int zero_constant_idx;
03168 int false_start_sh_idx;
03169 int false_end_sh_idx;
03170 int true_start_sh_idx;
03171 int true_end_sh_idx;
03172 int true_start_sh_idx2;
03173 int true_end_sh_idx2;
03174 opnd_type cond_opnd;
03175 # ifdef KEY
03176 int dim;
03177 # endif
03178
03179
03180 TRACE (Func_Entry, "final_arg_work", NULL);
03181
03182 exp_desc = init_exp_desc;
03183
03184 save_expr_mode = expr_mode;
03185
03186 expr_mode = Regular_Expr;
03187
03188 explicit = ATP_EXPL_ITRFC(spec_idx);
03189 dummy = NULL_IDX;
03190
03191 zero_constant_idx = (SA_INTEGER_DEFAULT_TYPE == CG_INTEGER_DEFAULT_TYPE) ?
03192 CN_INTEGER_ZERO_IDX :
03193 C_INT_TO_CN(SA_INTEGER_DEFAULT_TYPE, 0);
03194
03195 if (ATP_ELEMENTAL(spec_idx)) {
03196 list_idx = OPND_IDX((*list_opnd));
03197
03198 if (ATP_EXTRA_DARG(spec_idx)) {
03199 list_idx = IL_NEXT_LIST_IDX(list_idx);
03200 }
03201 #ifdef KEY
03202 ok = check_elemental_conformance(list_idx, &exp_desc, spec_idx);
03203 #else
03204 ok = check_elemental_conformance(list_idx, &exp_desc);
03205 #endif
03206 explicit = FALSE;
03207
03208 if (elemental_exp_desc != NULL) {
03209 elemental_exp_desc->rank = exp_desc.rank;
03210 COPY_SHAPE(elemental_exp_desc->shape, exp_desc.shape, exp_desc.rank);
03211 }
03212 }
03213
03214 # ifdef _DEBUG
03215 if (explicit) {
03216
03217
03218 debug_count = 0;
03219 list_idx = OPND_IDX((*list_opnd));
03220
03221 while (list_idx != NULL_IDX) {
03222 if (! IL_INTRIN_PLACE_HOLDER(list_idx)) {
03223 debug_count++;
03224 }
03225 list_idx = IL_NEXT_LIST_IDX(list_idx);
03226 }
03227
03228 if (debug_count != ATP_NUM_DARGS(spec_idx)) {
03229 PRINTMSG(stmt_start_line, 1119, Internal, stmt_start_col,
03230 AT_OBJ_NAME_PTR(spec_idx));
03231 }
03232 }
03233 # endif
03234
03235
03236 if (spec_idx == glb_tbl_idx[Buffer_In_Attr_Idx] ||
03237 spec_idx == glb_tbl_idx[Buffer_Out_Attr_Idx] ||
03238 spec_idx == glb_tbl_idx[Close_Attr_Idx] ||
03239 spec_idx == glb_tbl_idx[Backspace_Attr_Idx] ||
03240 spec_idx == glb_tbl_idx[Rewind_Attr_Idx] ||
03241 spec_idx == glb_tbl_idx[Endfile_Attr_Idx] ||
03242 spec_idx == glb_tbl_idx[Inquire_Attr_Idx] ||
03243 spec_idx == glb_tbl_idx[Open_Attr_Idx]) {
03244
03245 io_call = TRUE;
03246 }
03247
03248 list_idx = OPND_IDX((*list_opnd));
03249
03250 if (!ATP_EXPL_ITRFC(spec_idx) &&
03251 !io_call &&
03252 !AT_COMPILER_GEND(spec_idx)) {
03253
03254
03255
03256
03257 check_call_for_global_def(list_idx, spec_idx, num_args);
03258 }
03259
03260 if (ATP_EXTRA_DARG(spec_idx)) {
03261 list_idx = IL_NEXT_LIST_IDX(list_idx);
03262 }
03263
03264 dummy_idx = 1;
03265
03266 for (i = 1; i <= num_args; i++) {
03267
03268 stmt_expansion_control_start();
03269 save_defer_stmt_expansion = defer_stmt_expansion;
03270 defer_stmt_expansion = FALSE;
03271
03272 if (IL_FLD(list_idx) == NO_Tbl_Idx &&
03273 ATP_PROC(spec_idx) == Intrin_Proc &&
03274 IL_INTRIN_PLACE_HOLDER(list_idx)) {
03275
03276
03277
03278 IL_FLD(list_idx) = CN_Tbl_Idx;
03279 IL_IDX(list_idx) = zero_constant_idx;
03280 IL_LINE_NUM(list_idx) = stmt_start_line;
03281 IL_COL_NUM(list_idx) = stmt_start_col;
03282
03283
03284
03285
03286 goto EXIT;
03287 }
03288
03289 if (explicit) {
03290 if (ATP_EXTRA_DARG(spec_idx)) {
03291 dummy = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + dummy_idx);
03292 }
03293 else {
03294 dummy = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + dummy_idx - 1);
03295 }
03296 }
03297
03298 if (IL_FLD(list_idx) == NO_Tbl_Idx) {
03299
03300
03301
03302 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03303 if (explicit &&
03304 ! io_call &&
03305 (AT_OBJ_CLASS(dummy) == Data_Obj &&
03306 ! ATD_IM_A_DOPE(dummy) &&
03307 (ATP_PROC(spec_idx) == Intrin_Proc ?
03308 (((1 << Character_1) & ATD_INTRIN_DARG_TYPE(dummy)) != 0) :
03309 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character)))
03310 # else
03311 if (explicit &&
03312 ! io_call &&
03313 ((AT_OBJ_CLASS(dummy) == Data_Obj &&
03314 ! ATD_IM_A_DOPE(dummy) &&
03315 (ATP_PROC(spec_idx) == Intrin_Proc ?
03316 (((1 << Character_1) & ATD_INTRIN_DARG_TYPE(dummy)) != 0) :
03317 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character)) ||
03318 (AT_OBJ_CLASS(dummy) == Pgm_Unit &&
03319 ATP_PGM_UNIT(dummy) == Function &&
03320 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(dummy))) == Character)))
03321 # endif
03322 {
03323
03324
03325
03326 NTR_IR_TBL(fcd_idx);
03327 IR_OPR(fcd_idx) = Fcd_Opr;
03328 IR_TYPE_IDX(fcd_idx) = CRI_Ch_Ptr_8;
03329 IR_LINE_NUM(fcd_idx) = stmt_start_line;
03330 IR_COL_NUM(fcd_idx) = stmt_start_col;
03331
03332 NTR_IR_LIST_TBL(list_idx2);
03333 IR_FLD_L(fcd_idx) = IL_Tbl_Idx;
03334 IR_IDX_L(fcd_idx) = list_idx2;
03335 IR_LIST_CNT_L(fcd_idx) = 2;
03336
03337
03338 IL_FLD(list_idx2) = CN_Tbl_Idx;
03339 IL_IDX(list_idx2) = zero_constant_idx;
03340 IL_LINE_NUM(list_idx2) = stmt_start_line;
03341 IL_COL_NUM(list_idx2) = stmt_start_col;
03342
03343 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
03344 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
03345 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
03346
03347 IL_FLD(list_idx2) = CN_Tbl_Idx;
03348 IL_IDX(list_idx2) = zero_constant_idx;
03349 IL_LINE_NUM(list_idx2) = stmt_start_line;
03350 IL_COL_NUM(list_idx2) = stmt_start_col;
03351
03352 IL_FLD(list_idx) = IR_Tbl_Idx;
03353 IL_IDX(list_idx) = fcd_idx;
03354
03355 }
03356 else {
03357 #if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03358 NTR_IR_TBL(fcd_idx);
03359 IR_OPR(fcd_idx) = Aloc_Opr;
03360 IR_TYPE_IDX(fcd_idx) = CRI_Ptr_8;
03361 IR_LINE_NUM(fcd_idx) = stmt_start_line;
03362 IR_COL_NUM(fcd_idx) = stmt_start_col;
03363
03364 IR_FLD_L(fcd_idx) = CN_Tbl_Idx;
03365 IR_IDX_L(fcd_idx) = zero_constant_idx;
03366 IR_LINE_NUM_L(fcd_idx) = stmt_start_line;
03367 IR_COL_NUM_L(fcd_idx) = stmt_start_col;
03368
03369 IL_FLD(list_idx) = IR_Tbl_Idx;
03370 IL_IDX(list_idx) = fcd_idx;
03371 #else
03372 IL_FLD(list_idx) = CN_Tbl_Idx;
03373 IL_IDX(list_idx) = zero_constant_idx;
03374 IL_LINE_NUM(list_idx) = stmt_start_line;
03375 IL_COL_NUM(list_idx) = stmt_start_col;
03376 #endif
03377 }
03378
03379 dummy_idx++;
03380 goto EXIT;
03381 }
03382
03383 info_idx = IL_ARG_DESC_IDX(list_idx);
03384
03385 # ifdef _DEBUG
03386 if (info_idx == NULL_IDX) {
03387 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
03388 "valid info_idx", "final_arg_work");
03389 }
03390 # endif
03391
03392 COPY_OPND(opnd, IL_OPND(list_idx));
03393 check_for_constructors(&opnd,
03394 (info_idx != NULL_IDX ? &(arg_info_list[info_idx].ed):
03395 NULL));
03396 COPY_OPND(IL_OPND(list_idx), opnd);
03397
03398 if (OPND_FLD(opnd) == AT_Tbl_Idx ||
03399 (OPND_FLD(opnd) == IR_Tbl_Idx &&
03400 (IR_OPR(OPND_IDX(opnd)) == Subscript_Opr ||
03401 IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr ||
03402 IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr ||
03403 IR_OPR(OPND_IDX(opnd)) == Substring_Opr ||
03404 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr ||
03405 IR_OPR(OPND_IDX(opnd)) == Struct_Opr ||
03406 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr))) {
03407
03408 attr_idx = find_left_attr(&opnd);
03409
03410 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
03411 ATD_CLASS(attr_idx) == Compiler_Tmp) {
03412 arg_info_list[info_idx].ed.tmp_reference = TRUE;
03413 arg_info_list[info_idx].ed.reference = FALSE;
03414 }
03415 else if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
03416 arg_info_list[info_idx].ed.reference = TRUE;
03417 arg_info_list[info_idx].ed.tmp_reference = FALSE;
03418 }
03419 }
03420
03421 if (arg_info_list[info_idx].ed.label) {
03422
03423 if (stmt_type == Call_Stmt) {
03424
03425
03426 IL_FLD(list_idx) = CN_Tbl_Idx;
03427 IL_IDX(list_idx) = zero_constant_idx;
03428 IL_LINE_NUM(list_idx) = stmt_start_line;
03429 IL_COL_NUM(list_idx) = stmt_start_col;
03430 }
03431 else {
03432
03433
03434 IL_FLD(list_idx) = CN_Tbl_Idx;
03435 IL_IDX(list_idx) = CN_INTEGER_NEG_ONE_IDX;
03436 IL_LINE_NUM(list_idx) = stmt_start_line;
03437 IL_COL_NUM(list_idx) = stmt_start_col;
03438 }
03439
03440 dummy_idx++;
03441 goto EXIT;
03442 }
03443
03444 if (arg_info_list[info_idx].pgm_unit) {
03445 set_at_actual_arg(list_idx);
03446
03447 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03448 &opnd_line,
03449 &opnd_column);
03450
03451 if (IL_FLD(list_idx) == AT_Tbl_Idx &&
03452 !AT_IS_INTRIN(IL_IDX(list_idx)) &&
03453 AT_OBJ_CLASS(IL_IDX(list_idx)) == Pgm_Unit &&
03454 ATP_ELEMENTAL(IL_IDX(list_idx))) {
03455 PRINTMSG(opnd_line, 1639, Error,
03456 opnd_column,
03457 AT_OBJ_NAME_PTR(IL_IDX(list_idx)));
03458
03459 ok = FALSE;
03460 }
03461
03462
03463 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03464 NTR_IR_TBL(ir_idx);
03465 IR_OPR(ir_idx) = Aloc_Opr;
03466 IR_TYPE_IDX(ir_idx) = CRI_Parcel_Ptr_8;
03467 IR_LINE_NUM(ir_idx) = opnd_line;
03468 IR_COL_NUM(ir_idx) = opnd_column;
03469 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
03470 IL_FLD(list_idx) = IR_Tbl_Idx;
03471 IL_IDX(list_idx) = ir_idx;
03472 # else
03473 if (arg_info_list[info_idx].ed.type == Character) {
03474
03475 NTR_IR_TBL(fcd_idx);
03476 IR_OPR(fcd_idx) = Fcd_Opr;
03477 IR_TYPE_IDX(fcd_idx) = CRI_Ch_Ptr_8;
03478 IR_LINE_NUM(fcd_idx) = opnd_line;
03479 IR_COL_NUM(fcd_idx) = opnd_column;
03480
03481 NTR_IR_LIST_TBL(list_idx2);
03482 IR_FLD_L(fcd_idx) = IL_Tbl_Idx;
03483 IR_IDX_L(fcd_idx) = list_idx2;
03484 IR_LIST_CNT_L(fcd_idx) = 2;
03485
03486
03487 NTR_IR_TBL(ir_idx);
03488 IR_OPR(ir_idx) = Aloc_Opr;
03489 IR_TYPE_IDX(ir_idx) = CRI_Parcel_Ptr_8;
03490 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
03491 IR_LINE_NUM(ir_idx) = opnd_line;
03492 IR_COL_NUM(ir_idx) = opnd_column;
03493 IL_FLD(list_idx2) = IR_Tbl_Idx;
03494 IL_IDX(list_idx2) = ir_idx;
03495
03496 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
03497 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
03498 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
03499
03500 IL_FLD(list_idx2) = TYP_FLD(arg_info_list[info_idx].ed.type_idx);
03501 IL_IDX(list_idx2) = TYP_IDX(arg_info_list[info_idx].ed.type_idx);
03502 IL_LINE_NUM(list_idx2) = opnd_line;
03503 IL_COL_NUM(list_idx2) = opnd_column;
03504
03505 IL_FLD(list_idx) = IR_Tbl_Idx;
03506 IL_IDX(list_idx) = fcd_idx;
03507 }
03508 else {
03509 NTR_IR_TBL(ir_idx);
03510 IR_OPR(ir_idx) = Aloc_Opr;
03511 IR_TYPE_IDX(ir_idx) = CRI_Parcel_Ptr_8;
03512 IR_LINE_NUM(ir_idx) = opnd_line;
03513 IR_COL_NUM(ir_idx) = opnd_column;
03514 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
03515 IL_FLD(list_idx) = IR_Tbl_Idx;
03516 IL_IDX(list_idx) = ir_idx;
03517 }
03518 # endif
03519
03520 dummy_idx++;
03521 goto EXIT;
03522 }
03523
03524 if (explicit) {
03525
03526
03527 if (
03528 #ifdef KEY
03529
03530 (ATD_ALLOCATABLE(dummy) &&
03531 ! arg_info_list[info_idx].ed.allocatable) ||
03532 #endif
03533 (ATD_POINTER(dummy) &&
03534 ! arg_info_list[info_idx].ed.pointer)) {
03535
03536
03537
03538 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03539 &opnd_line,
03540 &opnd_column);
03541 PRINTMSG(opnd_line, 256, Error,
03542 opnd_column,
03543 AT_OBJ_NAME_PTR(dummy));
03544
03545 ok = FALSE;
03546 }
03547
03548
03549 # if 0
03550
03551
03552
03553
03554 if (ATD_TARGET(dummy) &&
03555 ((! arg_info_list[info_idx].ed.target &&
03556 ! arg_info_list[info_idx].ed.pointer) ||
03557 arg_info_list[info_idx].ed.vector_subscript)) {
03558 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03559 &opnd_line,
03560 &opnd_column);
03561
03562 PRINTMSG(opnd_line, 622, Error,
03563 opnd_column,
03564 AT_OBJ_NAME_PTR(dummy));
03565
03566 ok = FALSE;
03567 }
03568 # endif
03569
03570 if (arg_info_list[info_idx].ed.assumed_size &&
03571 ATD_ARRAY_IDX(dummy) &&
03572 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Assumed_Shape) {
03573
03574
03575
03576 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03577 &opnd_line,
03578 &opnd_column);
03579
03580 PRINTMSG(opnd_line, 258, Error, opnd_column);
03581
03582 ok = FALSE;
03583 }
03584
03585
03586
03587
03588 if (ATD_INTENT(dummy) == Intent_Out ||
03589 ATD_INTENT(dummy) == Intent_Inout) {
03590
03591 if (arg_info_list[info_idx].ed.vector_subscript ||
03592 ! arg_info_list[info_idx].ed.reference) {
03593 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03594 &opnd_line,
03595 &opnd_column);
03596
03597 PRINTMSG(opnd_line, 786, Error, opnd_column);
03598 ok = FALSE;
03599 }
03600 else {
03601 COPY_OPND(opnd, IL_OPND(list_idx));
03602 attr_idx = find_left_attr(&opnd);
03603
03604 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
03605 ATD_CLASS(attr_idx) == Dummy_Argument &&
03606 ATD_INTENT(attr_idx) == Intent_In) {
03607
03608 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03609 &opnd_line,
03610 &opnd_column);
03611 PRINTMSG(opnd_line, 786, Error, opnd_column);
03612
03613 ok = FALSE;
03614 }
03615 }
03616 }
03617
03618 #ifdef KEY
03619 if (ATD_VOLATILE(dummy)) {
03620 boolean constraint_error = FALSE;
03621
03622 if (arg_info_list[info_idx].ed.vector_subscript) {
03623 constraint_error = TRUE;
03624 }
03625
03626 else if (arg_info_list[info_idx].ed.pointer) {
03627 if (!(BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Assumed_Shape ||
03628 ATD_POINTER(dummy))) {
03629 constraint_error = TRUE;
03630 }
03631 }
03632
03633 else if (arg_info_list[info_idx].ed.section ||
03634 arg_info_list[info_idx].ed.assumed_shape) {
03635 if (!(ATD_ARRAY_IDX(dummy) &&
03636 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Assumed_Shape)) {
03637 constraint_error = TRUE;
03638 }
03639 }
03640 if (constraint_error) {
03641 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03642 &opnd_line, &opnd_column);
03643 PRINTMSG(opnd_line, 1688, Error, opnd_column,
03644 AT_OBJ_NAME_PTR(dummy));
03645 }
03646 }
03647 #endif
03648
03649 if (arg_info_list[info_idx].ed.type == Character &&
03650 ATP_PROC(spec_idx) != Intrin_Proc &&
03651 AT_OBJ_CLASS(dummy) == Data_Obj &&
03652 ATD_ARRAY_IDX(dummy) == NULL_IDX &&
03653 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character) {
03654
03655 if (TYP_FLD(arg_info_list[info_idx].ed.type_idx) == CN_Tbl_Idx &&
03656 TYP_FLD(ATD_TYPE_IDX(dummy)) == CN_Tbl_Idx &&
03657 fold_relationals(TYP_IDX(arg_info_list[info_idx].ed.type_idx),
03658 TYP_IDX(ATD_TYPE_IDX(dummy)),
03659 Lt_Opr)) {
03660
03661 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03662 &opnd_line,
03663 &opnd_column);
03664
03665 PRINTMSG(opnd_line, 1205, Error, opnd_column,
03666 AT_OBJ_NAME_PTR(dummy));
03667 ok = FALSE;
03668 }
03669 }
03670
03671
03672
03673 if (TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character &&
03674 TYP_FLD(ATD_TYPE_IDX(dummy)) == CN_Tbl_Idx &&
03675 ATD_ARRAY_IDX(dummy) != NULL_IDX &&
03676 BD_LEN_FLD(ATD_ARRAY_IDX(dummy)) == CN_Tbl_Idx &&
03677 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Explicit_Shape &&
03678 arg_info_list[info_idx].ed.rank != 0) {
03679
03680 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03681 &opnd_line,
03682 &opnd_column);
03683
03684 COPY_OPND(opnd, IL_OPND(list_idx));
03685 exp_desc = arg_info_list[info_idx].ed;
03686 ok &= validate_char_len(&opnd, &exp_desc);
03687 arg_info_list[info_idx].ed = exp_desc;
03688
03689 OPND_FLD(len_opnd) = TYP_FLD(exp_desc.type_idx);
03690 OPND_IDX(len_opnd) = TYP_IDX(exp_desc.type_idx);
03691
03692 for (k = 0; k < arg_info_list[info_idx].ed.rank; k++) {
03693 NTR_IR_TBL(mult_idx);
03694 IR_OPR(mult_idx) = Mult_Opr;
03695 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
03696 IR_LINE_NUM(mult_idx) = opnd_line;
03697 IR_COL_NUM(mult_idx) = opnd_column;
03698
03699 COPY_OPND(IR_OPND_L(mult_idx), len_opnd);
03700
03701 COPY_OPND(IR_OPND_R(mult_idx),
03702 arg_info_list[info_idx].ed.shape[k]);
03703
03704 OPND_FLD(len_opnd) = IR_Tbl_Idx;
03705 OPND_IDX(len_opnd) = mult_idx;
03706 }
03707
03708 NTR_IR_TBL(mult_idx);
03709 IR_OPR(mult_idx) = Mult_Opr;
03710 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
03711 IR_LINE_NUM(mult_idx) = opnd_line;
03712 IR_COL_NUM(mult_idx) = opnd_column;
03713
03714 IR_FLD_L(mult_idx) = BD_LEN_FLD(ATD_ARRAY_IDX(dummy));
03715 IR_IDX_L(mult_idx) = BD_LEN_IDX(ATD_ARRAY_IDX(dummy));
03716 IR_LINE_NUM_L(mult_idx) = opnd_line;
03717 IR_COL_NUM_L(mult_idx) = opnd_column;
03718
03719 IR_FLD_R(mult_idx) = TYP_FLD(ATD_TYPE_IDX(dummy));
03720 IR_IDX_R(mult_idx) = TYP_IDX(ATD_TYPE_IDX(dummy));
03721 IR_LINE_NUM_R(mult_idx) = opnd_line;
03722 IR_COL_NUM_R(mult_idx) = opnd_column;
03723
03724 NTR_IR_TBL(ir_idx);
03725 IR_OPR(ir_idx) = Gt_Opr;
03726 IR_TYPE_IDX(ir_idx) = CG_LOGICAL_DEFAULT_TYPE;
03727 IR_LINE_NUM(ir_idx) = opnd_line;
03728 IR_COL_NUM(ir_idx) = opnd_column;
03729
03730 IR_FLD_L(ir_idx) = IR_Tbl_Idx;
03731 IR_IDX_L(ir_idx) = mult_idx;
03732 IR_LINE_NUM_L(ir_idx) = opnd_line;
03733 IR_COL_NUM_L(ir_idx) = opnd_column;
03734
03735 COPY_OPND(IR_OPND_R(ir_idx), len_opnd);
03736
03737 OPND_FLD(len_opnd) = IR_Tbl_Idx;
03738 OPND_IDX(len_opnd) = ir_idx;
03739
03740 save_xref_state = xref_state;
03741 xref_state = CIF_No_Usage_Rec;
03742 save_expr_mode = expr_mode;
03743 expr_mode = Regular_Expr;
03744
03745 exp_desc.rank = 0;
03746 ok = expr_semantics(&len_opnd, &exp_desc);
03747 xref_state = save_xref_state;
03748 expr_mode = save_expr_mode;
03749
03750 if (OPND_FLD(len_opnd) == CN_Tbl_Idx &&
03751 THIS_IS_TRUE((&CN_CONST(OPND_IDX(len_opnd))),
03752 exp_desc.type_idx)) {
03753
03754 PRINTMSG(opnd_line, 1500, Error, opnd_column);
03755 ok = FALSE;
03756 }
03757 }
03758 else if (ATD_ARRAY_IDX(dummy) != NULL_IDX &&
03759 BD_LEN_FLD(ATD_ARRAY_IDX(dummy)) == CN_Tbl_Idx &&
03760 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Explicit_Shape &&
03761 arg_info_list[info_idx].ed.rank != 0) {
03762
03763 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03764 &opnd_line,
03765 &opnd_column);
03766
03767 COPY_OPND(len_opnd, arg_info_list[info_idx].ed.shape[0]);
03768
03769 for (k = 1; k < arg_info_list[info_idx].ed.rank; k++) {
03770 NTR_IR_TBL(mult_idx);
03771 IR_OPR(mult_idx) = Mult_Opr;
03772 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
03773 IR_LINE_NUM(mult_idx) = opnd_line;
03774 IR_COL_NUM(mult_idx) = opnd_column;
03775
03776 COPY_OPND(IR_OPND_L(mult_idx), len_opnd);
03777
03778 COPY_OPND(IR_OPND_R(mult_idx),
03779 arg_info_list[info_idx].ed.shape[k]);
03780
03781 OPND_FLD(len_opnd) = IR_Tbl_Idx;
03782 OPND_IDX(len_opnd) = mult_idx;
03783 }
03784
03785 save_xref_state = xref_state;
03786 xref_state = CIF_No_Usage_Rec;
03787 save_expr_mode = expr_mode;
03788 expr_mode = Regular_Expr;
03789
03790 exp_desc.rank = 0;
03791 ok = expr_semantics(&len_opnd, &exp_desc);
03792 xref_state = save_xref_state;
03793 expr_mode = save_expr_mode;
03794
03795 if (OPND_FLD(len_opnd) == CN_Tbl_Idx &&
03796 fold_relationals(BD_LEN_IDX(ATD_ARRAY_IDX(dummy)),
03797 OPND_IDX(len_opnd),
03798 Gt_Opr)) {
03799 PRINTMSG(opnd_line, 1500, Error, opnd_column);
03800 ok = FALSE;
03801 }
03802 }
03803 }
03804
03805 if (explicit &&
03806 arg_info_list[info_idx].ed.linear_type == Short_Typeless_Const &&
03807 (TYP_TYPE(ATD_TYPE_IDX(dummy)) == Integer ||
03808 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Real ||
03809 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Complex)) {
03810
03811 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
03812 ATD_TYPE_IDX(dummy),
03813 arg_info_list[info_idx].line,
03814 arg_info_list[info_idx].col);
03815
03816 arg_info_list[info_idx].ed.type_idx = ATD_TYPE_IDX(dummy);
03817 arg_info_list[info_idx].ed.type = TYP_TYPE(ATD_TYPE_IDX(dummy));
03818 arg_info_list[info_idx].ed.linear_type =
03819 TYP_LINEAR(ATD_TYPE_IDX(dummy));
03820 }
03821 else if (explicit &&
03822 arg_info_list[info_idx].ed.linear_type ==
03823 Short_Typeless_Const &&
03824 (CN_HOLLERITH_TYPE(IL_IDX(list_idx)) == H_Hollerith ||
03825 CN_HOLLERITH_TYPE(IL_IDX(list_idx)) == L_Hollerith) &&
03826 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character) {
03827
03828 old_cn_idx = IL_IDX(list_idx);
03829
03830 char_len = strlen((char *)&CN_CONST(IL_IDX(list_idx)));
03831
03832 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
03833
03834 TYP_TYPE(TYP_WORK_IDX) = Character;
03835 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
03836 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
03837 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx;
03838 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(NULL_IDX,
03839 char_len);
03840 arg_info_list[info_idx].ed.type_idx = ntr_type_tbl();
03841 arg_info_list[info_idx].ed.type = Character;
03842 arg_info_list[info_idx].ed.linear_type = Short_Char_Const;
03843 arg_info_list[info_idx].ed.char_len.fld =
03844 TYP_FLD(arg_info_list[info_idx].ed.type_idx);
03845 arg_info_list[info_idx].ed.char_len.idx =
03846 TYP_IDX(arg_info_list[info_idx].ed.type_idx);
03847
03848
03849
03850
03851 IL_IDX(list_idx) = ntr_const_tbl(arg_info_list[info_idx].ed.type_idx,
03852 TRUE,
03853 NULL);
03854
03855 for (k = 0; k < TARGET_BYTES_TO_WORDS(char_len); k++) {
03856 CP_CONSTANT(CN_POOL_IDX(IL_IDX(list_idx)) + k) =
03857 CP_CONSTANT(CN_POOL_IDX(old_cn_idx) + k);
03858 }
03859 }
03860 else if (! explicit &&
03861 arg_info_list[info_idx].ed.linear_type == Short_Typeless_Const &&
03862 CN_HOLLERITH_TYPE(IL_IDX(list_idx)) == Not_Hollerith) {
03863
03864 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
03865 INTEGER_DEFAULT_TYPE,
03866 arg_info_list[info_idx].line,
03867 arg_info_list[info_idx].col);
03868
03869 arg_info_list[info_idx].ed.type_idx = INTEGER_DEFAULT_TYPE;
03870 arg_info_list[info_idx].ed.type = TYP_TYPE(INTEGER_DEFAULT_TYPE);
03871 arg_info_list[info_idx].ed.linear_type =
03872 TYP_LINEAR(INTEGER_DEFAULT_TYPE);
03873 }
03874
03875
03876 if (arg_info_list[info_idx].ed.reference &&
03877 ! arg_info_list[info_idx].ed.vector_subscript &&
03878 arg_info_list[info_idx].maybe_modified) {
03879
03880 set_at_actual_arg(list_idx);
03881 }
03882
03883
03884 d_type = get_dummy_arg_type(dummy);
03885
03886 if (dummy != NULL_IDX &&
03887 AT_OBJ_CLASS(dummy) == Data_Obj &&
03888 #ifdef KEY
03889
03890
03891
03892 (!ATD_POINTER(dummy)) &&
03893 #endif
03894 ATD_IGNORE_TKR(dummy)) {
03895
03896 d_type = Unknown_Dummy;
03897 }
03898
03899 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
03900 IR_OPR(IL_IDX(list_idx)) == Null_Intrinsic_Opr) {
03901
03902 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03903 &opnd_line,
03904 &opnd_column);
03905
03906 if (dummy != NULL_IDX &&
03907 AT_OBJ_CLASS(dummy) == Data_Obj) {
03908 tmp_dv_idx = gen_compiler_tmp(opnd_line,
03909 opnd_column,
03910 Priv,
03911 TRUE);
03912 ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(dummy);
03913 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03914 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE;
03915 ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(dummy);
03916 ATD_POINTER(tmp_dv_idx) = TRUE;
03917 ATD_IM_A_DOPE(tmp_dv_idx) = TRUE;
03918
03919 gen_opnd(&dv_opnd,
03920 tmp_dv_idx,
03921 AT_Tbl_Idx,
03922 opnd_line,
03923 opnd_column);
03924 gen_dv_whole_def_init(&dv_opnd,
03925 tmp_dv_idx,
03926 Before);
03927
03928 if (ATD_ARRAY_IDX(dummy) == NULL_IDX) {
03929 arg_info_list[info_idx].ed.rank = 0;
03930 }
03931 else {
03932 arg_info_list[info_idx].ed.rank = BD_RANK(ATD_ARRAY_IDX(dummy));
03933 }
03934 arg_info_list[info_idx].ed.type_idx = ATD_TYPE_IDX(dummy);
03935 arg_info_list[info_idx].ed.type = TYP_TYPE(ATD_TYPE_IDX(dummy));
03936 arg_info_list[info_idx].ed.linear_type =
03937 TYP_LINEAR(ATD_TYPE_IDX(dummy));
03938 arg_info_list[info_idx].ed.pointer = TRUE;
03939 arg_info_list[info_idx].ed.tmp_reference = TRUE;
03940
03941 gen_opnd(&dv_opnd,
03942 gen_ir(AT_Tbl_Idx,
03943 tmp_dv_idx,
03944 Dv_Deref_Opr,
03945 arg_info_list[info_idx].ed.type_idx,
03946 opnd_line,
03947 opnd_column,
03948 NO_Tbl_Idx,
03949 NULL_IDX),
03950 IR_Tbl_Idx,
03951 opnd_line,
03952 opnd_column);
03953
03954 if (arg_info_list[info_idx].ed.rank > 0) {
03955 ok = gen_whole_subscript(&dv_opnd, &arg_info_list[info_idx].ed);
03956 }
03957
03958 IL_IDX(list_idx) = OPND_IDX(dv_opnd);
03959 IL_FLD(list_idx) = OPND_FLD(dv_opnd);
03960 }
03961 else {
03962 tmp_dv_idx = gen_compiler_tmp(opnd_line,
03963 opnd_column,
03964 Priv,
03965 TRUE);
03966 ATD_TYPE_IDX(tmp_dv_idx) = TYPELESS_DEFAULT_TYPE;
03967 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03968 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE;
03969 ATD_ARRAY_IDX(tmp_dv_idx) = NULL_IDX;
03970 ATD_POINTER(tmp_dv_idx) = TRUE;
03971 ATD_IM_A_DOPE(tmp_dv_idx) = TRUE;
03972
03973 gen_opnd(&dv_opnd,
03974 tmp_dv_idx,
03975 AT_Tbl_Idx,
03976 opnd_line,
03977 opnd_column);
03978 gen_dv_whole_def_init(&dv_opnd,
03979 tmp_dv_idx,
03980 Before);
03981
03982 arg_info_list[info_idx].ed.rank = 0;
03983 arg_info_list[info_idx].ed.type_idx = TYPELESS_DEFAULT_TYPE;
03984 arg_info_list[info_idx].ed.linear_type =
03985 TYP_LINEAR(TYPELESS_DEFAULT_TYPE);
03986 arg_info_list[info_idx].ed.pointer = TRUE;
03987 arg_info_list[info_idx].ed.tmp_reference = TRUE;
03988
03989 gen_opnd(&dv_opnd,
03990 gen_ir(AT_Tbl_Idx,
03991 tmp_dv_idx,
03992 Dv_Deref_Opr,
03993 arg_info_list[info_idx].ed.type_idx,
03994 opnd_line,
03995 opnd_column,
03996 NO_Tbl_Idx,
03997 NULL_IDX),
03998 IR_Tbl_Idx,
03999 opnd_line,
04000 opnd_column);
04001
04002 if (arg_info_list[info_idx].ed.rank > 0) {
04003 ok = gen_whole_subscript(&dv_opnd, &arg_info_list[info_idx].ed);
04004 }
04005
04006 IL_IDX(list_idx) = OPND_IDX(dv_opnd);
04007 IL_FLD(list_idx) = OPND_FLD(dv_opnd);
04008 }
04009 }
04010
04011 a_type = get_act_arg_type(&arg_info_list[info_idx].ed);
04012
04013 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
04014 &line,
04015 &col);
04016
04017
04018 if (! AT_IS_INTRIN(spec_idx) &&
04019 dummy != NULL_IDX &&
04020 AT_OBJ_CLASS(dummy) == Data_Obj) {
04021
04022
04023
04024 if (ATD_AUXILIARY(dummy)) {
04025
04026 if (arg_assoc_tbl[a_type][d_type] != PASS_ADDRESS) {
04027 PRINTMSG(line, 627, Warning, col,
04028 AT_OBJ_NAME_PTR(dummy));
04029 }
04030 else {
04031
04032 COPY_OPND(opnd, IL_OPND(list_idx));
04033 attr_idx = find_left_attr(&opnd);
04034
04035 if (! ATD_AUXILIARY(attr_idx)) {
04036 PRINTMSG(line, 627, Warning, col,
04037 AT_OBJ_NAME_PTR(dummy));
04038 }
04039 }
04040 }
04041 else if (arg_assoc_tbl[a_type][d_type] == PASS_ADDRESS) {
04042 COPY_OPND(opnd, IL_OPND(list_idx));
04043 attr_idx = find_left_attr(&opnd);
04044
04045 if (ATD_AUXILIARY(attr_idx)) {
04046 PRINTMSG(line, 620, Warning, col,
04047 AT_OBJ_NAME_PTR(dummy));
04048 }
04049 }
04050 }
04051
04052 association = arg_assoc_tbl[a_type][d_type];
04053
04054 if (association == PASS_ADDRESS_FROM_DV &&
04055 # ifdef _TRANSFORM_CHAR_SEQUENCE
04056 (arg_info_list[info_idx].ed.type == Character ||
04057 (arg_info_list[info_idx].ed.type == Structure &&
04058 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx)))))
04059 # else
04060 arg_info_list[info_idx].ed.type == Character)
04061 # endif
04062 {
04063
04064 association = PASS_ADDRESS;
04065 }
04066 else if (association == PASS_ADDRESS &&
04067 IL_FLD(list_idx) == AT_Tbl_Idx &&
04068 AT_OBJ_CLASS(IL_IDX(list_idx)) == Data_Obj &&
04069 ATD_LIVE_DO_VAR(IL_IDX(list_idx))) {
04070
04071
04072 association = COPY_IN;
04073 }
04074 #ifdef KEY
04075
04076
04077
04078
04079
04080
04081
04082
04083
04084 else if (explicit && NULL_IDX != dummy && ATD_ALLOCATABLE(dummy)) {
04085 association = arg_info_list[info_idx].ed.allocatable ?
04086 PASS_DV :
04087 ERROR_ASSOC;
04088 }
04089 #endif
04090 #ifdef KEY
04091
04092
04093
04094 else if (association == PASS_DV_COPY &&
04095 lower_bounds_match(list_idx, dummy)) {
04096
04097
04098
04099
04100
04101
04102 if (! (FUNCTION_MUST_BE_SUBROUTINE(spec_idx, ATP_RSLT_IDX(spec_idx)) ||
04103 ATP_ELEMENTAL(spec_idx))) {
04104 association = PASS_DV;
04105 }
04106 }
04107 #endif
04108
04109 if (arg_info_list[info_idx].ed.rank > 0 &&
04110 ATP_ELEMENTAL(spec_idx)) {
04111
04112 if (association == PASS_ADDRESS_FROM_DV ||
04113 association == CHECK_CONTIG_FLAG ||
04114 association == COPY_IN_COPY_OUT ||
04115 association == PASS_SECTION_ADDRESS) {
04116
04117 association = PASS_ADDRESS;
04118 }
04119 }
04120
04121 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04122 if (association == CHECK_CONTIG_FLAG &&
04123 arg_info_list[info_idx].ed.type == Character) {
04124
04125 association = COPY_IN_COPY_OUT;
04126 }
04127 # endif
04128
04129 # if defined(_F_MINUS_MINUS)
04130 if (dummy != NULL_IDX &&
04131 AT_OBJ_CLASS(dummy) == Data_Obj &&
04132 ATD_PE_ARRAY_IDX(dummy) != NULL_IDX) {
04133
04134 if (arg_info_list[info_idx].ed.reference) {
04135 attr_idx = find_left_attr(&IL_OPND(list_idx));
04136
04137 if (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
04138 ATD_PE_ARRAY_IDX(attr_idx) == NULL_IDX) {
04139
04140 PRINTMSG(line, 1584, Error, col);
04141 }
04142 }
04143 else {
04144 PRINTMSG(line, 1584, Error, col);
04145 }
04146 }
04147 # endif
04148
04149 # if defined(KEY)
04150 char dim[MAX_DIMENSION];
04151 bzero(dim, sizeof(dim));
04152
04153
04154 if (LANG_Copy_Inout &&
04155 (a_type == Dv_Array_Section ||
04156 a_type == Sequence_Array_Section) &&
04157 d_type == Assumed_Shape_Dummy &&
04158 !ATD_ALLOCATABLE(attr_idx) &&
04159 !ATD_POINTER(attr_idx) &&
04160 arg_info_list[info_idx].ed.rank > 0 &&
04161 stride_access_greater_than_1(&opnd, dim) &&
04162 ((LANG_Copy_Inout_Level > 0) ||
04163 inside_loop(SH_PREV_IDX(curr_stmt_sh_idx)))){
04164 association = COPY_INOUT_MAKE_DV;
04165 }
04166 # endif
04167 arg_info_list[info_idx].association = association;
04168
04169 #ifdef KEY
04170 if (stop_recursion) {
04171 association = ERROR_ASSOC;
04172 }
04173 #endif
04174 #ifdef KEY
04175
04176 if (arg_info_list[info_idx].ed.constant &&
04177 arg_info_list[info_idx].ed.pointer) {
04178 switch (association) {
04179 case ERROR_ASSOC:
04180 case PASS_DV:
04181 case PASS_DV_COPY:
04182 break;
04183 default: {
04184 int line_tmp, col_tmp;
04185 find_opnd_line_and_column(&IL_OPND(list_idx), &line_tmp, &col_tmp);
04186 PRINTMSG(line_tmp, 1677, Error, col_tmp);
04187 }
04188 }
04189 }
04190 #endif
04191 switch (association) {
04192 case ERROR_ASSOC :
04193 break;
04194
04195 case PASS_ADDRESS :
04196 #ifdef _DEBUG
04197 pass_address_count += 1;
04198 #endif
04199
04200 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04201 #ifdef KEY
04202 if (clear_pt_unique_mem(dummy)) {
04203 #endif
04204 ATD_NOT_PT_UNIQUE_MEM(
04205 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
04206 #ifdef KEY
04207 }
04208 #endif
04209 # endif
04210
04211 if (!pass_by_value(spec_idx, info_idx, dummy)) {
04212
04213
04214
04215 if (arg_info_list[info_idx].ed.rank != 0 &&
04216 ! ATP_ELEMENTAL(spec_idx)) {
04217
04218 # ifndef _FRONTEND_INLINER
04219 if (IL_FLD(list_idx) == IR_Tbl_Idx) {
04220
04221 ir_idx = IL_IDX(list_idx);
04222
04223 if (IR_OPR(ir_idx) == Whole_Subscript_Opr) {
04224 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(ir_idx));
04225 }
04226 }
04227 # endif
04228
04229 if ((IL_FLD(list_idx) == AT_Tbl_Idx &&
04230 BD_ARRAY_CLASS(ATD_ARRAY_IDX(IL_IDX(list_idx))) ==
04231 Assumed_Size) ||
04232 (arg_info_list[info_idx].ed.type == Character &&
04233 IR_FLD_L(IL_IDX(list_idx)) == AT_Tbl_Idx &&
04234 BD_ARRAY_CLASS(ATD_ARRAY_IDX(IR_IDX_L(
04235 IL_IDX(list_idx)))) == Assumed_Size)) {
04236
04237 if (arg_info_list[info_idx].ed.type == Character) {
04238 COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx)));
04239 make_base_assumed_size(&opnd, &base_opnd);
04240 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), base_opnd);
04241 }
04242 else {
04243 COPY_OPND(opnd, IL_OPND(list_idx));
04244 make_base_assumed_size(&opnd, &base_opnd);
04245 COPY_OPND(IL_OPND(list_idx), base_opnd);
04246 }
04247
04248 if (a_type == Whole_Sequence ||
04249 a_type == Whole_Allocatable) {
04250
04251 if (OPND_FLD(base_opnd) == IR_Tbl_Idx &&
04252 IR_OPR(OPND_IDX(base_opnd)) == Subscript_Opr) {
04253 IR_WHOLE_ARRAY(OPND_IDX(base_opnd)) = TRUE;
04254 }
04255 }
04256 }
04257 else {
04258
04259 if (a_type == Whole_Sequence ||
04260 a_type == Whole_Allocatable) {
04261
04262 COPY_OPND(opnd, IL_OPND(list_idx));
04263
04264 while (OPND_FLD(opnd) == IR_Tbl_Idx) {
04265
04266 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
04267 IR_WHOLE_ARRAY(OPND_IDX(opnd)) = TRUE;
04268 break;
04269 }
04270
04271 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
04272 }
04273 }
04274
04275 COPY_OPND(opnd, IL_OPND(list_idx));
04276 unused1 = NULL_IDX;
04277 unused2 = NULL_IDX;
04278 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2);
04279 COPY_OPND(IL_OPND(list_idx), base_opnd);
04280 }
04281 }
04282
04283 NTR_IR_TBL(ir_idx);
04284 IR_OPR(ir_idx) = Aloc_Opr;
04285 IR_TYPE_IDX(ir_idx) = (arg_info_list[info_idx].ed.type ==
04286 Character)
04287 ? CRI_Ch_Ptr_8 : CRI_Ptr_8;
04288 IR_LINE_NUM(ir_idx) = line;
04289 IR_COL_NUM(ir_idx) = col;
04290
04291 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
04292 IL_FLD(list_idx) = IR_Tbl_Idx;
04293 IL_IDX(list_idx) = ir_idx;
04294
04295 # ifdef _TRANSFORM_CHAR_SEQUENCE
04296 if (arg_info_list[info_idx].ed.type == Structure &&
04297 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
04298
04299 COPY_OPND(opnd, IR_OPND_L(ir_idx));
04300 transform_char_sequence_ref(&opnd,
04301 arg_info_list[info_idx].ed.type_idx);
04302 COPY_OPND(IR_OPND_L(ir_idx), opnd);
04303
04304 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04305 }
04306 # endif
04307 }
04308
04309 break;
04310
04311 case PASS_SECTION_ADDRESS :
04312 #ifdef _DEBUG
04313 pass_section_address_count += 1;
04314 #endif
04315
04316 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04317 #ifdef KEY
04318 if (clear_pt_unique_mem(dummy)) {
04319 #endif
04320 ATD_NOT_PT_UNIQUE_MEM(
04321 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
04322 #ifdef KEY
04323 }
04324 #endif
04325 # endif
04326
04327
04328
04329 COPY_OPND(opnd, IL_OPND(list_idx));
04330 unused1 = NULL_IDX;
04331 unused2 = NULL_IDX;
04332 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2);
04333 COPY_OPND(opnd, base_opnd);
04334
04335 NTR_IR_TBL(ir_idx);
04336 IR_OPR(ir_idx) = Aloc_Opr;
04337 IR_TYPE_IDX(ir_idx) = (arg_info_list[info_idx].ed.type ==
04338 Character)
04339 ? CRI_Ch_Ptr_8 : CRI_Ptr_8;
04340 IR_LINE_NUM(ir_idx) = line;
04341 IR_COL_NUM(ir_idx) = col;
04342
04343 COPY_OPND(IR_OPND_L(ir_idx), opnd);
04344 IL_FLD(list_idx) = IR_Tbl_Idx;
04345 IL_IDX(list_idx) = ir_idx;
04346
04347 # ifdef _TRANSFORM_CHAR_SEQUENCE
04348 if (arg_info_list[info_idx].ed.type == Structure &&
04349 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
04350
04351 COPY_OPND(opnd, IR_OPND_L(ir_idx));
04352 transform_char_sequence_ref(&opnd,
04353 arg_info_list[info_idx].ed.type_idx);
04354 COPY_OPND(IR_OPND_L(ir_idx), opnd);
04355
04356 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04357 }
04358 # endif
04359
04360 break;
04361
04362
04363
04364 case PASS_ADDRESS_FROM_DV :
04365 #ifdef _DEBUG
04366 pass_address_from_dv_count += 1;
04367 #endif
04368
04369 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04370 #ifdef KEY
04371 if (clear_pt_unique_mem(dummy)) {
04372 #endif
04373 ATD_NOT_PT_UNIQUE_MEM(
04374 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
04375 #ifdef KEY
04376 }
04377 #endif
04378 # endif
04379
04380
04381 if (!pass_by_value(spec_idx, info_idx, dummy)) {
04382
04383 NTR_IR_TBL(ir_idx);
04384 IR_OPR(ir_idx) = Dv_Access_Base_Addr;
04385 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE;
04386 IR_LINE_NUM(ir_idx) = line;
04387 IR_COL_NUM(ir_idx) = col;
04388
04389 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04390 IR_OPR(IL_IDX(list_idx)) == Whole_Substring_Opr) {
04391 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
04392 }
04393
04394 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04395 IR_OPR(IL_IDX(list_idx)) == Whole_Subscript_Opr) {
04396 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
04397 }
04398
04399 if (IL_FLD(list_idx) != IR_Tbl_Idx ||
04400 IR_OPR(IL_IDX(list_idx)) != Dv_Deref_Opr) {
04401
04402 PRINTMSG(line, 861, Internal, col,
04403 "final_arg_work");
04404 }
04405
04406 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IL_IDX(list_idx)));
04407
04408 if (cmd_line_flags.runtime_ptr_chk) {
04409 COPY_OPND(opnd, IR_OPND_L(ir_idx));
04410 gen_runtime_ptr_chk(&opnd);
04411 }
04412
04413 IL_FLD(list_idx) = IR_Tbl_Idx;
04414 IL_IDX(list_idx) = ir_idx;
04415 }
04416
04417 arg_info_list[info_idx].ed.dope_vector = FALSE;
04418 arg_info_list[info_idx].ed.pointer = FALSE;
04419
04420 break;
04421
04422 case PASS_DV :
04423 #ifdef _DEBUG
04424 pass_dv_count += 1;
04425 #endif
04426
04427 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04428 #ifdef KEY
04429 if (clear_pt_unique_mem(dummy)) {
04430 #endif
04431 ATD_NOT_PT_UNIQUE_MEM(
04432 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
04433 #ifdef KEY
04434 }
04435 #endif
04436 # endif
04437
04438 NTR_IR_TBL(ir_idx);
04439 IR_OPR(ir_idx) = Aloc_Opr;
04440 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
04441 IR_LINE_NUM(ir_idx) = line;
04442 IR_COL_NUM(ir_idx) = col;
04443
04444 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04445 IR_OPR(IL_IDX(list_idx)) == Whole_Substring_Opr) {
04446 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
04447 }
04448
04449 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04450 IR_OPR(IL_IDX(list_idx)) == Whole_Subscript_Opr) {
04451 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
04452 }
04453
04454 if (IL_FLD(list_idx) != IR_Tbl_Idx ||
04455 IR_OPR(IL_IDX(list_idx)) != Dv_Deref_Opr) {
04456
04457 PRINTMSG(line, 861, Internal, col,
04458 "final_arg_work");
04459 }
04460
04461 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IL_IDX(list_idx)));
04462
04463 IL_FLD(list_idx) = IR_Tbl_Idx;
04464 IL_IDX(list_idx) = ir_idx;
04465
04466 break;
04467
04468 case PASS_DV_COPY :
04469 #ifdef _DEBUG
04470 pass_dv_copy_count += 1;
04471 #endif
04472
04473 if (AT_OPTIONAL(dummy) &&
04474 arg_info_list[info_idx].ed.optional_darg) {
04475
04476
04477
04478 COPY_OPND(opnd, IL_OPND(list_idx));
04479 present_idx = gen_ir(AT_Tbl_Idx, find_left_attr(&opnd),
04480 Present_Opr, LOGICAL_DEFAULT_TYPE, line, col,
04481 NO_Tbl_Idx, NULL_IDX);
04482
04483 gen_opnd(&cond_opnd,
04484 present_idx,
04485 IR_Tbl_Idx,
04486 line,
04487 col);
04488
04489
04490 true_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
04491 true_end_sh_idx = curr_stmt_sh_idx;
04492
04493
04494
04495 tmp_dv_idx = create_tmp_DV_asg(list_idx, info_idx);
04496
04497 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04498 #ifdef KEY
04499
04500
04501
04502 if ( ATD_NOT_PT_UNIQUE_MEM((find_left_attr(&IL_OPND(list_idx)))))
04503 #endif
04504 {
04505 ATD_NOT_PT_UNIQUE_MEM(tmp_dv_idx) = TRUE;
04506 ATD_NOT_PT_UNIQUE_MEM(
04507 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
04508 }
04509 #endif
04510
04511
04512
04513 GEN_COMPILER_TMP_ASG(asg_idx,
04514 tmp_loc_idx,
04515 TRUE,
04516 line,
04517 col,
04518 SA_INTEGER_DEFAULT_TYPE,
04519 Priv);
04520
04521 ir_idx = gen_ir(AT_Tbl_Idx, tmp_dv_idx,
04522 Loc_Opr, CRI_Ptr_8, line, col,
04523 NO_Tbl_Idx, NULL_IDX);
04524
04525 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
04526 IR_IDX_R(asg_idx) = ir_idx;
04527 IR_LINE_NUM_R(asg_idx) = line;
04528 IR_COL_NUM_R(asg_idx) = col;
04529
04530 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
04531
04532 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
04533 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
04534
04535 true_start_sh_idx = SH_NEXT_IDX(true_start_sh_idx);
04536 true_end_sh_idx = SH_PREV_IDX(true_end_sh_idx);
04537
04538
04539
04540 asg_idx = gen_ir(AT_Tbl_Idx, tmp_loc_idx,
04541 Asg_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
04542 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
04543
04544 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
04545
04546 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
04547 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
04548
04549 false_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
04550 false_end_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
04551
04552 gen_if_stmt(&cond_opnd,
04553 true_start_sh_idx,
04554 true_end_sh_idx,
04555 false_start_sh_idx,
04556 false_end_sh_idx,
04557 line,
04558 col);
04559
04560
04561
04562 IL_FLD(list_idx) = AT_Tbl_Idx;
04563 IL_IDX(list_idx) = tmp_loc_idx;
04564 IL_LINE_NUM(list_idx) = line;
04565 IL_COL_NUM(list_idx) = col;
04566 }
04567 else {
04568
04569 tmp_dv_idx = create_tmp_DV_asg(list_idx, info_idx);
04570
04571
04572 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04573 #ifdef KEY
04574
04575
04576
04577 if ( ATD_NOT_PT_UNIQUE_MEM((find_left_attr(&IL_OPND(list_idx)))))
04578 #endif
04579 {
04580 ATD_NOT_PT_UNIQUE_MEM(tmp_dv_idx) = TRUE;
04581 ATD_NOT_PT_UNIQUE_MEM(
04582 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
04583 }
04584 #endif
04585
04586 NTR_IR_TBL(ir_idx);
04587 IR_OPR(ir_idx) = Aloc_Opr;
04588 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
04589 IR_LINE_NUM(ir_idx) = line;
04590 IR_COL_NUM(ir_idx) = col;
04591 IL_FLD(list_idx) = IR_Tbl_Idx;
04592 IL_IDX(list_idx) = ir_idx;
04593 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
04594 IR_IDX_L(ir_idx) = tmp_dv_idx;
04595 IR_LINE_NUM_L(ir_idx) = line;
04596 IR_COL_NUM_L(ir_idx) = col;
04597 }
04598 break;
04599
04600 case COPY_IN :
04601 #ifdef _DEBUG
04602 copy_in_count += 1;
04603 #endif
04604
04605 if (IL_FLD(list_idx) == CN_Tbl_Idx &&
04606 ! io_call &&
04607
04608 # ifdef KEY
04609 ! LANG_Read_Write_Const &&
04610 # endif
04611 # ifdef _TARGET_OS_MAX
04612 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Integer_1 &&
04613 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Integer_2 &&
04614 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Integer_4 &&
04615 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Logical_1 &&
04616 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Logical_2 &&
04617 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Logical_4 &&
04618 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Real_4 &&
04619 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Complex_4 &&
04620
04621 # endif
04622 (TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Integer ||
04623 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Logical ||
04624 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Real ||
04625 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04626 (TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Character &&
04627 ! on_off_flags.pad_char_literals) ||
04628 # endif
04629 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Complex)) {
04630
04631
04632
04633
04634 if (!pass_by_value(spec_idx, info_idx, dummy)) {
04635 NTR_IR_TBL(ir_idx);
04636 IR_OPR(ir_idx) = Const_Tmp_Loc_Opr;
04637 IR_TYPE_IDX(ir_idx) = CN_TYPE_IDX(IL_IDX(list_idx));
04638 IR_LINE_NUM(ir_idx) = line;
04639 IR_COL_NUM(ir_idx) = col;
04640 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
04641 IL_FLD(list_idx) = IR_Tbl_Idx;
04642 IL_IDX(list_idx) = ir_idx;
04643 }
04644
04645 break;
04646 }
04647
04648 if (IL_FLD(list_idx) == CN_Tbl_Idx &&
04649 arg_info_list[info_idx].ed.type == Character &&
04650 dummy == NULL_IDX &&
04651 compare_cn_and_value(TYP_IDX(arg_info_list[info_idx].ed.type_idx),
04652 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04653 storage_bit_size_tbl[INTEGER_DEFAULT_TYPE]/8,
04654 # else
04655 TARGET_CHARS_PER_WORD,
04656 # endif
04657 Lt_Opr)) {
04658
04659 exp_desc = arg_info_list[info_idx].ed;
04660 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
04661
04662 TYP_TYPE(TYP_WORK_IDX) = Character;
04663 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
04664 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
04665 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx;
04666
04667 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04668 the_constant = storage_bit_size_tbl[INTEGER_DEFAULT_TYPE]/8;
04669 # else
04670 the_constant = TARGET_CHARS_PER_WORD;
04671 # endif
04672 TYP_IDX(TYP_WORK_IDX)= C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
04673 the_constant);
04674
04675 exp_desc.type_idx = ntr_type_tbl();
04676 exp_desc.char_len.fld = CN_Tbl_Idx;
04677 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx);
04678
04679 OPND_FLD(opnd) = CN_Tbl_Idx;
04680 OPND_IDX(opnd) = ntr_const_tbl(exp_desc.type_idx,
04681 TRUE,
04682 NULL);
04683
04684 OPND_LINE_NUM(opnd) = line;
04685 OPND_COL_NUM(opnd) = col;
04686
04687 char_ptr1 = (char *)&CN_CONST(IL_IDX(list_idx));
04688 char_ptr2 = (char *)&CN_CONST(OPND_IDX(opnd));
04689
04690 for (k = 0;
04691 k<CN_INT_TO_C(TYP_IDX(arg_info_list[info_idx].ed.type_idx));
04692 k++) {
04693 char_ptr2[k] = char_ptr1[k];
04694 }
04695
04696 for ( ; k < CN_INT_TO_C(TYP_IDX(exp_desc.type_idx)); k++) {
04697 char_ptr2[k] = ' ';
04698 }
04699
04700 #ifdef KEY
04701 tmp_idx = create_tmp_asg_or_call(&opnd,
04702 &exp_desc,
04703 &l_opnd,
04704 Intent_In,
04705 TRUE,
04706 FALSE,
04707 info_idx, a_type, d_type);
04708 #else
04709 tmp_idx = create_tmp_asg(&opnd,
04710 &exp_desc,
04711 &l_opnd,
04712 Intent_In,
04713 TRUE,
04714 FALSE);
04715 #endif
04716
04717 NTR_IR_TBL(ir_idx);
04718 IR_OPR(ir_idx) = Aloc_Opr;
04719 IR_LINE_NUM(ir_idx) = line;
04720 IR_COL_NUM(ir_idx) = col;
04721
04722 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04723
04724 IL_FLD(list_idx) = IR_Tbl_Idx;
04725 IL_IDX(list_idx) = ir_idx;
04726
04727 NTR_IR_TBL(unused1);
04728 IR_OPR(unused1) = Substring_Opr;
04729 IR_TYPE_IDX(unused1) = arg_info_list[info_idx].ed.type_idx;
04730 IR_FLD_L(unused1) = AT_Tbl_Idx;
04731 IR_IDX_L(unused1) = tmp_idx;
04732 IR_LINE_NUM_L(unused1) = line;
04733 IR_COL_NUM_L(unused1) = col;
04734 IR_LINE_NUM(unused1) = line;
04735 IR_COL_NUM(unused1) = col;
04736
04737 NTR_IR_LIST_TBL(list_idx2);
04738 IR_FLD_R(unused1) = IL_Tbl_Idx;
04739 IR_IDX_R(unused1) = list_idx2;
04740 IR_LIST_CNT_R(unused1) = 3;
04741
04742 IL_FLD(list_idx2) = CN_Tbl_Idx;
04743 IL_IDX(list_idx2) = CN_INTEGER_ONE_IDX;
04744 IL_LINE_NUM(list_idx2) = line;
04745 IL_COL_NUM(list_idx2) = col;
04746
04747 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
04748 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
04749 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
04750
04751 IL_FLD(list_idx2) = CN_Tbl_Idx;
04752 IL_IDX(list_idx2) = TYP_IDX(arg_info_list[info_idx].ed.type_idx);
04753 IL_LINE_NUM(list_idx2) = line;
04754 IL_COL_NUM(list_idx2) = col;
04755
04756 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
04757 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
04758 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
04759
04760 IL_FLD(list_idx2) = CN_Tbl_Idx;
04761 IL_IDX(list_idx2) = TYP_IDX(arg_info_list[info_idx].ed.type_idx);
04762 IL_LINE_NUM(list_idx2) = line;
04763 IL_COL_NUM(list_idx2) = col;
04764
04765
04766 IR_FLD_L(ir_idx) = IR_Tbl_Idx;
04767 IR_IDX_L(ir_idx) = unused1;
04768 }
04769 #ifdef KEY
04770 else if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04771 IR_OPR(IL_IDX(list_idx)) == Percent_Val_Opr) {
04772
04773
04774
04775
04776
04777
04778
04779 int pvo = IL_IDX(list_idx);
04780 IL_FLD(list_idx) = IR_FLD_L(pvo);
04781 IL_IDX(list_idx) = IR_IDX_L(pvo);
04782 }
04783 #endif
04784
04785 else {
04786
04787 if (! io_call &&
04788 arg_info_list[info_idx].ed.rank != 0) {
04789
04790
04791
04792 PRINTMSG(line, 1438, Caution, col, "copy in");
04793 }
04794
04795 COPY_OPND(opnd, IL_OPND(list_idx));
04796 tmp_idx = create_tmp_asg(&opnd,
04797 (expr_arg_type *)&(arg_info_list[info_idx].ed),
04798 &l_opnd,
04799 Intent_In,
04800 TRUE,
04801 FALSE);
04802
04803
04804 if (pass_by_value(spec_idx, info_idx, dummy) ||
04805 ATP_ELEMENTAL(spec_idx)) {
04806
04807 COPY_OPND(IL_OPND(list_idx), l_opnd);
04808
04809 if (ATP_ELEMENTAL(spec_idx)) {
04810 NTR_IR_TBL(ir_idx);
04811 IR_OPR(ir_idx) = Aloc_Opr;
04812 IR_LINE_NUM(ir_idx) = line;
04813 IR_COL_NUM(ir_idx) = col;
04814
04815 if (arg_info_list[info_idx].ed.type == Character) {
04816 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04817 }
04818 else {
04819 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
04820 }
04821
04822 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
04823 IL_FLD(list_idx) = IR_Tbl_Idx;
04824 IL_IDX(list_idx) = ir_idx;
04825 }
04826 }
04827 else {
04828 NTR_IR_TBL(ir_idx);
04829 IR_OPR(ir_idx) = Aloc_Opr;
04830 IR_LINE_NUM(ir_idx) = line;
04831 IR_COL_NUM(ir_idx) = col;
04832
04833 if (arg_info_list[info_idx].ed.type == Character) {
04834 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04835 }
04836 else {
04837 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
04838 }
04839
04840 IL_FLD(list_idx) = IR_Tbl_Idx;
04841 IL_IDX(list_idx) = ir_idx;
04842
04843
04844
04845 # ifndef _FRONTEND_INLINER
04846 if (OPND_FLD(l_opnd) == IR_Tbl_Idx &&
04847 ! ATP_ELEMENTAL(spec_idx)) {
04848
04849 if (IR_OPR(OPND_IDX(l_opnd)) == Whole_Subscript_Opr) {
04850 COPY_OPND(l_opnd, IR_OPND_L(OPND_IDX(l_opnd)));
04851 }
04852 }
04853 # endif
04854 if (arg_info_list[info_idx].ed.rank != 0) {
04855 unused1 = NULL_IDX;
04856 unused2 = NULL_IDX;
04857 make_base_subtree(&l_opnd,&base_opnd,&unused1,&unused2);
04858 COPY_OPND(l_opnd, base_opnd);
04859 }
04860
04861
04862 COPY_OPND(IR_OPND_L(ir_idx), l_opnd);
04863
04864 # ifdef _TRANSFORM_CHAR_SEQUENCE
04865 if (arg_info_list[info_idx].ed.type == Structure &&
04866 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
04867
04868 COPY_OPND(opnd, IR_OPND_L(ir_idx));
04869 transform_char_sequence_ref(&opnd,
04870 arg_info_list[info_idx].ed.type_idx);
04871 COPY_OPND(IR_OPND_L(ir_idx), opnd);
04872
04873 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04874 }
04875 # endif
04876 }
04877 }
04878 break;
04879
04880 case COPY_IN_COPY_OUT :
04881 #ifdef _DEBUG
04882 copy_in_copy_out_count += 1;
04883 #endif
04884
04885
04886 if (arg_info_list[info_idx].ed.section) {
04887 save_array_syntax_subscripts(list_idx);
04888 }
04889
04890 intent = Intent_Inout;
04891
04892 if (dummy != NULL_IDX &&
04893 ATD_INTENT(dummy) == Intent_Out) {
04894
04895 intent = Intent_Out;
04896
04897 if (! io_call &&
04898 arg_info_list[info_idx].ed.rank != 0) {
04899
04900
04901 PRINTMSG(line, 1438, Caution, col, "copy out");
04902 }
04903 }
04904 else if (! io_call &&
04905 arg_info_list[info_idx].ed.rank != 0 &&
04906 (dummy == NULL_IDX ||
04907 ATD_INTENT(dummy) != Intent_In)) {
04908
04909
04910 PRINTMSG(line, 1438, Caution, col, "copy in and copy out");
04911 }
04912 else if (! io_call &&
04913 arg_info_list[info_idx].ed.rank != 0) {
04914
04915
04916 intent = Intent_In;
04917
04918 PRINTMSG(line, 1438, Caution, col, "copy in");
04919 }
04920
04921 COPY_OPND(opnd, IL_OPND(list_idx));
04922 tmp_idx = create_tmp_asg(&opnd,
04923 (expr_arg_type *)&(arg_info_list[info_idx].ed),
04924 &l_opnd,
04925 intent,
04926 TRUE,
04927 FALSE);
04928
04929 if (pass_by_value(spec_idx, info_idx, dummy)) {
04930
04931 COPY_OPND(IL_OPND(list_idx), l_opnd);
04932 }
04933 else {
04934 NTR_IR_TBL(ir_idx);
04935 IR_OPR(ir_idx) = Aloc_Opr;
04936 IR_LINE_NUM(ir_idx) = line;
04937 IR_COL_NUM(ir_idx) = col;
04938
04939 if (arg_info_list[info_idx].ed.type == Character) {
04940 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04941 }
04942 else {
04943 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
04944 }
04945
04946 IL_FLD(list_idx) = IR_Tbl_Idx;
04947 IL_IDX(list_idx) = ir_idx;
04948
04949
04950
04951 # ifndef _FRONTEND_INLINER
04952 if (OPND_FLD(l_opnd) == IR_Tbl_Idx &&
04953 ! ATP_ELEMENTAL(spec_idx)) {
04954
04955 if (IR_OPR(OPND_IDX(l_opnd)) == Whole_Subscript_Opr) {
04956 COPY_OPND(l_opnd, IR_OPND_L(OPND_IDX(l_opnd)));
04957 }
04958 }
04959 # endif
04960 if (arg_info_list[info_idx].ed.rank != 0) {
04961 unused1 = NULL_IDX;
04962 unused2 = NULL_IDX;
04963 make_base_subtree(&l_opnd, &base_opnd, &unused1, &unused2);
04964 COPY_OPND(l_opnd, base_opnd);
04965 }
04966
04967 COPY_OPND(IR_OPND_L(ir_idx), l_opnd);
04968
04969 # ifdef _TRANSFORM_CHAR_SEQUENCE
04970 if (arg_info_list[info_idx].ed.type == Structure &&
04971 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
04972
04973 COPY_OPND(opnd, IR_OPND_L(ir_idx));
04974 transform_char_sequence_ref(&opnd,
04975 arg_info_list[info_idx].ed.type_idx);
04976 COPY_OPND(IR_OPND_L(ir_idx), opnd);
04977
04978 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
04979 }
04980 # endif
04981 }
04982
04983
04984 break;
04985
04986 case MAKE_DV :
04987 #ifdef _DEBUG
04988 make_dv_count += 1;
04989 #endif
04990
04991 if (AT_OPTIONAL(dummy) &&
04992 arg_info_list[info_idx].ed.optional_darg) {
04993
04994
04995
04996 COPY_OPND(opnd, IL_OPND(list_idx));
04997 present_idx = gen_ir(AT_Tbl_Idx, find_left_attr(&opnd),
04998 Present_Opr, LOGICAL_DEFAULT_TYPE, line, col,
04999 NO_Tbl_Idx, NULL_IDX);
05000
05001 gen_opnd(&cond_opnd,
05002 present_idx,
05003 IR_Tbl_Idx,
05004 line,
05005 col);
05006
05007
05008 true_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05009 true_end_sh_idx = curr_stmt_sh_idx;
05010
05011
05012
05013 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
05014
05015 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05016 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE;
05017 ATD_NOT_PT_UNIQUE_MEM(
05018 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
05019 # endif
05020
05021 ATD_TYPE_IDX(tmp_idx) = arg_info_list[info_idx].ed.type_idx;
05022 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
05023 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
05024
05025 if (arg_info_list[info_idx].ed.rank) {
05026
05027
05028
05029 ATD_ARRAY_IDX(tmp_idx) = arg_info_list[info_idx].ed.rank;
05030 }
05031 ATD_IM_A_DOPE(tmp_idx) = TRUE;
05032
05033 COPY_OPND(r_opnd, IL_OPND(list_idx));
05034 exp_desc = arg_info_list[info_idx].ed;
05035 OPND_FLD(l_opnd) = AT_Tbl_Idx;
05036 OPND_IDX(l_opnd) = tmp_idx;
05037 OPND_LINE_NUM(l_opnd) = line;
05038 OPND_COL_NUM(l_opnd) = col;
05039
05040 gen_dv_whole_def(&l_opnd, &r_opnd, &exp_desc);
05041
05042
05043
05044
05045 GEN_COMPILER_TMP_ASG(asg_idx,
05046 tmp_loc_idx,
05047 TRUE,
05048 line,
05049 col,
05050 SA_INTEGER_DEFAULT_TYPE,
05051 Priv);
05052
05053 ir_idx = gen_ir(AT_Tbl_Idx, tmp_idx,
05054 Loc_Opr, CRI_Ptr_8, line, col,
05055 NO_Tbl_Idx, NULL_IDX);
05056
05057 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
05058 IR_IDX_R(asg_idx) = ir_idx;
05059 IR_LINE_NUM_R(asg_idx) = line;
05060 IR_COL_NUM_R(asg_idx) = col;
05061
05062 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
05063
05064 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
05065 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
05066
05067 true_start_sh_idx = SH_NEXT_IDX(true_start_sh_idx);
05068 true_end_sh_idx = SH_PREV_IDX(true_end_sh_idx);
05069
05070
05071
05072 asg_idx = gen_ir(AT_Tbl_Idx, tmp_loc_idx,
05073 Asg_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
05074 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
05075
05076 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
05077
05078 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
05079 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
05080
05081 false_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05082 false_end_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05083
05084 gen_if_stmt(&cond_opnd,
05085 true_start_sh_idx,
05086 true_end_sh_idx,
05087 false_start_sh_idx,
05088 false_end_sh_idx,
05089 line,
05090 col);
05091
05092
05093
05094 IL_FLD(list_idx) = AT_Tbl_Idx;
05095 IL_IDX(list_idx) = tmp_loc_idx;
05096 IL_LINE_NUM(list_idx) = line;
05097 IL_COL_NUM(list_idx) = col;
05098 }
05099 else {
05100
05101 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
05102
05103 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05104 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE;
05105 ATD_NOT_PT_UNIQUE_MEM(
05106 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
05107 # endif
05108
05109 ATD_TYPE_IDX(tmp_idx) = arg_info_list[info_idx].ed.type_idx;
05110 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
05111 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
05112
05113 if (arg_info_list[info_idx].ed.rank) {
05114
05115
05116
05117 ATD_ARRAY_IDX(tmp_idx) = arg_info_list[info_idx].ed.rank;
05118 }
05119 ATD_IM_A_DOPE(tmp_idx) = TRUE;
05120
05121 COPY_OPND(r_opnd, IL_OPND(list_idx));
05122 exp_desc = arg_info_list[info_idx].ed;
05123 OPND_FLD(l_opnd) = AT_Tbl_Idx;
05124 OPND_IDX(l_opnd) = tmp_idx;
05125 OPND_LINE_NUM(l_opnd) = line;
05126 OPND_COL_NUM(l_opnd) = col;
05127
05128 gen_dv_whole_def(&l_opnd, &r_opnd, &exp_desc);
05129
05130 NTR_IR_TBL(ir_idx);
05131 IR_OPR(ir_idx) = Aloc_Opr;
05132 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
05133 IR_LINE_NUM(ir_idx) = line;
05134 IR_COL_NUM(ir_idx) = col;
05135 IL_FLD(list_idx) = IR_Tbl_Idx;
05136 IL_IDX(list_idx) = ir_idx;
05137 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
05138 IR_IDX_L(ir_idx) = tmp_idx;
05139 IR_LINE_NUM_L(ir_idx) = line;
05140 IR_COL_NUM_L(ir_idx) = col;
05141 }
05142
05143 arg_info_list[info_idx].ed.dope_vector = TRUE;
05144
05145 break;
05146
05147 case COPY_IN_MAKE_DV :
05148 # if defined(KEY)
05149 case COPY_INOUT_MAKE_DV :
05150 {
05151 #ifdef _DEBUG
05152 copy_in_make_dv_count += (association == COPY_IN_MAKE_DV);
05153 copy_inout_make_dv_count += (association == COPY_INOUT_MAKE_DV);
05154 #endif
05155 int old_curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05156 # endif
05157
05158
05159 COPY_OPND(opnd, IL_OPND(list_idx));
05160 # if defined(KEY)
05161 #ifdef KEY
05162 boolean copyin = (association == COPY_IN_MAKE_DV);
05163
05164
05165
05166
05167
05168
05169
05170
05171
05172
05173
05174 boolean move = (association == COPY_INOUT_MAKE_DV) &&
05175 safe_to_move_copyinout_alloc(&opnd);
05176 tmp_idx = create_tmp_asg(&opnd,
05177 (expr_arg_type *)&(arg_info_list[info_idx].ed),
05178 &l_opnd,
05179 copyin ? Intent_In : Intent_Inout,
05180 copyin,
05181
05182 move);
05183 if (move) {
05184 move_tmp_alloc_assignment(old_curr_stmt_sh_idx, attr_idx);
05185 }
05186 }
05187 #else
05188 tmp_idx = create_tmp_asg(&opnd,
05189 (expr_arg_type *)&(arg_info_list[info_idx].ed),
05190 &l_opnd,
05191 association == COPY_IN_MAKE_DV ? Intent_In : Intent_Inout,
05192 association == COPY_IN_MAKE_DV ? TRUE : FALSE,
05193 association == COPY_IN_MAKE_DV ? FALSE : TRUE);
05194 if (association == COPY_INOUT_MAKE_DV)
05195 move_tmp_alloc_assignment(&opnd, old_curr_stmt_sh_idx, attr_idx, dim);
05196 #endif
05197 # else
05198 tmp_idx = create_tmp_asg(&opnd,
05199 (expr_arg_type *)&(arg_info_list[info_idx].ed),
05200 &l_opnd,
05201 Intent_In,
05202 TRUE,
05203 FALSE);
05204 # endif
05205
05206 if (! io_call &&
05207 arg_info_list[info_idx].ed.rank != 0) {
05208
05209
05210
05211 PRINTMSG(line, 1438, Caution, col, "copy in");
05212 }
05213
05214
05215
05216 tmp_dv_idx = gen_compiler_tmp(line, col, Priv, TRUE);
05217
05218 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05219 #ifdef KEY
05220 if (clear_pt_unique_mem(dummy)) {
05221 #endif
05222 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE;
05223 #ifdef KEY
05224 }
05225 #endif
05226
05227 if (ATD_AUTOMATIC(tmp_idx) &&
05228 ATD_AUTO_BASE_IDX(tmp_idx) != NULL_IDX) {
05229 ATD_NOT_PT_UNIQUE_MEM(ATD_AUTO_BASE_IDX(tmp_idx)) = TRUE;
05230 }
05231
05232 #ifdef KEY
05233 if (clear_pt_unique_mem(dummy)) {
05234 #endif
05235 ATD_NOT_PT_UNIQUE_MEM(tmp_dv_idx) = TRUE;
05236 #ifdef KEY
05237 }
05238 #endif
05239 # endif
05240
05241 ATD_TYPE_IDX(tmp_dv_idx) = arg_info_list[info_idx].ed.type_idx;
05242 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
05243 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE;
05244
05245 if (arg_info_list[info_idx].ed.rank) {
05246
05247
05248
05249 ATD_ARRAY_IDX(tmp_dv_idx) = arg_info_list[info_idx].ed.rank;
05250 }
05251 ATD_IM_A_DOPE(tmp_dv_idx) = TRUE;
05252
05253 OPND_FLD(r_opnd) = AT_Tbl_Idx;
05254 OPND_IDX(r_opnd) = tmp_idx;
05255 OPND_LINE_NUM(r_opnd) = line;
05256 OPND_COL_NUM(r_opnd) = col;
05257
05258 exp_desc = arg_info_list[info_idx].ed;
05259
05260 if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character) {
05261 ok = gen_whole_substring(&r_opnd, exp_desc.rank) && ok;
05262 }
05263
05264 OPND_FLD(l_opnd) = AT_Tbl_Idx;
05265 OPND_IDX(l_opnd) = tmp_dv_idx;
05266 OPND_LINE_NUM(l_opnd) = line;
05267 OPND_COL_NUM(l_opnd) = col;
05268
05269 gen_dv_whole_def(&l_opnd, &r_opnd, &exp_desc);
05270
05271 NTR_IR_TBL(ir_idx);
05272 IR_OPR(ir_idx) = Aloc_Opr;
05273 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
05274 IR_LINE_NUM(ir_idx) = line;
05275 IR_COL_NUM(ir_idx) = col;
05276 IL_FLD(list_idx) = IR_Tbl_Idx;
05277 IL_IDX(list_idx) = ir_idx;
05278 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
05279 IR_IDX_L(ir_idx) = tmp_dv_idx;
05280 IR_LINE_NUM_L(ir_idx) = line;
05281 IR_COL_NUM_L(ir_idx) = col;
05282
05283 arg_info_list[info_idx].ed.dope_vector = TRUE;
05284
05285 break;
05286
05287 case CHECK_CONTIG_FLAG :
05288 #ifdef _DEBUG
05289 check_contig_flag_count += 1;
05290 #endif
05291
05292 if (! io_call &&
05293 arg_info_list[info_idx].ed.rank != 0) {
05294
05295
05296 PRINTMSG(line, 1438, Caution, col, "possible copy in and out");
05297 }
05298
05299 if (arg_info_list[info_idx].ed.section) {
05300 save_array_syntax_subscripts(list_idx);
05301 }
05302
05303
05304
05305 # if 0
05306 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05307 NTR_IR_LIST_TBL(false_list_idx);
05308 NTR_IR_TBL(false_parm_idx);
05309 IR_OPR(false_parm_idx) = False_Parm_Opr;
05310 IR_TYPE_IDX(false_parm_idx) = CRI_Ptr_8;
05311 IR_LINE_NUM(false_parm_idx) = line;
05312 IR_COL_NUM(false_parm_idx) = col;
05313 COPY_OPND(IR_OPND_L(false_parm_idx), IL_OPND(list_idx));
05314 IL_FLD(false_list_idx) = IR_Tbl_Idx;
05315 IL_IDX(false_list_idx) = false_parm_idx;
05316 # endif
05317 # endif
05318 addr_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
05319
05320 # ifdef _TRANSFORM_CHAR_SEQUENCE
05321 if (arg_info_list[info_idx].ed.type == Character ||
05322 (arg_info_list[info_idx].ed.type == Structure &&
05323 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))))
05324 # else
05325 if (arg_info_list[info_idx].ed.type == Character)
05326 # endif
05327 {
05328 ATD_TYPE_IDX(addr_tmp_idx) = CRI_Ch_Ptr_8;
05329 }
05330 else {
05331 ATD_TYPE_IDX(addr_tmp_idx) = SA_INTEGER_DEFAULT_TYPE;
05332 }
05333 ATD_STOR_BLK_IDX(addr_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
05334 AT_SEMANTICS_DONE(addr_tmp_idx) = TRUE;
05335
05336 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05337 ATD_NOT_PT_UNIQUE_MEM(addr_tmp_idx) = TRUE;
05338 ATD_NOT_PT_UNIQUE_MEM(find_left_attr(&IL_OPND(list_idx))) = TRUE;
05339 # endif
05340
05341
05342
05343 COPY_OPND(dv_opnd, IL_OPND(list_idx));
05344
05345 while (OPND_FLD(dv_opnd) == IR_Tbl_Idx &&
05346 IR_OPR(OPND_IDX(dv_opnd)) != Dv_Deref_Opr) {
05347 COPY_OPND(dv_opnd, IR_OPND_L(OPND_IDX(dv_opnd)));
05348 }
05349
05350 COPY_OPND(dv_opnd, IR_OPND_L(OPND_IDX(dv_opnd)));
05351
05352
05353
05354 ATD_FLD(addr_tmp_idx) = OPND_FLD(dv_opnd);
05355 ATD_TMP_IDX(addr_tmp_idx) = OPND_IDX(dv_opnd);
05356
05357
05358
05359 ir_idx = gen_ir(OPND_FLD(dv_opnd), OPND_IDX(dv_opnd),
05360 Dv_Access_A_Contig, CG_INTEGER_DEFAULT_TYPE, line, col,
05361 NO_Tbl_Idx, NULL_IDX);
05362
05363 present_idx = gen_ir(IR_Tbl_Idx, ir_idx,
05364 Eq_Opr, LOGICAL_DEFAULT_TYPE, line, col,
05365 CN_Tbl_Idx, CN_INTEGER_ONE_IDX);
05366
05367 gen_opnd(&cond_opnd,
05368 present_idx,
05369 IR_Tbl_Idx,
05370 line,
05371 col);
05372
05373
05374 contig_test_ir_idx = present_idx;
05375
05376 # if 0
05377 OPND_FLD(opnd) = CN_Tbl_Idx;
05378 OPND_IDX(opnd) = CN_INTEGER_ZERO_IDX;
05379 OPND_LINE_NUM(opnd) = line;
05380 OPND_COL_NUM(opnd) = col;
05381
05382 gen_internal_call_stmt("DUMP", &opnd, Before);
05383 # endif
05384
05385
05386
05387
05388 NTR_IR_TBL(asg_idx);
05389 IR_OPR(asg_idx) = Asg_Opr;
05390 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(addr_tmp_idx);
05391 IR_LINE_NUM(asg_idx) = line;
05392 IR_COL_NUM(asg_idx) = col;
05393 IR_LINE_NUM_L(asg_idx) = line;
05394 IR_COL_NUM_L(asg_idx) = col;
05395 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
05396 IR_IDX_L(asg_idx) = addr_tmp_idx;
05397
05398 COPY_OPND(opnd, IL_OPND(list_idx));
05399 unused1 = NULL_IDX;
05400 unused2 = NULL_IDX;
05401 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2);
05402
05403 NTR_IR_TBL(ir_idx);
05404 IR_OPR(ir_idx) = Loc_Opr;
05405 IR_TYPE_IDX(ir_idx) = (arg_info_list[info_idx].ed.type ==
05406 Character)
05407 ? CRI_Ch_Ptr_8 : CRI_Ptr_8;
05408 IR_LINE_NUM(ir_idx) = line;
05409 IR_COL_NUM(ir_idx) = col;
05410
05411 COPY_OPND(IR_OPND_L(ir_idx), base_opnd);
05412
05413 # ifdef _TRANSFORM_CHAR_SEQUENCE
05414 if (arg_info_list[info_idx].ed.type == Structure &&
05415 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
05416
05417 COPY_OPND(opnd, IR_OPND_L(ir_idx));
05418 transform_char_sequence_ref(&opnd,
05419 arg_info_list[info_idx].ed.type_idx);
05420 COPY_OPND(IR_OPND_L(ir_idx), opnd);
05421
05422 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
05423 }
05424 # endif
05425
05426
05427
05428
05429
05430
05431
05432
05433
05434
05435
05436 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
05437 IR_IDX_R(asg_idx) = ir_idx;
05438
05439 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
05440
05441 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
05442 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
05443
05444 true_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05445 true_end_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05446
05447
05448 true_start_sh_idx2 = curr_stmt_sh_idx;
05449 true_end_sh_idx2 = SH_NEXT_IDX(curr_stmt_sh_idx);
05450
05451 # if 0
05452 OPND_FLD(opnd) = CN_Tbl_Idx;
05453 OPND_IDX(opnd) = CN_INTEGER_ONE_IDX;
05454 OPND_LINE_NUM(opnd) = line;
05455 OPND_COL_NUM(opnd) = col;
05456
05457 gen_internal_call_stmt("DUMP", &opnd, Before);
05458 # endif
05459
05460
05461 false_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05462 false_end_sh_idx = curr_stmt_sh_idx;
05463
05464
05465
05466 intent = Intent_In;
05467
05468 if (dummy != NULL_IDX &&
05469 ATD_INTENT(dummy) == Intent_Out) {
05470 intent = Intent_Out;
05471 }
05472 else if (a_type != Array_Tmp_Ptr &&
05473 (dummy == NULL_IDX ||
05474 ATD_INTENT(dummy) != Intent_In)) {
05475 intent = Intent_Inout;
05476 }
05477
05478 COPY_OPND(opnd, IL_OPND(list_idx));
05479 exp_desc = arg_info_list[info_idx].ed;
05480 #ifdef KEY
05481 tmp_idx = create_tmp_asg_or_call(&opnd,
05482 &exp_desc,
05483 &r_opnd,
05484 intent,
05485 TRUE,
05486 FALSE,
05487 info_idx, a_type, d_type);
05488 #else
05489 tmp_idx = create_tmp_asg(&opnd,
05490 &exp_desc,
05491 &r_opnd,
05492 intent,
05493 TRUE,
05494 FALSE);
05495 #endif
05496 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05497 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE;
05498
05499 if (ATD_AUTOMATIC(tmp_idx) &&
05500 ATD_AUTO_BASE_IDX(tmp_idx) != NULL_IDX) {
05501
05502 ATD_NOT_PT_UNIQUE_MEM(ATD_AUTO_BASE_IDX(tmp_idx)) = TRUE;
05503 }
05504 # endif
05505
05506 contig_test_ir_idx = NULL_IDX;
05507
05508
05509
05510 NTR_IR_TBL(asg_idx);
05511 IR_OPR(asg_idx) = Asg_Opr;
05512 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(addr_tmp_idx);
05513 IR_LINE_NUM(asg_idx) = line;
05514 IR_COL_NUM(asg_idx) = col;
05515 IR_LINE_NUM_L(asg_idx) = line;
05516 IR_COL_NUM_L(asg_idx) = col;
05517 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
05518 IR_IDX_L(asg_idx) = addr_tmp_idx;
05519
05520 NTR_IR_TBL(ir_idx);
05521 IR_OPR(ir_idx) = Loc_Opr;
05522 IR_LINE_NUM(ir_idx) = line;
05523 IR_COL_NUM(ir_idx) = col;
05524
05525 if (arg_info_list[info_idx].ed.type == Character) {
05526 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
05527 }
05528 else {
05529 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
05530 }
05531
05532 OPND_FLD(l_opnd) = AT_Tbl_Idx;
05533 OPND_IDX(l_opnd) = tmp_idx;
05534 OPND_LINE_NUM(l_opnd) = line;
05535 OPND_COL_NUM(l_opnd) = col;
05536
05537 if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character) {
05538 ok = gen_whole_substring(&l_opnd,
05539 arg_info_list[info_idx].ed.rank) && ok;
05540 }
05541
05542 COPY_OPND(IR_OPND_L(ir_idx), l_opnd);
05543
05544 # ifdef _TRANSFORM_CHAR_SEQUENCE
05545 if (arg_info_list[info_idx].ed.type == Structure &&
05546 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
05547
05548 COPY_OPND(opnd, IR_OPND_L(ir_idx));
05549 transform_char_sequence_ref(&opnd,
05550 arg_info_list[info_idx].ed.type_idx);
05551 COPY_OPND(IR_OPND_L(ir_idx), opnd);
05552
05553 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
05554 }
05555 # endif
05556
05557 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
05558 IR_IDX_R(asg_idx) = ir_idx;
05559
05560 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
05561
05562 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
05563 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
05564
05565
05566 gen_if_stmt(&cond_opnd,
05567 true_start_sh_idx,
05568 true_end_sh_idx,
05569 SH_NEXT_IDX(false_start_sh_idx),
05570 SH_PREV_IDX(false_end_sh_idx),
05571 line,
05572 col);
05573
05574 # if 0
05575 OPND_FLD(opnd) = CN_Tbl_Idx;
05576 OPND_IDX(opnd) = CN_INTEGER_ONE_IDX;
05577 OPND_LINE_NUM(opnd) = line;
05578 OPND_COL_NUM(opnd) = col;
05579
05580 gen_internal_call_stmt("DUMP", &opnd, After);
05581 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05582 # endif
05583
05584
05585
05586 if (SH_NEXT_IDX(true_start_sh_idx2) != true_end_sh_idx2) {
05587 ir_idx = gen_ir(OPND_FLD(dv_opnd), OPND_IDX(dv_opnd),
05588 Dv_Access_A_Contig, CG_INTEGER_DEFAULT_TYPE, line, col,
05589 NO_Tbl_Idx, NULL_IDX);
05590
05591 present_idx = gen_ir(IR_Tbl_Idx, ir_idx,
05592 Ne_Opr, LOGICAL_DEFAULT_TYPE, line, col,
05593 CN_Tbl_Idx, CN_INTEGER_ONE_IDX);
05594
05595 gen_opnd(&cond_opnd,
05596 present_idx,
05597 IR_Tbl_Idx,
05598 line,
05599 col);
05600
05601 gen_if_stmt(&cond_opnd,
05602 SH_NEXT_IDX(true_start_sh_idx2),
05603 SH_PREV_IDX(true_end_sh_idx2),
05604 NULL_IDX,
05605 NULL_IDX,
05606 line,
05607 col);
05608 }
05609
05610
05611
05612 IL_FLD(list_idx) = AT_Tbl_Idx;
05613 IL_IDX(list_idx) = addr_tmp_idx;
05614 IL_LINE_NUM(list_idx) = line;
05615 IL_COL_NUM(list_idx) = col;
05616
05617 break;
05618 }
05619
05620 dummy_idx++;
05621
05622 EXIT:
05623
05624 defer_stmt_expansion = save_defer_stmt_expansion;
05625 COPY_OPND(opnd, IL_OPND(list_idx));
05626 stmt_expansion_control_end(&opnd);
05627 COPY_OPND(IL_OPND(list_idx), opnd);
05628
05629 list_idx = IL_NEXT_LIST_IDX(list_idx);
05630 }
05631
05632 expr_mode = save_expr_mode;
05633
05634 TRACE (Func_Exit, "final_arg_work", NULL);
05635
05636 return(ok);
05637
05638 }
05639
05640
05641
05642
05643
05644
05645
05646
05647
05648
05649
05650
05651
05652
05653
05654
05655
05656
05657 static dummy_arg_type get_dummy_arg_type(int darg_idx)
05658
05659 {
05660 dummy_arg_type d_type = Unknown_Dummy;
05661
05662
05663 TRACE (Func_Entry, "get_dummy_arg_type", NULL);
05664
05665 if (darg_idx != NULL_IDX) {
05666 # ifdef _DEBUG
05667 if (AT_OBJ_CLASS(darg_idx) != Data_Obj) {
05668 PRINTMSG(stmt_start_line, 325, Internal, stmt_start_col);
05669 }
05670 # endif
05671 if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) {
05672
05673 if (ATD_POINTER(darg_idx)) {
05674 d_type = Scalar_Ptr_Dummy;
05675 }
05676 else if (ATD_INTRIN_DARG(darg_idx) &&
05677 ATD_IM_A_DOPE(darg_idx)) {
05678 d_type = Intrin_Dope_Dummy;
05679 }
05680 # if 0
05681
05682
05683
05684 else if (ATD_TARGET(darg_idx)) {
05685 d_type = Scalar_Target_Dummy;
05686 }
05687 # endif
05688 else {
05689 d_type = Scalar_Dummy;
05690 }
05691 }
05692 else {
05693
05694 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(darg_idx)) == Assumed_Shape) {
05695 d_type = Assumed_Shape_Dummy;
05696 }
05697 #ifdef KEY
05698
05699
05700
05701
05702
05703
05704
05705
05706
05707
05708
05709
05710
05711
05712
05713
05714
05715
05716
05717
05718 else if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(darg_idx)) == Deferred_Shape &&
05719 ATD_CLASS(darg_idx) == Dummy_Argument &&
05720 !(ATD_INTRIN_DARG(darg_idx) || ATD_POINTER(darg_idx) ||
05721 ATD_ALLOCATABLE(darg_idx))) {
05722 d_type = Assumed_Shape_Dummy;
05723 }
05724 #endif
05725 else if (ATD_POINTER(darg_idx)) {
05726 d_type = Array_Ptr_Dummy;
05727 }
05728 else if (ATD_INTRIN_DARG(darg_idx) &&
05729 ATD_IM_A_DOPE(darg_idx)) {
05730 d_type = Intrin_Dope_Dummy;
05731 }
05732 # if 0
05733
05734
05735
05736
05737 else if (ATD_TARGET(darg_idx)) {
05738 d_type = Array_Target_Dummy;
05739 }
05740 # endif
05741 else {
05742 d_type = Sequence_Array_Dummy;
05743 }
05744 }
05745 }
05746
05747 TRACE (Func_Exit, "get_dummy_arg_type", NULL);
05748
05749 return(d_type);
05750
05751 }
05752
05753
05754
05755
05756
05757
05758
05759
05760
05761
05762
05763
05764
05765
05766
05767
05768
05769
05770
05771 act_arg_type get_act_arg_type(expr_arg_type *exp_desc)
05772
05773 {
05774 act_arg_type a_type;
05775
05776 TRACE (Func_Entry, "get_act_arg_type", NULL);
05777
05778 if (exp_desc->rank == 0) {
05779
05780 #ifdef KEY
05781
05782
05783
05784
05785 #endif
05786 if (exp_desc->pointer) {
05787 if (exp_desc->tmp_reference) {
05788 a_type = Scalar_Tmp_Ptr;
05789 }
05790 else {
05791 a_type = Scalar_Ptr;
05792 }
05793 }
05794 else if (exp_desc->constant) {
05795 if (exp_desc->tmp_reference) {
05796 a_type = Scalar_Tmp_Var;
05797 }
05798 else {
05799 a_type = Scalar_Constant;
05800 }
05801 }
05802 else if (exp_desc->reference) {
05803
05804 if (exp_desc->array_elt) {
05805 if (exp_desc->tmp_reference) {
05806 a_type = Array_Tmp_Elt;
05807 }
05808 else {
05809 a_type = Array_Elt;
05810 }
05811 }
05812 else if (exp_desc->has_symbolic) {
05813 a_type = Scalar_Expression;
05814 }
05815 else {
05816 if (exp_desc->tmp_reference) {
05817 a_type = Scalar_Tmp_Var;
05818 }
05819 else {
05820 a_type = Scalar_Var;
05821 }
05822 }
05823 }
05824 else if (exp_desc->tmp_reference) {
05825 if (exp_desc->dope_vector) {
05826 a_type = Scalar_Tmp_Ptr;
05827 }
05828 else {
05829 a_type = Scalar_Tmp_Var;
05830 }
05831 }
05832 else {
05833 a_type = Scalar_Expression;
05834 }
05835 }
05836 else {
05837
05838 if (exp_desc->constant) {
05839 if (exp_desc->section) {
05840 a_type = Constant_Array_Section;
05841 }
05842 else if (exp_desc->tmp_reference) {
05843 a_type = Whole_Tmp_Sequence;
05844 }
05845 else {
05846 a_type = Whole_Array_Constant;
05847 }
05848 }
05849 else if (exp_desc->pointer) {
05850 if (exp_desc->tmp_reference) {
05851 a_type = Array_Tmp_Ptr;
05852 }
05853 else {
05854 a_type = Array_Ptr;
05855 }
05856 }
05857 else if (exp_desc->reference) {
05858
05859 if (exp_desc->vector_subscript) {
05860 a_type = Vector_Subscript_Section;
05861 }
05862 else if (exp_desc->section) {
05863
05864 if (exp_desc->contig_array) {
05865 if (exp_desc->dope_vector) {
05866 a_type = Dv_Contig_Section;
05867 }
05868 else {
05869 a_type = Contig_Section;
05870 }
05871 }
05872 else if (exp_desc->dope_vector) {
05873 a_type = Dv_Array_Section;
05874 }
05875 else {
05876 a_type = Sequence_Array_Section;
05877 }
05878 }
05879 else if (exp_desc->allocatable) {
05880 if (exp_desc->tmp_reference) {
05881 a_type = Whole_Tmp_Allocatable;
05882 }
05883 else {
05884 a_type = Whole_Allocatable;
05885 }
05886 }
05887 else if (exp_desc->assumed_shape) {
05888 a_type = Whole_Ass_Shape;
05889 }
05890 else {
05891 if (exp_desc->tmp_reference) {
05892 a_type = Whole_Tmp_Sequence;
05893 }
05894 else {
05895 a_type = Whole_Sequence;
05896 }
05897 }
05898 }
05899 else if (exp_desc->tmp_reference) {
05900 if (exp_desc->allocatable) {
05901 a_type = Whole_Tmp_Allocatable;
05902 }
05903 else if (exp_desc->dope_vector) {
05904
05905
05906
05907
05908 a_type = Array_Tmp_Ptr;
05909 }
05910 else {
05911 a_type = Whole_Tmp_Sequence;
05912 }
05913 }
05914 else {
05915 a_type = Array_Expr;
05916 }
05917 }
05918
05919 TRACE (Func_Exit, "get_act_arg_type", NULL);
05920
05921 return(a_type);
05922
05923 }
05924
05925
05926
05927
05928
05929
05930
05931
05932
05933
05934
05935
05936
05937
05938
05939
05940
05941
05942
05943
05944
05945
05946
05947
05948
05949 int create_tmp_asg(opnd_type *r_opnd,
05950 expr_arg_type *exp_desc,
05951 opnd_type *left_opnd,
05952 int intent,
05953 boolean stmt_tmp,
05954 boolean save_where_dealloc_stmt)
05955 #if KEY
05956 {
05957 return common_create_tmp_asg(r_opnd, exp_desc, left_opnd, intent,
05958 stmt_tmp, save_where_dealloc_stmt, FALSE);
05959 }
05960
05961
05962
05963
05964 int
05965 create_tmp_asg_or_call(opnd_type *r_opnd, expr_arg_type *exp_desc,
05966 opnd_type *left_opnd, int intent, boolean stmt_tmp,
05967 boolean save_where_dealloc_stmt, int info_idx, dummy_arg_type a_type,
05968 dummy_arg_type d_type) {
05969
05970
05971
05972
05973
05974
05975
05976
05977
05978
05979
05980
05981
05982 boolean call = arg_info_list[info_idx].ed.rank &&
05983 (!arg_info_list[info_idx].ed.section) &&
05984 arg_info_list[info_idx].ed.type != Structure &&
05985 (a_type == Whole_Ass_Shape || a_type == Array_Ptr) &&
05986 (d_type == Unknown_Dummy || d_type == Sequence_Array_Dummy);
05987
05988 #ifdef _DEBUG
05989 runtime_copyinout_count += !!call;
05990 #endif
05991
05992 return common_create_tmp_asg(r_opnd, exp_desc, left_opnd, intent,
05993 stmt_tmp, save_where_dealloc_stmt, call);
05994 }
05995
05996
05997
05998
05999 static int
06000 common_create_tmp_asg(opnd_type *r_opnd, expr_arg_type *exp_desc,
06001 opnd_type *left_opnd, int intent, boolean stmt_tmp,
06002 boolean save_where_dealloc_stmt, boolean call)
06003 #endif
06004 {
06005 int alloc_idx;
06006 int asg_idx;
06007 int base_asg_idx;
06008 int base_tmp_idx;
06009 int bd_idx;
06010 int col;
06011 boolean constant_shape = TRUE;
06012 int dealloc_idx = NULL_IDX;
06013 int ir_idx;
06014 int line;
06015 int list_idx;
06016 int max_idx;
06017 boolean ok = TRUE;
06018 opnd_type opnd;
06019 int save_curr_stmt_sh_idx;
06020 boolean save_defer_stmt_expansion;
06021 opnd_type size_opnd;
06022 int tmp_idx;
06023 int true_start_sh_idx;
06024 int true_end_sh_idx;
06025
06026
06027 TRACE (Func_Entry, "common_create_tmp_asg", NULL);
06028
06029 find_opnd_line_and_column(r_opnd, &line, &col);
06030
06031 # ifdef _DEBUG
06032 if (defer_stmt_expansion &&
06033 alloc_block_start_idx &&
06034 save_where_dealloc_stmt) {
06035 PRINTMSG(line, 626, Internal, col,
06036 "no defer_stmt_expansion", "create_tmp_asg");
06037 }
06038
06039 if (orig_sh_idx != NULL_IDX &&
06040 alloc_block_start_idx &&
06041 save_where_dealloc_stmt) {
06042 PRINTMSG(line, 626, Internal, col,
06043 "no orig_sh_idx", "create_tmp_asg");
06044 }
06045 # endif
06046
06047 stmt_expansion_control_start();
06048 save_defer_stmt_expansion = defer_stmt_expansion;
06049 defer_stmt_expansion = FALSE;
06050
06051 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
06052
06053 if (alloc_block_start_idx &&
06054 save_where_dealloc_stmt) {
06055 curr_stmt_sh_idx = alloc_block_start_idx;
06056 }
06057
06058 if (exp_desc->rank) {
06059 constant_shape = gen_bd_entry(r_opnd, exp_desc, &bd_idx, line, col);
06060 }
06061 else if (exp_desc->type == Character) {
06062 ok = validate_char_len(r_opnd, exp_desc);
06063
06064 if (TYP_FLD(exp_desc->type_idx) != CN_Tbl_Idx) {
06065 constant_shape = FALSE;
06066 }
06067 }
06068
06069 tmp_idx = NULL_IDX;
06070
06071 if (stmt_tmp &&
06072 constant_shape) {
06073 tmp_idx = get_stmt_tmp(exp_desc->type_idx,
06074 FALSE,
06075 exp_desc->rank);
06076 }
06077
06078
06079
06080 #ifdef KEY
06081 int copyin_dest = NULL_IDX;
06082 fld_type copyin_fld;
06083 int copyin_src = get_variable_reference(r_opnd, ©in_fld);
06084 if (NULL_IDX == copyin_src) {
06085 call = FALSE;
06086 }
06087 if (call) {
06088
06089
06090
06091 if (NULL_IDX == tmp_idx) {
06092 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
06093 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
06094 ATD_TYPE_IDX(tmp_idx) = exp_desc->type_idx;
06095
06096 ATD_FLD(tmp_idx) = IR_Tbl_Idx;
06097 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
06098 AT_DEFINED(tmp_idx) = TRUE;
06099 }
06100 copyin_dest = tmp_idx;
06101 asg_idx = build_copyinout_call(Copyin_Attr_Idx, COPYIN_ENTRY,
06102 AT_Tbl_Idx, copyin_dest, copyin_fld, copyin_src, line, col);
06103 }
06104 else {
06105 #endif
06106 if (tmp_idx) {
06107 NTR_IR_TBL(asg_idx);
06108 IR_OPR(asg_idx) = Asg_Opr;
06109
06110 IR_TYPE_IDX(asg_idx) = exp_desc->type_idx;
06111 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
06112 IR_IDX_L(asg_idx) = tmp_idx;
06113 IR_LINE_NUM_L(asg_idx) = line;
06114 IR_LINE_NUM(asg_idx) = line;
06115 IR_COL_NUM_L(asg_idx) = col;
06116 IR_COL_NUM(asg_idx) = col;
06117 ATD_TMP_IDX(tmp_idx) = asg_idx;
06118 ATD_FLD(tmp_idx) = IR_Tbl_Idx;
06119 AT_DEFINED(tmp_idx) = TRUE;
06120 }
06121 else {
06122 GEN_COMPILER_TMP_ASG(asg_idx,
06123 tmp_idx,
06124 TRUE,
06125 line,
06126 col,
06127 exp_desc->type_idx,
06128 Priv);
06129 }
06130 #ifdef KEY
06131 }
06132 #endif
06133
06134 ATD_ASG_TMP(tmp_idx) = TRUE;
06135
06136 if (!constant_shape) {
06137 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_BASED_IDX(curr_scp_idx);
06138 }
06139
06140 if (exp_desc->rank) {
06141
06142 if (! constant_shape) {
06143
06144
06145
06146 OPND_FLD(size_opnd) = BD_LEN_FLD(bd_idx);
06147 OPND_IDX(size_opnd) = BD_LEN_IDX(bd_idx);
06148 OPND_LINE_NUM(size_opnd) = line;
06149 OPND_COL_NUM(size_opnd) = col;
06150 }
06151
06152 ATD_ARRAY_IDX(tmp_idx) = bd_idx;
06153 }
06154 else if (! constant_shape) {
06155
06156
06157
06158 OPND_FLD(size_opnd) = CN_Tbl_Idx;
06159 OPND_IDX(size_opnd) = CN_INTEGER_ONE_IDX;
06160 OPND_LINE_NUM(size_opnd) = line;
06161 OPND_COL_NUM(size_opnd) = col;
06162 }
06163
06164
06165
06166 #ifdef KEY
06167 if (!call) {
06168 #endif
06169 COPY_OPND((*left_opnd), IR_OPND_L(asg_idx));
06170
06171 if (exp_desc->rank) {
06172 ok = gen_whole_subscript(left_opnd, exp_desc);
06173 }
06174 else if (exp_desc->type == Character) {
06175 ok = gen_whole_substring(left_opnd, 0);
06176 }
06177
06178 COPY_OPND(IR_OPND_L(asg_idx), (*left_opnd));
06179
06180
06181 IR_RANK(asg_idx) = exp_desc->rank;
06182 #ifdef KEY
06183 }
06184 #endif
06185
06186 if (! constant_shape) {
06187
06188
06189 ATD_AUTOMATIC(tmp_idx) = TRUE;
06190
06191 GEN_COMPILER_TMP_ASG(base_asg_idx,
06192 base_tmp_idx,
06193 TRUE,
06194 line,
06195 col,
06196 SA_INTEGER_DEFAULT_TYPE,
06197 Priv);
06198
06199 ATD_AUTO_BASE_IDX(tmp_idx) = base_tmp_idx;
06200
06201 determine_tmp_size(&size_opnd, exp_desc->type_idx);
06202
06203 NTR_IR_TBL(max_idx);
06204 IR_OPR(max_idx) = Max_Opr;
06205 IR_TYPE_IDX(max_idx) = SA_INTEGER_DEFAULT_TYPE;
06206 IR_LINE_NUM(max_idx) = line;
06207 IR_COL_NUM(max_idx) = col;
06208 IR_FLD_L(max_idx) = IL_Tbl_Idx;
06209 IR_LIST_CNT_L(max_idx) = 2;
06210
06211 NTR_IR_LIST_TBL(list_idx);
06212 IR_IDX_L(max_idx) = list_idx;
06213
06214 IL_FLD(list_idx) = CN_Tbl_Idx;
06215 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
06216 IL_LINE_NUM(list_idx) = line;
06217 IL_COL_NUM(list_idx) = col;
06218
06219 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
06220 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
06221 list_idx = IL_NEXT_LIST_IDX(list_idx);
06222
06223 COPY_OPND(IL_OPND(list_idx), size_opnd);
06224
06225 OPND_FLD(size_opnd) = IR_Tbl_Idx;
06226 OPND_IDX(size_opnd) = max_idx;
06227
06228
06229 NTR_IR_TBL(alloc_idx);
06230 IR_OPR(alloc_idx) = Alloc_Opr;
06231 IR_TYPE_IDX(alloc_idx) = TYPELESS_DEFAULT_TYPE;
06232 IR_LINE_NUM(alloc_idx) = line;
06233 IR_COL_NUM(alloc_idx) = col;
06234 COPY_OPND(IR_OPND_L(alloc_idx), size_opnd);
06235 IR_FLD_R(base_asg_idx) = IR_Tbl_Idx;
06236 IR_IDX_R(base_asg_idx) = alloc_idx;
06237
06238 gen_sh(Before, Assignment_Stmt, line,
06239 col, FALSE, FALSE, TRUE);
06240
06241 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = base_asg_idx;
06242 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06243
06244
06245 NTR_IR_TBL(dealloc_idx);
06246 IR_OPR(dealloc_idx) = Dealloc_Opr;
06247 IR_TYPE_IDX(dealloc_idx) = TYPELESS_DEFAULT_TYPE;
06248 IR_LINE_NUM(dealloc_idx) = line;
06249 IR_COL_NUM(dealloc_idx) = col;
06250 COPY_OPND(IR_OPND_L(dealloc_idx), IR_OPND_L(base_asg_idx));
06251
06252 if (save_where_dealloc_stmt) {
06253
06254 if (alloc_block_start_idx) {
06255 curr_stmt_sh_idx = alloc_block_end_idx;
06256 gen_sh(After, Assignment_Stmt, line,
06257 col, FALSE, FALSE, TRUE);
06258
06259 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx;
06260 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06261 }
06262 else {
06263 where_dealloc_stmt_idx = ntr_sh_tbl();
06264 SH_STMT_TYPE(where_dealloc_stmt_idx) = Assignment_Stmt;
06265 SH_GLB_LINE(where_dealloc_stmt_idx) = line;
06266 SH_COL_NUM(where_dealloc_stmt_idx) = col;
06267 SH_COMPILER_GEN(where_dealloc_stmt_idx) = TRUE;
06268 SH_P2_SKIP_ME(where_dealloc_stmt_idx) = TRUE;
06269
06270 SH_IR_IDX(where_dealloc_stmt_idx) = dealloc_idx;
06271 }
06272 }
06273 else if (orig_sh_idx != NULL_IDX) {
06274 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
06275 curr_stmt_sh_idx = orig_sh_idx;
06276
06277 if (contig_test_ir_idx != NULL_IDX) {
06278
06279 true_start_sh_idx = curr_stmt_sh_idx;
06280 true_end_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
06281
06282
06283
06284 gen_opnd(&opnd, contig_test_ir_idx, IR_Tbl_Idx, line, col);
06285 copy_subtree(&opnd, &opnd);
06286 ir_idx = OPND_IDX(opnd);
06287 IR_OPR(ir_idx) = Ne_Opr;
06288
06289
06290
06291 gen_sh(After, Assignment_Stmt, line,
06292 col, FALSE, FALSE, TRUE);
06293
06294 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx;
06295 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06296
06297
06298 gen_if_stmt(&opnd,
06299 SH_NEXT_IDX(true_start_sh_idx),
06300 SH_PREV_IDX(true_end_sh_idx),
06301 NULL_IDX,
06302 NULL_IDX,
06303 line,
06304 col);
06305
06306 }
06307 else {
06308 gen_sh(After, Assignment_Stmt, line,
06309 col, FALSE, FALSE, TRUE);
06310
06311 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx;
06312 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06313 }
06314
06315 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
06316 }
06317 else {
06318 gen_sh(After, Assignment_Stmt, line,
06319 col, FALSE, FALSE, TRUE);
06320
06321 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx;
06322 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06323
06324 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
06325 }
06326 }
06327
06328 if (alloc_block_start_idx &&
06329 save_where_dealloc_stmt) {
06330 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
06331 }
06332
06333 #ifdef KEY
06334 if (!call) {
06335 #endif
06336 COPY_OPND(IR_OPND_R(asg_idx), (*r_opnd));
06337
06338 # ifdef _TRANSFORM_CHAR_SEQUENCE
06339 if (exp_desc->type == Structure &&
06340 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
06341
06342 COPY_OPND(opnd, IR_OPND_L(asg_idx));
06343 transform_char_sequence_ref(&opnd, exp_desc->type_idx);
06344 COPY_OPND(IR_OPND_L(asg_idx), opnd);
06345
06346 COPY_OPND(opnd, IR_OPND_R(asg_idx));
06347 transform_char_sequence_ref(&opnd, exp_desc->type_idx);
06348 COPY_OPND(IR_OPND_R(asg_idx), opnd);
06349 }
06350 # endif
06351 #ifdef KEY
06352 }
06353 #endif
06354
06355 if (intent == Intent_In || intent == Intent_Inout) {
06356 #ifdef KEY
06357 gen_sh(Before, call ? Call_Stmt : Assignment_Stmt, line, col, FALSE,
06358 FALSE, TRUE);
06359 #else
06360 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06361 #endif
06362
06363 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
06364 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06365 }
06366
06367 if (intent == Intent_Out || intent == Intent_Inout) {
06368
06369 #ifdef KEY
06370 if (call) {
06371 asg_idx = build_copyinout_call(Copyout_Attr_Idx, COPYOUT_ENTRY,
06372 copyin_fld, copyin_src,
06373 AT_Tbl_Idx, copyin_dest, line, col);
06374 gen_sh(After, Call_Stmt, stmt_start_line,
06375 stmt_start_col, FALSE, FALSE, TRUE);
06376 }
06377 else {
06378 #endif
06379 NTR_IR_TBL(asg_idx);
06380 IR_OPR(asg_idx) = Asg_Opr;
06381 IR_TYPE_IDX(asg_idx) = exp_desc->type_idx;
06382 IR_LINE_NUM(asg_idx) = line;
06383 IR_COL_NUM(asg_idx) = col;
06384 IR_RANK(asg_idx) = exp_desc->rank;
06385 COPY_OPND(IR_OPND_R(asg_idx), (*left_opnd));
06386 COPY_OPND(IR_OPND_L(asg_idx), (*r_opnd));
06387
06388 gen_sh(After, Assignment_Stmt, stmt_start_line,
06389 stmt_start_col, FALSE, FALSE, TRUE);
06390 #ifdef KEY
06391 }
06392 #endif
06393
06394 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
06395 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06396 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
06397 }
06398
06399
06400
06401 exp_desc->constant = FALSE;
06402 exp_desc->foldable = FALSE;
06403 exp_desc->will_fold_later = FALSE;
06404
06405 exp_desc->tmp_reference = TRUE;
06406 exp_desc->section = FALSE;
06407
06408 if (exp_desc->rank > 0) {
06409 exp_desc->contig_array = TRUE;
06410 }
06411
06412 defer_stmt_expansion = save_defer_stmt_expansion;
06413 stmt_expansion_control_end(left_opnd);
06414
06415 TRACE (Func_Exit, "common_create_tmp_asg", NULL);
06416
06417 return(tmp_idx);
06418
06419 }
06420
06421
06422
06423
06424
06425
06426
06427
06428
06429
06430
06431
06432
06433
06434
06435
06436
06437 boolean gen_bd_entry(opnd_type *r_opnd,
06438 expr_arg_type *exp_desc,
06439 int *res_bd_idx,
06440 int line,
06441 int col)
06442
06443 {
06444 int attr_idx;
06445 int bd_idx;
06446 int br_idx;
06447 int ch_asg_idx;
06448 boolean constant_shape = TRUE;
06449 int ir_idx;
06450 #ifdef KEY
06451 int label_idx = 0;
06452 #else
06453 int label_idx;
06454 #endif
06455 expr_arg_type loc_exp_desc;
06456 int i;
06457 int minus_idx;
06458 int mult_idx;
06459 opnd_type num_el_opnd;
06460 boolean ok = TRUE;
06461 opnd_type opnd;
06462 int plus_idx;
06463 expr_mode_type save_expr_mode;
06464 cif_usage_code_type save_xref_state;
06465 opnd_type sm_opnd;
06466 size_offset_type stride;
06467 int tmp_idx;
06468
06469
06470 TRACE (Func_Entry, "gen_bd_entry", NULL);
06471
06472 bd_idx = reserve_array_ntry(exp_desc->rank);
06473 BD_RESOLVED(bd_idx) = TRUE;
06474
06475 for (i = 1; i <= exp_desc->rank; i++) {
06476
06477 if (shared_bd_idx != NULL_IDX) {
06478
06479
06480
06481
06482 constant_shape = FALSE;
06483
06484 # ifdef _DEBUG
06485 if (r_opnd == NULL) {
06486 PRINTMSG(line, 626, Internal, col, "r_opnd", "gen_bd_entry");
06487 }
06488 # endif
06489 attr_idx = find_left_attr(r_opnd);
06490
06491 BD_LB_FLD(bd_idx,i) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),i);
06492 BD_LB_IDX(bd_idx,i) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),i);
06493
06494
06495
06496 if (shared_bd_idx < 0) {
06497
06498 if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx &&
06499 ATD_CLASS(OPND_IDX(exp_desc->shape[i-1])) == Compiler_Tmp) {
06500
06501 BD_XT_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]);
06502 BD_XT_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]);
06503 }
06504 else {
06505
06506 GEN_COMPILER_TMP_ASG(ch_asg_idx,
06507 tmp_idx,
06508 TRUE,
06509 line,
06510 col,
06511 CG_INTEGER_DEFAULT_TYPE,
06512 Priv);
06513
06514 IR_FLD_R(ch_asg_idx) = OPND_FLD(exp_desc->shape[i-1]);
06515 IR_IDX_R(ch_asg_idx) = OPND_IDX(exp_desc->shape[i-1]);
06516 IR_LINE_NUM_R(ch_asg_idx) = line;
06517 IR_COL_NUM_R(ch_asg_idx) = col;
06518
06519 if (reassign_XT_temps) {
06520
06521
06522 label_idx = gen_internal_lbl(line);
06523
06524 NTR_IR_TBL(br_idx);
06525 IR_OPR(br_idx) = Br_True_Opr;
06526 IR_TYPE_IDX(br_idx) = LOGICAL_DEFAULT_TYPE;
06527 IR_LINE_NUM(br_idx) = line;
06528 IR_COL_NUM(br_idx) = col;
06529
06530 NTR_IR_TBL(ir_idx);
06531 IR_OPR(ir_idx) = Ge_Opr;
06532 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE;
06533 IR_LINE_NUM(ir_idx) = line;
06534 IR_COL_NUM(ir_idx) = col;
06535
06536 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
06537 IR_IDX_L(ir_idx) = tmp_idx;
06538 IR_LINE_NUM_L(ir_idx) = line;
06539 IR_COL_NUM_L(ir_idx) = col;
06540
06541 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
06542 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
06543 IR_LINE_NUM_R(ir_idx) = line;
06544 IR_COL_NUM_R(ir_idx) = col;
06545
06546 IR_FLD_L(br_idx) = IR_Tbl_Idx;
06547 IR_IDX_L(br_idx) = ir_idx;
06548 IR_FLD_R(br_idx) = AT_Tbl_Idx;
06549 IR_IDX_R(br_idx) = label_idx;
06550 IR_LINE_NUM_R(br_idx) = line;
06551 IR_COL_NUM_R(br_idx) = col;
06552
06553 gen_sh(Before, If_Stmt, line,
06554 col, FALSE, FALSE, TRUE);
06555
06556 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_idx;
06557 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06558 }
06559
06560
06561
06562 gen_sh(Before, Assignment_Stmt, line,
06563 col , FALSE, FALSE, TRUE);
06564
06565 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx;
06566 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06567
06568 gen_copyin_bounds_stmt(tmp_idx);
06569
06570 if (reassign_XT_temps) {
06571
06572
06573 NTR_IR_TBL(ir_idx);
06574 IR_OPR(ir_idx) = Label_Opr;
06575 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
06576 IR_LINE_NUM(ir_idx) = line;
06577 IR_COL_NUM(ir_idx) = col;
06578 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
06579 IR_IDX_L(ir_idx) = label_idx;
06580 IR_COL_NUM_L(ir_idx) = col;
06581 IR_LINE_NUM_L(ir_idx) = line;
06582
06583 AT_DEFINED(label_idx) = TRUE;
06584
06585 gen_sh(Before, Continue_Stmt, line, col,
06586 FALSE, FALSE, TRUE);
06587 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06588 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
06589
06590 ATL_DEF_STMT_IDX(label_idx)=SH_PREV_IDX(curr_stmt_sh_idx);
06591 }
06592
06593 BD_XT_FLD(bd_idx, i) = AT_Tbl_Idx;
06594 BD_XT_IDX(bd_idx, i) = tmp_idx;
06595 OPND_FLD(exp_desc->shape[i-1]) = AT_Tbl_Idx;
06596 OPND_IDX(exp_desc->shape[i-1]) = tmp_idx;
06597 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE;
06598 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE;
06599 }
06600 }
06601 else {
06602
06603 BD_XT_FLD(bd_idx,i) = BD_XT_FLD(shared_bd_idx,i);
06604 BD_XT_IDX(bd_idx,i) = BD_XT_IDX(shared_bd_idx,i);
06605
06606 if (reassign_XT_temps) {
06607
06608
06609
06610
06611 label_idx = gen_internal_lbl(line);
06612
06613 NTR_IR_TBL(br_idx);
06614 IR_OPR(br_idx) = Br_True_Opr;
06615 IR_TYPE_IDX(br_idx) = LOGICAL_DEFAULT_TYPE;
06616 IR_LINE_NUM(br_idx) = line;
06617 IR_COL_NUM(br_idx) = col;
06618
06619 NTR_IR_TBL(ir_idx);
06620 IR_OPR(ir_idx) = Ge_Opr;
06621 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE;
06622 IR_LINE_NUM(ir_idx) = line;
06623 IR_COL_NUM(ir_idx) = col;
06624
06625 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
06626 IR_IDX_L(ir_idx) = BD_XT_IDX(bd_idx,i);
06627 IR_LINE_NUM_L(ir_idx) = line;
06628 IR_COL_NUM_L(ir_idx) = col;
06629
06630 IR_FLD_R(ir_idx) = CN_Tbl_Idx;
06631 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
06632 IR_LINE_NUM_R(ir_idx) = line;
06633 IR_COL_NUM_R(ir_idx) = col;
06634
06635 IR_FLD_L(br_idx) = IR_Tbl_Idx;
06636 IR_IDX_L(br_idx) = ir_idx;
06637 IR_FLD_R(br_idx) = AT_Tbl_Idx;
06638 IR_IDX_R(br_idx) = label_idx;
06639 IR_LINE_NUM_R(br_idx) = line;
06640 IR_COL_NUM_R(br_idx) = col;
06641
06642 gen_sh(Before, If_Stmt, line,
06643 col, FALSE, FALSE, TRUE);
06644
06645 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_idx;
06646 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06647
06648
06649
06650 NTR_IR_TBL(ch_asg_idx);
06651 IR_OPR(ch_asg_idx) = Asg_Opr;
06652 IR_TYPE_IDX(ch_asg_idx) = ATD_TYPE_IDX(BD_XT_IDX(bd_idx,i));
06653 IR_LINE_NUM(ch_asg_idx) = line;
06654 IR_COL_NUM(ch_asg_idx) = col;
06655 IR_LINE_NUM_L(ch_asg_idx) = line;
06656 IR_COL_NUM_L(ch_asg_idx) = col;
06657
06658 IR_FLD_L(ch_asg_idx) = AT_Tbl_Idx;
06659 IR_IDX_L(ch_asg_idx) = BD_XT_IDX(bd_idx,i);
06660
06661 IR_FLD_R(ch_asg_idx) = OPND_FLD(exp_desc->shape[i-1]);
06662 IR_IDX_R(ch_asg_idx) = OPND_IDX(exp_desc->shape[i-1]);
06663 IR_LINE_NUM_R(ch_asg_idx) = line;
06664 IR_COL_NUM_R(ch_asg_idx) = col;
06665
06666 gen_sh(Before, Assignment_Stmt, line,
06667 col, FALSE, FALSE, TRUE);
06668
06669 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx;
06670 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06671
06672 gen_copyin_bounds_stmt(BD_XT_IDX(bd_idx,i));
06673
06674
06675
06676 NTR_IR_TBL(ir_idx);
06677 IR_OPR(ir_idx) = Label_Opr;
06678 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
06679 IR_LINE_NUM(ir_idx) = line;
06680 IR_COL_NUM(ir_idx) = col;
06681 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
06682 IR_IDX_L(ir_idx) = label_idx;
06683 IR_COL_NUM_L(ir_idx) = col;
06684 IR_LINE_NUM_L(ir_idx) = line;
06685
06686 AT_DEFINED(label_idx) = TRUE;
06687
06688 gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
06689 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06690 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
06691
06692 ATL_DEF_STMT_IDX(label_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
06693 }
06694 }
06695
06696
06697
06698 if (BD_LB_FLD(bd_idx, i) == CN_Tbl_Idx &&
06699 compare_cn_and_value(BD_LB_IDX(bd_idx, i), 1L, Eq_Opr)) {
06700
06701 BD_UB_FLD(bd_idx,i) = BD_XT_FLD(bd_idx,i);
06702 BD_UB_IDX(bd_idx,i) = BD_XT_IDX(bd_idx,i);
06703 }
06704 else {
06705 NTR_IR_TBL(plus_idx);
06706 IR_OPR(plus_idx) = Plus_Opr;
06707 IR_LINE_NUM(plus_idx) = line;
06708 IR_COL_NUM(plus_idx) = col;
06709 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE;
06710 IR_FLD_R(plus_idx) = BD_XT_FLD(bd_idx,i);
06711 IR_IDX_R(plus_idx) = BD_XT_IDX(bd_idx,i);
06712 IR_LINE_NUM_R(plus_idx) = line;
06713 IR_COL_NUM_R(plus_idx) = col;
06714
06715 NTR_IR_TBL(minus_idx);
06716 IR_OPR(minus_idx) = Minus_Opr;
06717 IR_LINE_NUM(minus_idx) = line;
06718 IR_COL_NUM(minus_idx) = col;
06719 IR_TYPE_IDX(minus_idx) = SA_INTEGER_DEFAULT_TYPE;
06720 IR_FLD_L(minus_idx) = BD_LB_FLD(bd_idx,i);
06721 IR_IDX_L(minus_idx) = BD_LB_IDX(bd_idx,i);
06722 IR_LINE_NUM_L(minus_idx) = line;
06723 IR_COL_NUM_L(minus_idx) = col;
06724 IR_FLD_R(minus_idx) = CN_Tbl_Idx;
06725 IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX;
06726 IR_LINE_NUM_R(minus_idx) = line;
06727 IR_COL_NUM_R(minus_idx) = col;
06728
06729 if (BD_LB_FLD(bd_idx, i) == CN_Tbl_Idx) {
06730 OPND_FLD(opnd) = IR_Tbl_Idx;
06731 OPND_IDX(opnd) = minus_idx;
06732
06733 save_xref_state = xref_state;
06734 xref_state = CIF_No_Usage_Rec;
06735 save_expr_mode = expr_mode;
06736 expr_mode = Regular_Expr;
06737
06738 loc_exp_desc.rank = 0;
06739 ok = expr_semantics(&opnd, &loc_exp_desc);
06740 xref_state = save_xref_state;
06741 expr_mode = save_expr_mode;
06742
06743 COPY_OPND(IR_OPND_L(plus_idx), opnd);
06744 }
06745 else {
06746 IR_FLD_L(plus_idx) = IR_Tbl_Idx;
06747 IR_IDX_L(plus_idx) = minus_idx;
06748 }
06749
06750 GEN_COMPILER_TMP_ASG(ch_asg_idx,
06751 tmp_idx,
06752 TRUE,
06753 line,
06754 col,
06755 SA_INTEGER_DEFAULT_TYPE,
06756 Priv);
06757
06758 IR_FLD_R(ch_asg_idx) = IR_Tbl_Idx;
06759 IR_IDX_R(ch_asg_idx) = plus_idx;
06760 IR_LINE_NUM_R(ch_asg_idx) = line;
06761 IR_COL_NUM_R(ch_asg_idx) = col;
06762
06763 gen_sh(Before, Assignment_Stmt, line,
06764 col, FALSE, FALSE, TRUE);
06765
06766 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx;
06767 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06768
06769 gen_copyin_bounds_stmt(tmp_idx);
06770
06771 BD_UB_FLD(bd_idx, i) = AT_Tbl_Idx;
06772 BD_UB_IDX(bd_idx, i) = tmp_idx;
06773 }
06774 }
06775 else {
06776
06777 BD_LB_FLD(bd_idx,i) = CN_Tbl_Idx;
06778 BD_LB_IDX(bd_idx,i) = CN_INTEGER_ONE_IDX;
06779
06780 if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx) {
06781 BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]);
06782 BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]);
06783 }
06784 else {
06785 constant_shape = FALSE;
06786
06787 if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx &&
06788 ATD_CLASS(OPND_IDX(exp_desc->shape[i-1])) == Compiler_Tmp) {
06789
06790 BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]);
06791 BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]);
06792 }
06793 else {
06794 GEN_COMPILER_TMP_ASG(ch_asg_idx,
06795 tmp_idx,
06796 TRUE,
06797 line,
06798 col,
06799 SA_INTEGER_DEFAULT_TYPE,
06800 Priv);
06801
06802 IR_FLD_R(ch_asg_idx) = OPND_FLD(exp_desc->shape[i-1]);
06803 IR_IDX_R(ch_asg_idx) = OPND_IDX(exp_desc->shape[i-1]);
06804 IR_LINE_NUM_R(ch_asg_idx) = line;
06805 IR_COL_NUM_R(ch_asg_idx) = col;
06806
06807 gen_sh(Before, Assignment_Stmt, line,
06808 col, FALSE, FALSE, TRUE);
06809
06810 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx;
06811 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06812
06813 gen_copyin_bounds_stmt(tmp_idx);
06814
06815 BD_UB_FLD(bd_idx, i) = AT_Tbl_Idx;
06816 BD_UB_IDX(bd_idx, i) = tmp_idx;
06817 OPND_FLD(exp_desc->shape[i-1]) = AT_Tbl_Idx;
06818 OPND_IDX(exp_desc->shape[i-1]) = tmp_idx;
06819 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE;
06820 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE;
06821 }
06822 }
06823
06824 BD_XT_FLD(bd_idx,i) = BD_UB_FLD(bd_idx,i);
06825 BD_XT_IDX(bd_idx,i) = BD_UB_IDX(bd_idx,i);
06826 }
06827
06828 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
06829 if (BD_UB_FLD(bd_idx,i) == AT_Tbl_Idx &&
06830 AT_OBJ_CLASS(BD_UB_IDX(bd_idx,i)) == Data_Obj &&
06831 ATD_CLASS(BD_UB_IDX(bd_idx,i)) == Compiler_Tmp &&
06832 ATD_TASK_PRIVATE(BD_UB_IDX(bd_idx,i))) {
06833
06834
06835
06836
06837
06838
06839 gen_temp_init(BD_UB_IDX(bd_idx,i),
06840 CN_INTEGER_ONE_IDX);
06841 }
06842 # endif
06843 }
06844
06845 if (exp_desc->type == Character &&
06846 r_opnd != NULL) {
06847 ok = validate_char_len(r_opnd, exp_desc);
06848 }
06849
06850 if (exp_desc->type == Character &&
06851 TYP_FLD(exp_desc->type_idx) != CN_Tbl_Idx) {
06852 constant_shape = FALSE;
06853 }
06854
06855 BD_RANK(bd_idx) = exp_desc->rank;
06856 BD_LINE_NUM(bd_idx) = line;
06857 BD_COLUMN_NUM(bd_idx) = col;
06858
06859 determine_num_elements(&num_el_opnd, exp_desc, line, col);
06860
06861 loc_exp_desc.rank = 0;
06862 save_xref_state = xref_state;
06863 xref_state = CIF_No_Usage_Rec;
06864
06865 ok = expr_semantics(&num_el_opnd, &loc_exp_desc);
06866
06867 xref_state = save_xref_state;
06868
06869 if (loc_exp_desc.constant) {
06870 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx;
06871 BD_LEN_IDX(bd_idx) = OPND_IDX(num_el_opnd);
06872 }
06873 else if (OPND_FLD(num_el_opnd) == AT_Tbl_Idx &&
06874 ATD_CLASS(OPND_IDX(num_el_opnd)) == Compiler_Tmp) {
06875 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx;
06876 BD_LEN_IDX(bd_idx) = OPND_IDX(num_el_opnd);
06877 }
06878 else {
06879
06880 GEN_COMPILER_TMP_ASG(ch_asg_idx,
06881 tmp_idx,
06882 TRUE,
06883 line,
06884 col,
06885 loc_exp_desc.type_idx,
06886 Priv);
06887
06888 COPY_OPND(IR_OPND_R(ch_asg_idx), num_el_opnd);
06889 gen_sh(Before, Assignment_Stmt, line,
06890 col, FALSE, FALSE, TRUE);
06891
06892 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx;
06893 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06894
06895 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx;
06896 BD_LEN_IDX(bd_idx) = tmp_idx;
06897 }
06898 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape;
06899
06900 if (constant_shape) {
06901 BD_ARRAY_SIZE(bd_idx) = Constant_Size;
06902 }
06903 else {
06904 BD_ARRAY_SIZE(bd_idx) = Var_Len_Array;
06905 }
06906
06907 set_stride_for_first_dim(exp_desc->type_idx, &stride);
06908
06909 BD_SM_FLD(bd_idx, 1) = stride.fld;
06910 BD_SM_IDX(bd_idx, 1) = stride.idx;
06911
06912 for (i = 2; i <= BD_RANK(bd_idx); i++) {
06913 NTR_IR_TBL(mult_idx);
06914 IR_OPR(mult_idx) = Mult_Opr;
06915 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
06916 IR_LINE_NUM(mult_idx) = line;
06917 IR_COL_NUM(mult_idx) = col;
06918 IR_FLD_L(mult_idx) = BD_SM_FLD(bd_idx, i - 1);
06919 IR_IDX_L(mult_idx) = BD_SM_IDX(bd_idx, i - 1);
06920 IR_LINE_NUM_L(mult_idx) = line;
06921 IR_COL_NUM_L(mult_idx) = col;
06922 IR_FLD_R(mult_idx) = BD_XT_FLD(bd_idx, i - 1);
06923 IR_IDX_R(mult_idx) = BD_XT_IDX(bd_idx, i - 1);
06924 IR_LINE_NUM_R(mult_idx) = line;
06925 IR_COL_NUM_R(mult_idx) = col;
06926 OPND_FLD(sm_opnd) = IR_Tbl_Idx;
06927 OPND_IDX(sm_opnd) = mult_idx;
06928
06929 loc_exp_desc.rank = 0;
06930 save_xref_state = xref_state;
06931 xref_state = CIF_No_Usage_Rec;
06932
06933 ok = expr_semantics(&sm_opnd, &loc_exp_desc);
06934
06935 xref_state = save_xref_state;
06936
06937 if (loc_exp_desc.constant) {
06938 BD_SM_FLD(bd_idx, i) = CN_Tbl_Idx;
06939 BD_SM_IDX(bd_idx, i) = OPND_IDX(sm_opnd);
06940 }
06941 else if (OPND_FLD(sm_opnd) == AT_Tbl_Idx &&
06942 ATD_CLASS(OPND_IDX(sm_opnd)) == Compiler_Tmp) {
06943 BD_SM_FLD(bd_idx, i) = AT_Tbl_Idx;
06944 BD_SM_IDX(bd_idx, i) = OPND_IDX(sm_opnd);
06945 }
06946 else {
06947
06948 GEN_COMPILER_TMP_ASG(ch_asg_idx,
06949 tmp_idx,
06950 TRUE,
06951 line,
06952 col,
06953 loc_exp_desc.type_idx,
06954 Priv);
06955
06956 COPY_OPND(IR_OPND_R(ch_asg_idx), sm_opnd);
06957 gen_sh(Before, Assignment_Stmt, line,
06958 col, FALSE, FALSE, TRUE);
06959
06960 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx;
06961 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06962
06963 BD_SM_FLD(bd_idx, i) = AT_Tbl_Idx;
06964 BD_SM_IDX(bd_idx, i) = tmp_idx;
06965 }
06966 }
06967
06968 BD_FLOW_DEPENDENT(bd_idx) = TRUE;
06969
06970 *res_bd_idx = ntr_array_in_bd_tbl(bd_idx);
06971
06972 TRACE (Func_Exit, "gen_bd_entry", NULL);
06973
06974 return(constant_shape);
06975
06976 }
06977
06978
06979
06980
06981
06982
06983
06984
06985
06986
06987
06988
06989
06990
06991
06992
06993
06994
06995 static int create_tmp_DV_asg(int list_idx,
06996 int info_idx)
06997
06998 {
06999 int asg_idx;
07000 int column;
07001 int line;
07002 int tmp_idx;
07003
07004
07005 TRACE (Func_Entry, "create_tmp_DV_asg", NULL);
07006
07007 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
07008 &line,
07009 &column);
07010
07011 # ifdef _DEBUG
07012 if (info_idx == NULL_IDX) {
07013 PRINTMSG(line, 626, Internal, column,
07014 "valid info_idx", "create_tmp_DV_asg");
07015 }
07016 # endif
07017
07018 GEN_COMPILER_TMP_ASG(asg_idx,
07019 tmp_idx,
07020 TRUE,
07021 line,
07022 column,
07023 arg_info_list[info_idx].ed.type_idx,
07024 Priv);
07025
07026 IR_OPR(asg_idx) = Dv_Whole_Copy_Opr;
07027 IR_DV_DIM(asg_idx) = arg_info_list[info_idx].ed.rank;
07028 ATD_IM_A_DOPE(tmp_idx) = TRUE;
07029 ATD_ARRAY_IDX(tmp_idx) = ATD_ARRAY_IDX(find_base_attr(&IL_OPND(list_idx),
07030 &line, &column));
07031
07032
07033 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
07034 IR_OPR(IL_IDX(list_idx)) == Whole_Substring_Opr) {
07035
07036 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
07037 }
07038
07039 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
07040 IR_OPR(IL_IDX(list_idx)) == Whole_Subscript_Opr) {
07041
07042 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
07043 }
07044
07045
07046
07047 if (IL_FLD(list_idx) != IR_Tbl_Idx ||
07048 IR_OPR(IL_IDX(list_idx)) != Dv_Deref_Opr) {
07049
07050 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
07051 &line,
07052 &column);
07053 PRINTMSG(line, 861, Internal, column,
07054 "create_tmp_DV_asg");
07055 }
07056
07057 COPY_OPND(IR_OPND_R(asg_idx), IR_OPND_L(IL_IDX(list_idx)));
07058
07059 gen_sh(Before, Assignment_Stmt, stmt_start_line,
07060 stmt_start_col, FALSE, FALSE, TRUE);
07061
07062 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
07063 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07064
07065 TRACE (Func_Exit, "create_tmp_DV_asg", NULL);
07066
07067 return(tmp_idx);
07068
07069 }
07070
07071
07072
07073
07074
07075
07076
07077
07078
07079
07080
07081
07082
07083
07084
07085
07086
07087 static void set_at_actual_arg(int list_idx)
07088
07089 {
07090 opnd_type opnd;
07091
07092 TRACE (Func_Entry, "set_at_actual_arg", NULL);
07093
07094 COPY_OPND(opnd, IL_OPND(list_idx));
07095
07096 while (TRUE) {
07097 switch (OPND_FLD(opnd)) {
07098 case AT_Tbl_Idx :
07099 AT_ACTUAL_ARG(OPND_IDX(opnd)) = TRUE;
07100 goto EXIT;
07101
07102 case IR_Tbl_Idx :
07103 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
07104 break;
07105
07106 default :
07107 goto EXIT;
07108 }
07109 }
07110
07111 EXIT:
07112
07113 TRACE (Func_Exit, "set_at_actual_arg", NULL);
07114
07115 return;
07116
07117 }
07118
07119
07120
07121
07122
07123
07124
07125
07126
07127
07128
07129
07130
07131
07132
07133
07134
07135 void determine_tmp_size(opnd_type *opnd,
07136 int type_idx)
07137
07138 {
07139 int col;
07140 size_offset_type length;
07141 int line;
07142 expr_arg_type loc_exp_desc;
07143 int mult_idx;
07144 size_offset_type result;
07145 cif_usage_code_type save_xref_state;
07146
07147 # if !defined(_HEAP_REQUEST_IN_BYTES)
07148 long_type constant;
07149 int div_idx;
07150 int plus_idx;
07151 # endif
07152
07153
07154 TRACE (Func_Entry, "determine_tmp_size", NULL);
07155
07156 find_opnd_line_and_column(opnd, &line, &col);
07157
07158 # ifdef _HEAP_REQUEST_IN_BYTES
07159
07160
07161
07162
07163
07164 if (TYP_TYPE(type_idx) == Character) {
07165
07166 NTR_IR_TBL(mult_idx);
07167 IR_OPR(mult_idx) = Mult_Opr;
07168 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
07169 IR_LINE_NUM(mult_idx) = line;
07170 IR_COL_NUM(mult_idx) = col;
07171 COPY_OPND(IR_OPND_L(mult_idx), (*opnd));
07172 IR_FLD_R(mult_idx) = TYP_FLD(type_idx);
07173 IR_IDX_R(mult_idx) = TYP_IDX(type_idx);
07174 IR_LINE_NUM_R(mult_idx) = line;
07175 IR_COL_NUM_R(mult_idx) = col;
07176
07177
07178 OPND_FLD((*opnd)) = IR_Tbl_Idx;
07179 OPND_IDX((*opnd)) = mult_idx;
07180 }
07181 else if (TYP_TYPE(type_idx) == Structure &&
07182 ATT_CHAR_SEQ(TYP_IDX(type_idx))) {
07183 NTR_IR_TBL(mult_idx);
07184 IR_OPR(mult_idx) = Mult_Opr;
07185 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
07186 IR_LINE_NUM(mult_idx) = line;
07187 IR_COL_NUM(mult_idx) = col;
07188 COPY_OPND(IR_OPND_L(mult_idx), (*opnd));
07189
07190 # if defined(_DEBUG)
07191
07192 if (ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)) != CN_Tbl_Idx) {
07193 PRINTMSG(line, 1201, Internal, col,
07194 AT_OBJ_NAME_PTR(TYP_IDX(type_idx)));
07195 }
07196
07197 # endif
07198
07199 result.idx = CN_INTEGER_CHAR_BIT_IDX;
07200 result.fld = CN_Tbl_Idx;
07201 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
07202 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
07203
07204 size_offset_binary_calc(&length,
07205 &result,
07206 Div_Opr,
07207 &result);
07208
07209 if (result.fld == NO_Tbl_Idx) {
07210 IR_FLD_R(mult_idx) = CN_Tbl_Idx;
07211 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx,
07212 FALSE,
07213 result.constant);
07214 }
07215 else {
07216 IR_FLD_R(mult_idx) = result.fld;
07217 IR_IDX_R(mult_idx) = result.idx;
07218 }
07219
07220 IR_LINE_NUM_R(mult_idx) = line;
07221 IR_COL_NUM_R(mult_idx) = col;
07222
07223 OPND_FLD((*opnd)) = IR_Tbl_Idx;
07224 OPND_IDX((*opnd)) = mult_idx;
07225 }
07226 else {
07227 NTR_IR_TBL(mult_idx);
07228 IR_OPR(mult_idx) = Mult_Opr;
07229 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
07230 IR_LINE_NUM(mult_idx) = line;
07231 IR_COL_NUM(mult_idx) = col;
07232 COPY_OPND(IR_OPND_L(mult_idx), (*opnd));
07233
07234 if (TYP_TYPE(type_idx) == Structure) {
07235 result.idx = CN_INTEGER_CHAR_BIT_IDX;
07236 result.fld = CN_Tbl_Idx;
07237 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
07238 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
07239
07240 # if defined(_DEBUG)
07241
07242 if (length.fld != CN_Tbl_Idx) {
07243 PRINTMSG(line, 1201, Internal, col,
07244 AT_OBJ_NAME_PTR(TYP_IDX(type_idx)));
07245 }
07246 # endif
07247
07248 size_offset_binary_calc(&length,
07249 &result,
07250 Div_Opr,
07251 &result);
07252 }
07253 else {
07254 C_TO_F_INT(result.constant,
07255 (storage_bit_size_tbl[TYP_LINEAR(type_idx)] / 8),
07256 CG_INTEGER_DEFAULT_TYPE);
07257 result.type_idx = CG_INTEGER_DEFAULT_TYPE;
07258 result.fld = NO_Tbl_Idx;
07259 }
07260
07261 if (result.fld == NO_Tbl_Idx) {
07262 IR_FLD_R(mult_idx) = CN_Tbl_Idx;
07263 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx,
07264 FALSE,
07265 result.constant);
07266 }
07267 else {
07268 IR_FLD_R(mult_idx) = result.fld;
07269 IR_IDX_R(mult_idx) = result.idx;
07270 }
07271
07272 IR_LINE_NUM_R(mult_idx) = line;
07273 IR_COL_NUM_R(mult_idx) = col;
07274
07275 OPND_FLD((*opnd)) = IR_Tbl_Idx;
07276 OPND_IDX((*opnd)) = mult_idx;
07277 }
07278
07279 # else
07280
07281
07282
07283
07284
07285 if (TYP_TYPE(type_idx) == Character) {
07286
07287 NTR_IR_TBL(mult_idx);
07288 IR_OPR(mult_idx) = Mult_Opr;
07289 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
07290 IR_LINE_NUM(mult_idx) = line;
07291 IR_COL_NUM(mult_idx) = col;
07292 COPY_OPND(IR_OPND_L(mult_idx), (*opnd));
07293 IR_FLD_R(mult_idx) = TYP_FLD(type_idx);
07294 IR_IDX_R(mult_idx) = TYP_IDX(type_idx);
07295 IR_LINE_NUM_R(mult_idx) = line;
07296 IR_COL_NUM_R(mult_idx) = col;
07297
07298
07299 NTR_IR_TBL(div_idx);
07300 IR_OPR(div_idx) = Div_Opr;
07301 IR_TYPE_IDX(div_idx) = SA_INTEGER_DEFAULT_TYPE;
07302 IR_LINE_NUM(div_idx) = line;
07303 IR_COL_NUM(div_idx) = col;
07304 IR_FLD_R(div_idx) = CN_Tbl_Idx;
07305 constant = TARGET_CHARS_PER_WORD;
07306 IR_IDX_R(div_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
07307 TARGET_CHARS_PER_WORD);
07308 IR_LINE_NUM_R(div_idx) = line;
07309 IR_COL_NUM_R(div_idx) = col;
07310
07311 NTR_IR_TBL(plus_idx);
07312 IR_OPR(plus_idx) = Plus_Opr;
07313 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE;
07314 IR_LINE_NUM(plus_idx) = line;
07315 IR_COL_NUM(plus_idx) = col;
07316 IR_FLD_L(div_idx) = IR_Tbl_Idx;
07317 IR_IDX_L(div_idx) = plus_idx;
07318
07319 constant--;
07320 IR_FLD_R(plus_idx) = CN_Tbl_Idx;
07321 IR_IDX_R(plus_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
07322 constant);
07323 IR_LINE_NUM_R(plus_idx) = line;
07324 IR_COL_NUM_R(plus_idx) = col;
07325
07326 IR_FLD_L(plus_idx) = IR_Tbl_Idx;
07327 IR_IDX_L(plus_idx) = mult_idx;
07328
07329 OPND_FLD((*opnd)) = IR_Tbl_Idx;
07330 OPND_IDX((*opnd)) = div_idx;
07331 }
07332 else if (TYP_TYPE(type_idx) == Structure &&
07333 ATT_CHAR_SEQ(TYP_IDX(type_idx))) {
07334
07335 NTR_IR_TBL(mult_idx);
07336 IR_OPR(mult_idx) = Mult_Opr;
07337 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
07338 IR_LINE_NUM(mult_idx) = line;
07339 IR_COL_NUM(mult_idx) = col;
07340 COPY_OPND(IR_OPND_L(mult_idx), (*opnd));
07341
07342 # if defined(_DEBUG)
07343
07344 if (ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)) != CN_Tbl_Idx) {
07345 PRINTMSG(line, 1201, Internal, col,
07346 AT_OBJ_NAME_PTR(TYP_IDX(type_idx)));
07347 }
07348
07349 # endif
07350
07351 result.idx = CN_INTEGER_CHAR_BIT_IDX;
07352 result.fld = CN_Tbl_Idx;
07353 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
07354 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
07355
07356 size_offset_binary_calc(&length,
07357 &result,
07358 Div_Opr,
07359 &result);
07360
07361 if (result.fld == NO_Tbl_Idx) {
07362 IR_FLD_R(mult_idx) = CN_Tbl_Idx;
07363 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx,
07364 FALSE,
07365 result.constant);
07366 }
07367 else {
07368 IR_FLD_R(mult_idx) = result.fld;
07369 IR_IDX_R(mult_idx) = result.idx;
07370 }
07371
07372 IR_LINE_NUM_R(mult_idx) = line;
07373 IR_COL_NUM_R(mult_idx) = col;
07374
07375
07376
07377 NTR_IR_TBL(div_idx);
07378 IR_OPR(div_idx) = Div_Opr;
07379 IR_TYPE_IDX(div_idx) = SA_INTEGER_DEFAULT_TYPE;
07380 IR_LINE_NUM(div_idx) = line;
07381 IR_COL_NUM(div_idx) = col;
07382 IR_FLD_R(div_idx) = CN_Tbl_Idx;
07383 constant = TARGET_CHARS_PER_WORD;
07384 IR_IDX_R(div_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
07385 TARGET_CHARS_PER_WORD);
07386 IR_LINE_NUM_R(div_idx) = line;
07387 IR_COL_NUM_R(div_idx) = col;
07388
07389 NTR_IR_TBL(plus_idx);
07390 IR_OPR(plus_idx) = Plus_Opr;
07391 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE;
07392 IR_LINE_NUM(plus_idx) = line;
07393 IR_COL_NUM(plus_idx) = col;
07394 IR_FLD_L(div_idx) = IR_Tbl_Idx;
07395 IR_IDX_L(div_idx) = plus_idx;
07396
07397 constant--;
07398 IR_FLD_R(plus_idx) = CN_Tbl_Idx;
07399 IR_IDX_R(plus_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
07400 constant);
07401 IR_LINE_NUM_R(plus_idx) = line;
07402 IR_COL_NUM_R(plus_idx) = col;
07403
07404 IR_FLD_L(plus_idx) = IR_Tbl_Idx;
07405 IR_IDX_L(plus_idx) = mult_idx;
07406
07407 OPND_FLD((*opnd)) = IR_Tbl_Idx;
07408 OPND_IDX((*opnd)) = div_idx;
07409 }
07410 else {
07411
07412 NTR_IR_TBL(mult_idx);
07413 IR_OPR(mult_idx) = Mult_Opr;
07414 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
07415 IR_LINE_NUM(mult_idx) = line;
07416 IR_COL_NUM(mult_idx) = col;
07417 COPY_OPND(IR_OPND_L(mult_idx), (*opnd));
07418
07419 if (TYP_TYPE(type_idx) == Structure) {
07420 result.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
07421 result.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
07422 }
07423 else {
07424 C_TO_F_INT(result.constant,
07425 storage_bit_size_tbl[TYP_LINEAR(type_idx)],
07426 CG_INTEGER_DEFAULT_TYPE);
07427 result.type_idx = CG_INTEGER_DEFAULT_TYPE;
07428 result.fld = NO_Tbl_Idx;
07429 }
07430
07431 BITS_TO_WORDS(result, TARGET_BITS_PER_WORD);
07432
07433 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx,
07434 FALSE,
07435 result.constant);
07436
07437 IR_FLD_R(mult_idx) = CN_Tbl_Idx;
07438 IR_LINE_NUM_R(mult_idx) = line;
07439 IR_COL_NUM_R(mult_idx) = col;
07440
07441 OPND_FLD((*opnd)) = IR_Tbl_Idx;
07442 OPND_IDX((*opnd)) = mult_idx;
07443 }
07444
07445 # endif
07446
07447 loc_exp_desc.rank = 0;
07448 save_xref_state = xref_state;
07449 xref_state = CIF_No_Usage_Rec;
07450
07451 expr_semantics(opnd, &loc_exp_desc);
07452
07453 xref_state = save_xref_state;
07454
07455 TRACE (Func_Exit, "determine_tmp_size", NULL);
07456
07457 return;
07458
07459 }
07460
07461
07462
07463
07464
07465
07466
07467
07468
07469
07470
07471
07472
07473
07474
07475
07476
07477
07478
07479
07480
07481 static void save_array_syntax_subscripts(int list_idx)
07482
07483
07484 {
07485 int asg_idx;
07486 int column;
07487 int i;
07488 int ir_idx;
07489 int k;
07490 int l_idx;
07491 int line;
07492 int t_idx;
07493 int tmp_idx;
07494
07495
07496 TRACE (Func_Entry, "save_array_syntax_subscripts", NULL);
07497
07498 ir_idx = IL_IDX(list_idx);
07499
07500 while (TRUE) {
07501
07502 if (IR_OPR(ir_idx) == Subscript_Opr ||
07503 IR_OPR(ir_idx) == Section_Subscript_Opr ||
07504 IR_OPR(ir_idx) == Substring_Opr) {
07505
07506 l_idx = IR_IDX_R(ir_idx);
07507
07508 for (k = 0; k < IR_LIST_CNT_R(ir_idx); k++) {
07509
07510 if (!IL_CONSTANT_SUBSCRIPT(l_idx)) {
07511
07512 if (IL_FLD(l_idx) == IR_Tbl_Idx &&
07513 IR_OPR(IL_IDX(l_idx)) == Triplet_Opr) {
07514
07515 t_idx = IR_IDX_L(IL_IDX(l_idx));
07516 for (i = 0; i < 3; i++) {
07517
07518 if (! IL_CONSTANT_SUBSCRIPT(t_idx)) {
07519 find_opnd_line_and_column((opnd_type *) &IL_OPND(t_idx),
07520 &line,
07521 &column);
07522
07523 GEN_COMPILER_TMP_ASG(asg_idx,
07524 tmp_idx,
07525 TRUE,
07526 line,
07527 column,
07528 CG_INTEGER_DEFAULT_TYPE,
07529 Priv);
07530
07531 COPY_OPND(IR_OPND_R(asg_idx), IL_OPND(t_idx));
07532
07533 gen_sh(Before, Assignment_Stmt, stmt_start_line,
07534 stmt_start_col, FALSE, FALSE, TRUE);
07535
07536 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
07537 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07538
07539 IL_FLD(t_idx) = AT_Tbl_Idx;
07540 IL_IDX(t_idx) = tmp_idx;
07541 IL_LINE_NUM(t_idx) = line;
07542 IL_COL_NUM(t_idx) = column;
07543 }
07544
07545 t_idx = IL_NEXT_LIST_IDX(t_idx);
07546 }
07547 }
07548 else {
07549 find_opnd_line_and_column((opnd_type *) &IL_OPND(l_idx),
07550 &line,
07551 &column);
07552 GEN_COMPILER_TMP_ASG(asg_idx,
07553 tmp_idx,
07554 TRUE,
07555 line,
07556 column,
07557 CG_INTEGER_DEFAULT_TYPE,
07558 Priv);
07559
07560 COPY_OPND(IR_OPND_R(asg_idx), IL_OPND(l_idx));
07561
07562 gen_sh(Before, Assignment_Stmt, stmt_start_line,
07563 stmt_start_col, FALSE, FALSE, TRUE);
07564
07565 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
07566 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07567
07568 IL_FLD(l_idx) = AT_Tbl_Idx;
07569 IL_IDX(l_idx) = tmp_idx;
07570 IL_LINE_NUM(l_idx) = line;
07571 IL_COL_NUM(l_idx) = column;
07572 }
07573 }
07574
07575 l_idx = IL_NEXT_LIST_IDX(l_idx);
07576 }
07577 }
07578
07579 if (IR_FLD_L(ir_idx) != IR_Tbl_Idx) {
07580 break;
07581 }
07582 else {
07583 ir_idx = IR_IDX_L(ir_idx);
07584 }
07585 }
07586
07587 TRACE (Func_Exit, "save_array_syntax_subscripts", NULL);
07588
07589 return;
07590
07591 }
07592
07593
07594
07595
07596
07597
07598
07599
07600
07601
07602
07603
07604
07605
07606
07607
07608
07609 static void determine_num_elements(opnd_type *opnd,
07610 expr_arg_type *exp_desc,
07611 int line,
07612 int col)
07613
07614 {
07615 int i;
07616 int list_idx;
07617 int max_idx;
07618 int mult_idx;
07619
07620
07621 TRACE (Func_Entry, "determine_num_elements", NULL);
07622
07623 *opnd = null_opnd;
07624
07625 for (i = 0; i < exp_desc->rank; i++) {
07626 NTR_IR_TBL(max_idx);
07627 IR_OPR(max_idx) = Max_Opr;
07628 IR_TYPE_IDX(max_idx) = SA_INTEGER_DEFAULT_TYPE;
07629 IR_LINE_NUM(max_idx) = line;
07630 IR_COL_NUM(max_idx) = col;
07631
07632 NTR_IR_LIST_TBL(list_idx);
07633 IR_FLD_L(max_idx) = IL_Tbl_Idx;
07634 IR_IDX_L(max_idx) = list_idx;
07635 IR_LIST_CNT_L(max_idx) = 2;
07636
07637 IL_FLD(list_idx) = CN_Tbl_Idx;
07638 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
07639 IL_LINE_NUM(list_idx) = IR_LINE_NUM(max_idx);
07640 IL_COL_NUM(list_idx) = IR_COL_NUM(max_idx);
07641
07642 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
07643 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
07644
07645 COPY_OPND(IL_OPND(IL_NEXT_LIST_IDX(list_idx)),
07646 exp_desc->shape[i]);
07647 IL_LINE_NUM(IL_NEXT_LIST_IDX(list_idx)) = line;
07648 IL_COL_NUM(IL_NEXT_LIST_IDX(list_idx)) = col;
07649
07650 if (OPND_FLD((*opnd)) == NO_Tbl_Idx) {
07651 OPND_FLD((*opnd)) = IR_Tbl_Idx;
07652 OPND_IDX((*opnd)) = max_idx;
07653 }
07654 else {
07655 NTR_IR_TBL(mult_idx);
07656 IR_OPR(mult_idx) = Mult_Opr;
07657 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE;
07658 IR_LINE_NUM(mult_idx) = line;
07659 IR_COL_NUM(mult_idx) = col;
07660
07661 COPY_OPND(IR_OPND_L(mult_idx), (*opnd));
07662 IR_FLD_R(mult_idx) = IR_Tbl_Idx;
07663 IR_IDX_R(mult_idx) = max_idx;
07664
07665 OPND_IDX((*opnd)) = mult_idx;
07666 }
07667 }
07668
07669
07670 TRACE (Func_Exit, "determine_num_elements", NULL);
07671
07672 return;
07673
07674 }
07675 #ifdef KEY
07676
07677
07678
07679
07680
07681
07682
07683
07684 boolean special_case_fcn_to_sub(int spec_idx) {
07685 char *name = ATP_EXT_NAME_PTR(spec_idx);
07686 # define IEEE_VALUE_PREFIX "IEEE_VALUE_"
07687 # define EXT_IEEE_VALUE_PREFIX "_Ieee_value_"
07688 return !(on_off_flags.intrinsic_module_gen ?
07689 strncmp(AT_OBJ_NAME_PTR(spec_idx), IEEE_VALUE_PREFIX,
07690 (sizeof IEEE_VALUE_PREFIX) - 1) :
07691 strncmp(ATP_EXT_NAME_PTR(spec_idx), EXT_IEEE_VALUE_PREFIX,
07692 (sizeof EXT_IEEE_VALUE_PREFIX) - 1));
07693 }
07694 #endif
07695
07696
07697
07698
07699
07700
07701
07702
07703
07704
07705
07706
07707
07708
07709
07710
07711
07712
07713
07714
07715
07716 void flatten_function_call(opnd_type *result)
07717 {
07718 int alloc_idx;
07719 int asg_idx;
07720 int attr_idx;
07721 int base_asg_idx;
07722 opnd_type base_opnd;
07723 int base_tmp_idx;
07724 int bd_idx;
07725 int cn_idx;
07726 int col;
07727 int dealloc_idx;
07728 int dv_idx;
07729 expr_arg_type elemental_exp_desc;
07730 expr_arg_type exp_desc;
07731 int ir_idx;
07732 int line;
07733 int list_idx;
07734 int loc_idx;
07735 int new_stmt_idx;
07736 int num_args;
07737 boolean ok;
07738 opnd_type opnd;
07739 #ifdef KEY
07740 int res_list_idx = 0;
07741 #else
07742 int res_list_idx;
07743 #endif
07744 boolean save_keep_orig_sh;
07745 int save_orig_sh_idx;
07746 opnd_type size_opnd;
07747 int spec_idx;
07748 int unused1;
07749 int unused2;
07750 boolean save_defer_stmt_expansion;
07751 int tmp_idx = NULL_IDX;
07752 int type_idx;
07753 boolean variable_size = FALSE;
07754
07755 # ifdef _ALLOCATE_IS_CALL
07756 int call_idx;
07757 int sub_idx;
07758 long_type the_constant;
07759 int tmp_array_idx;
07760 # endif
07761
07762
07763 TRACE (Func_Entry, "flatten_function_call", NULL);
07764
07765 if (no_func_expansion) {
07766 goto EXIT;
07767 }
07768
07769 ir_idx = OPND_IDX((*result));
07770
07771 spec_idx = IR_IDX_L(ir_idx);
07772 attr_idx = ATP_RSLT_IDX(spec_idx);
07773 type_idx = ATD_TYPE_IDX(attr_idx);
07774
07775 line = IR_LINE_NUM(ir_idx);
07776 col = IR_COL_NUM(ir_idx);
07777
07778 save_orig_sh_idx = orig_sh_idx;
07779
07780 stmt_expansion_control_start();
07781 save_defer_stmt_expansion = defer_stmt_expansion;
07782 defer_stmt_expansion = FALSE;
07783
07784 if (! keep_orig_sh) {
07785 orig_sh_idx = curr_stmt_sh_idx;
07786 }
07787
07788 #ifdef KEY
07789
07790
07791
07792
07793 int sh_prev = SH_PREV_IDX(curr_stmt_sh_idx);
07794 int insertion_point =
07795 (curr_stmt_sh_idx != SCP_FIRST_SH_IDX(curr_scp_idx) &&
07796 IR_OPR(SH_IR_IDX(sh_prev)) == Atomic_Open_Mp_Opr) ?
07797 sh_prev :
07798 curr_stmt_sh_idx;
07799 gen_sh_at(Before, Call_Stmt, stmt_start_line, stmt_start_col,
07800 FALSE, FALSE, TRUE, insertion_point);
07801 curr_stmt_sh_idx = SH_PREV_IDX(insertion_point);
07802 #else
07803 gen_sh(Before, Call_Stmt, stmt_start_line, stmt_start_col,
07804 FALSE, FALSE, TRUE);
07805
07806 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
07807 #endif
07808 new_stmt_idx = curr_stmt_sh_idx;
07809
07810 num_args = IR_LIST_CNT_R(ir_idx);
07811
07812 #ifdef KEY
07813 boolean fcn_to_sub = FUNCTION_MUST_BE_SUBROUTINE(spec_idx, attr_idx);
07814 if (fcn_to_sub)
07815 #else
07816 if (FUNCTION_MUST_BE_SUBROUTINE(attr_idx))
07817 #endif
07818 {
07819
07820 NTR_IR_LIST_TBL(res_list_idx);
07821 IL_ARG_DESC_VARIANT(res_list_idx) = TRUE;
07822 IL_NEXT_LIST_IDX(res_list_idx) = IR_IDX_R(ir_idx);
07823 IR_IDX_R(ir_idx) = res_list_idx;
07824 IR_LIST_CNT_R(ir_idx)++;
07825 }
07826
07827 elemental_exp_desc = init_exp_desc;
07828 elemental_exp_desc.type_idx = type_idx;
07829 elemental_exp_desc.type = TYP_TYPE(type_idx);
07830 elemental_exp_desc.linear_type = TYP_LINEAR(type_idx);
07831
07832 COPY_OPND(opnd, IR_OPND_R(ir_idx));
07833 ok = final_arg_work(&opnd, IR_IDX_L(ir_idx), num_args, &elemental_exp_desc);
07834 COPY_OPND(IR_OPND_R(ir_idx), opnd);
07835
07836 curr_stmt_sh_idx = new_stmt_idx;
07837
07838 #ifdef KEY
07839 if (fcn_to_sub || ATP_ELEMENTAL(spec_idx))
07840 #else
07841 if (FUNCTION_MUST_BE_SUBROUTINE(attr_idx) || ATP_ELEMENTAL(spec_idx))
07842 #endif
07843 {
07844
07845 bd_idx = ATD_ARRAY_IDX(attr_idx);
07846
07847 if (TYP_TYPE(type_idx) == Character &&
07848 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char &&
07849 ATP_PROC(IR_IDX_L(ir_idx)) != Dummy_Proc &&
07850 attr_idx != SCP_ATTR_IDX(curr_scp_idx) &&
07851 !AT_IS_INTRIN(attr_idx)) {
07852
07853 PRINTMSG(line, 939, Error, col, AT_OBJ_NAME_PTR(attr_idx));
07854 }
07855
07856 if (ATP_PROC(IR_IDX_L(ir_idx)) != Intrin_Proc &&
07857 (TYP_TYPE(type_idx) == Character &&
07858 TYP_CHAR_CLASS(type_idx) == Var_Len_Char ||
07859 bd_idx != NULL_IDX &&
07860 BD_ARRAY_SIZE(bd_idx) == Var_Len_Array)) {
07861
07862 save_keep_orig_sh = keep_orig_sh;
07863 keep_orig_sh = TRUE;
07864
07865 process_variable_size_func(attr_idx,
07866 IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)),
07867 (ATP_EXTRA_DARG(IR_IDX_L(ir_idx)) ?
07868 ATP_FIRST_IDX(IR_IDX_L(ir_idx)) + 1 :
07869 ATP_FIRST_IDX(IR_IDX_L(ir_idx))),
07870 (ATP_EXTRA_DARG(IR_IDX_L(ir_idx)) ?
07871 ATP_NUM_DARGS(IR_IDX_L(ir_idx)) - 1 :
07872 ATP_NUM_DARGS(IR_IDX_L(ir_idx))),
07873 &type_idx,
07874 &bd_idx);
07875
07876
07877 if (! ATD_IM_A_DOPE(attr_idx) &&
07878 ((TYP_TYPE(type_idx) == Character &&
07879 TYP_CHAR_CLASS(type_idx) == Var_Len_Char) ||
07880 (bd_idx != NULL_IDX &&
07881 BD_ARRAY_SIZE(bd_idx) == Var_Len_Array))) {
07882
07883 variable_size = TRUE;
07884 }
07885
07886 keep_orig_sh = save_keep_orig_sh;
07887 }
07888
07889 if (ATP_PROC(IR_IDX_L(ir_idx)) != Intrin_Proc &&
07890 TYP_TYPE(type_idx) == Character &&
07891 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char &&
07892 ! ATD_IM_A_DOPE(attr_idx)) {
07893
07894 variable_size = TRUE;
07895 }
07896
07897 if (ATP_ELEMENTAL(spec_idx) &&
07898 elemental_exp_desc.rank > 0) {
07899
07900 elemental_exp_desc.type_idx = type_idx;
07901 variable_size |= ! gen_bd_entry(NULL, &elemental_exp_desc, &bd_idx,
07902 line, col);
07903 }
07904
07905
07906
07907 tmp_idx = get_stmt_tmp(type_idx,
07908 ATD_IM_A_DOPE(attr_idx),
07909 (bd_idx == NULL_IDX ? 0 : BD_RANK(bd_idx)));
07910
07911 if (tmp_idx == NULL_IDX) {
07912
07913 if (variable_size) {
07914 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
07915 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_BASED_IDX(curr_scp_idx);
07916 }
07917 else {
07918 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
07919 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
07920 }
07921
07922 ATD_TYPE_IDX(tmp_idx) = type_idx;
07923 ATD_ARRAY_IDX(tmp_idx) = bd_idx;
07924 ATD_IM_A_DOPE(tmp_idx) = ATD_IM_A_DOPE(attr_idx);
07925 AT_ACTUAL_ARG(tmp_idx) = TRUE;
07926 ATD_POINTER(tmp_idx) = ATD_POINTER(attr_idx);
07927 AT_SEMANTICS_DONE(tmp_idx)= TRUE;
07928 }
07929
07930 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
07931 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE;
07932 # endif
07933
07934 ATD_CHAR_LEN_IN_DV(tmp_idx) = ATD_CHAR_LEN_IN_DV(attr_idx);
07935
07936 if (variable_size) {
07937
07938
07939
07940 ATD_AUTOMATIC(tmp_idx) = TRUE;
07941
07942 GEN_COMPILER_TMP_ASG(base_asg_idx,
07943 base_tmp_idx,
07944 TRUE,
07945 line,
07946 col,
07947 SA_INTEGER_DEFAULT_TYPE,
07948 Priv);
07949
07950 ATD_AUTO_BASE_IDX(tmp_idx) = base_tmp_idx;
07951 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
07952 ATD_NOT_PT_UNIQUE_MEM(base_tmp_idx) = TRUE;
07953 # endif
07954
07955 if (bd_idx) {
07956 OPND_FLD(size_opnd) = BD_LEN_FLD(bd_idx);
07957 OPND_IDX(size_opnd) = BD_LEN_IDX(bd_idx);
07958 OPND_LINE_NUM(size_opnd) = line;
07959 OPND_COL_NUM(size_opnd) = col;
07960 }
07961 else {
07962 OPND_FLD(size_opnd) = CN_Tbl_Idx;
07963 OPND_IDX(size_opnd) = CN_INTEGER_ONE_IDX;
07964 OPND_LINE_NUM(size_opnd) = line;
07965 OPND_COL_NUM(size_opnd) = col;
07966 }
07967
07968 determine_tmp_size(&size_opnd,
07969 ATD_TYPE_IDX(tmp_idx));
07970
07971 NTR_IR_TBL(alloc_idx);
07972 IR_OPR(alloc_idx) = Alloc_Opr;
07973 IR_TYPE_IDX(alloc_idx) = TYPELESS_DEFAULT_TYPE;
07974 IR_LINE_NUM(alloc_idx) = line;
07975 IR_COL_NUM(alloc_idx) = col;
07976 COPY_OPND(IR_OPND_L(alloc_idx), size_opnd);
07977 IR_FLD_R(base_asg_idx) = IR_Tbl_Idx;
07978 IR_IDX_R(base_asg_idx) = alloc_idx;
07979
07980
07981
07982 gen_sh(Before, Assignment_Stmt, stmt_start_line,
07983 stmt_start_col, FALSE, FALSE, TRUE);
07984
07985 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = base_asg_idx;
07986 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
07987
07988 NTR_IR_TBL(dealloc_idx);
07989 IR_OPR(dealloc_idx) = Dealloc_Opr;
07990 IR_TYPE_IDX(dealloc_idx) = TYPELESS_DEFAULT_TYPE;
07991 IR_LINE_NUM(dealloc_idx) = line;
07992 IR_COL_NUM(dealloc_idx) = col;
07993 COPY_OPND(IR_OPND_L(dealloc_idx), IR_OPND_L(base_asg_idx));
07994
07995
07996
07997 curr_stmt_sh_idx = orig_sh_idx;
07998
07999 gen_sh(After, Assignment_Stmt, stmt_start_line,
08000 stmt_start_col, FALSE, FALSE, TRUE);
08001
08002 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx;
08003 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
08004 curr_stmt_sh_idx = new_stmt_idx;
08005 }
08006 else if (ATD_IM_A_DOPE(tmp_idx)) {
08007
08008 if (AT_IS_INTRIN(IR_IDX_L(ir_idx))) {
08009
08010
08011
08012 if (glb_tbl_idx[Dealloc_Attr_Idx] == NULL_IDX) {
08013 glb_tbl_idx[Dealloc_Attr_Idx] = create_lib_entry_attr(
08014 DEALLOC_LIB_ENTRY,
08015 DEALLOC_NAME_LEN,
08016 line,
08017 col);
08018 }
08019
08020 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Dealloc_Attr_Idx]);
08021
08022
08023
08024
08025
08026 curr_stmt_sh_idx = SH_NEXT_IDX(orig_sh_idx);
08027
08028 # ifdef _ALLOCATE_IS_CALL
08029 tmp_array_idx = create_alloc_descriptor(1, line, col, FALSE);
08030
08031
08032
08033 NTR_IR_TBL(sub_idx);
08034 IR_OPR(sub_idx) = Subscript_Opr;
08035 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(tmp_array_idx);
08036 IR_LINE_NUM(sub_idx) = line;
08037 IR_COL_NUM(sub_idx) = col;
08038 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
08039 IR_IDX_L(sub_idx) = tmp_array_idx;
08040 IR_LINE_NUM_L(sub_idx) = line;
08041 IR_COL_NUM_L(sub_idx) = col;
08042
08043 NTR_IR_LIST_TBL(list_idx);
08044 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
08045 IR_IDX_R(sub_idx) = list_idx;
08046 IR_LIST_CNT_R(sub_idx) = 1;
08047
08048 IL_FLD(list_idx) = CN_Tbl_Idx;
08049 the_constant = 2L;
08050
08051 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
08052 if (TYP_LINEAR(ATD_TYPE_IDX(tmp_array_idx)) == Integer_4) {
08053 the_constant++;
08054 }
08055 # endif
08056
08057 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
08058 the_constant);
08059 IL_LINE_NUM(list_idx) = line;
08060 IL_COL_NUM(list_idx) = col;
08061
08062 NTR_IR_TBL(asg_idx);
08063 IR_OPR(asg_idx) = Asg_Opr;
08064 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
08065
08066 IR_LINE_NUM(asg_idx) = line;
08067 IR_COL_NUM(asg_idx) = col;
08068 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
08069 IR_IDX_L(asg_idx) = sub_idx;
08070 NTR_IR_TBL(loc_idx);
08071 IR_OPR(loc_idx) = Loc_Opr;
08072 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
08073 IR_LINE_NUM(loc_idx) = line;
08074 IR_COL_NUM(loc_idx) = col;
08075
08076 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
08077 IR_IDX_R(asg_idx) = loc_idx;
08078
08079 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
08080 IR_IDX_L(loc_idx) = tmp_idx;
08081 IR_LINE_NUM_L(loc_idx) = line;
08082 IR_COL_NUM_L(loc_idx) = col;
08083
08084 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
08085 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08086 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08087
08088
08089
08090 NTR_IR_TBL(call_idx);
08091 IR_OPR(call_idx) = Call_Opr;
08092 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE;
08093 IR_LINE_NUM(call_idx) = line;
08094 IR_COL_NUM(call_idx) = col;
08095 IR_FLD_L(call_idx) = AT_Tbl_Idx;
08096 IR_IDX_L(call_idx) = glb_tbl_idx[Dealloc_Attr_Idx];
08097 IR_LINE_NUM_L(call_idx) = line;
08098 IR_COL_NUM_L(call_idx) = col;
08099
08100 NTR_IR_LIST_TBL(list_idx);
08101 IR_FLD_R(call_idx) = IL_Tbl_Idx;
08102 IR_IDX_R(call_idx) = list_idx;
08103 IR_LIST_CNT_R(call_idx) = 1;
08104
08105 NTR_IR_TBL(loc_idx);
08106 IR_OPR(loc_idx) = Aloc_Opr;
08107 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
08108 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
08109 IR_IDX_L(loc_idx) = tmp_array_idx;
08110 IR_LINE_NUM(loc_idx) = line;
08111 IR_COL_NUM(loc_idx) = col;
08112 IR_LINE_NUM_L(loc_idx) = line;
08113 IR_COL_NUM_L(loc_idx) = col;
08114 IL_FLD(list_idx) = IR_Tbl_Idx;
08115 IL_IDX(list_idx) = loc_idx;
08116
08117 gen_sh(Before, Call_Stmt, line, col, FALSE, FALSE, TRUE);
08118 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = call_idx;
08119 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08120 # else
08121
08122 NTR_IR_TBL(asg_idx);
08123 IR_OPR(asg_idx) = Deallocate_Opr;
08124 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
08125 IR_LINE_NUM(asg_idx) = line;
08126 IR_COL_NUM(asg_idx) = col;
08127
08128 NTR_IR_LIST_TBL(list_idx);
08129 IR_FLD_L(asg_idx) = IL_Tbl_Idx;
08130 IR_IDX_L(asg_idx) = list_idx;
08131 IR_LIST_CNT_L(asg_idx) = 1;
08132
08133 NTR_IR_TBL(loc_idx);
08134 IR_OPR(loc_idx) = Aloc_Opr;
08135 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
08136 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
08137 IR_IDX_L(loc_idx) = tmp_idx;
08138 IR_LINE_NUM(loc_idx) = line;
08139 IR_COL_NUM(loc_idx) = col;
08140 IR_LINE_NUM_L(loc_idx) = line;
08141 IR_COL_NUM_L(loc_idx) = col;
08142 IL_FLD(list_idx) = IR_Tbl_Idx;
08143 IL_IDX(list_idx) = loc_idx;
08144
08145 NTR_IR_LIST_TBL(list_idx);
08146 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
08147 IR_IDX_R(asg_idx) = list_idx;
08148 IR_LIST_CNT_R(asg_idx) = 3;
08149 IL_FLD(list_idx) = AT_Tbl_Idx;
08150 IL_IDX(list_idx) = glb_tbl_idx[Dealloc_Attr_Idx];
08151 IL_LINE_NUM(list_idx) = line;
08152 IL_COL_NUM(list_idx) = col;
08153
08154 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
08155 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
08156 list_idx = IL_NEXT_LIST_IDX(list_idx);
08157
08158 IL_FLD(list_idx) = CN_Tbl_Idx;
08159 IL_IDX(list_idx) = gen_alloc_header_const(Integer_8,
08160 1,
08161 FALSE,
08162 &cn_idx);
08163 IL_LINE_NUM(list_idx) = line;
08164 IL_COL_NUM(list_idx) = col;
08165
08166 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
08167 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
08168 list_idx = IL_NEXT_LIST_IDX(list_idx);
08169
08170 IL_FLD(list_idx) = CN_Tbl_Idx;
08171 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
08172 IL_LINE_NUM(list_idx) = line;
08173 IL_COL_NUM(list_idx) = col;
08174
08175 gen_sh(Before, Call_Stmt, line, col, FALSE, FALSE, TRUE);
08176 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08177 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08178 # endif
08179
08180 curr_stmt_sh_idx = new_stmt_idx;
08181 }
08182 }
08183
08184 if (ATD_IM_A_DOPE(tmp_idx)) {
08185
08186
08187 OPND_FLD(opnd) = AT_Tbl_Idx;
08188 OPND_IDX(opnd) = tmp_idx;
08189 OPND_LINE_NUM(opnd) = line;
08190 OPND_COL_NUM(opnd) = col;
08191
08192 gen_dv_whole_def_init(&opnd, tmp_idx, Before);
08193 }
08194 else if (TYP_TYPE(type_idx) == Structure &&
08195 (ATT_POINTER_CPNT(TYP_IDX(type_idx)) ||
08196 #ifdef KEY
08197 ATT_ALLOCATABLE_CPNT(TYP_IDX(type_idx)) ||
08198 #endif
08199 ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx)))) {
08200
08201 OPND_FLD(opnd) = AT_Tbl_Idx;
08202 OPND_IDX(opnd) = tmp_idx;
08203 OPND_LINE_NUM(opnd) = line;
08204 OPND_COL_NUM(opnd) = col;
08205
08206 if (ATD_ARRAY_IDX(tmp_idx) != NULL_IDX) {
08207 ok = gen_whole_subscript(&opnd, &exp_desc);
08208 }
08209
08210 process_cpnt_inits(&opnd,
08211 TYP_IDX(type_idx),
08212 gen_dv_whole_def_init,
08213 Asg_Opr,
08214 Before);
08215 }
08216
08217 #ifdef KEY
08218 if (fcn_to_sub)
08219 #else
08220 if (FUNCTION_MUST_BE_SUBROUTINE(attr_idx))
08221 #endif
08222 {
08223
08224
08225 OPND_FLD(opnd) = AT_Tbl_Idx;
08226 OPND_IDX(opnd) = tmp_idx;
08227 OPND_LINE_NUM(opnd) = line;
08228 OPND_COL_NUM(opnd) = col;
08229
08230 NTR_IR_TBL(loc_idx);
08231
08232 IR_OPR(loc_idx) = Aloc_Opr;
08233
08234
08235
08236 if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character &&
08237 ! ATD_IM_A_DOPE(tmp_idx)) {
08238 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
08239 }
08240 else {
08241 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
08242 }
08243
08244 if (ATD_ARRAY_IDX(tmp_idx) != NULL_IDX &&
08245 ! ATD_IM_A_DOPE(tmp_idx)) {
08246
08247 ok &= gen_whole_subscript(&opnd, &exp_desc);
08248
08249 # ifndef _FRONTEND_INLINER
08250 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
08251 ! ATP_ELEMENTAL(spec_idx)) {
08252
08253 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
08254 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
08255 }
08256 }
08257
08258 # endif
08259 if (! ATP_ELEMENTAL(spec_idx)) {
08260 unused1 = NULL_IDX;
08261 unused2 = NULL_IDX;
08262 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2);
08263 COPY_OPND(opnd, base_opnd);
08264 }
08265 }
08266 else if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character &&
08267 ! ATD_IM_A_DOPE(tmp_idx)) {
08268 ok = gen_whole_substring(&opnd,
08269 (ATD_ARRAY_IDX(tmp_idx) ?
08270 BD_RANK(ATD_ARRAY_IDX(tmp_idx)) : 0));
08271 }
08272
08273 IR_LINE_NUM(loc_idx) = line;
08274 IR_COL_NUM(loc_idx) = col;
08275
08276 COPY_OPND(IR_OPND_L(loc_idx), opnd);
08277
08278 # ifdef _TRANSFORM_CHAR_SEQUENCE
08279 if (! ATD_IM_A_DOPE(tmp_idx) &&
08280 TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Structure &&
08281 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(tmp_idx)))) {
08282
08283 transform_char_sequence_ref(&opnd,
08284 ATD_TYPE_IDX(tmp_idx));
08285 COPY_OPND(IR_OPND_L(loc_idx), opnd);
08286
08287 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
08288 }
08289 # endif
08290
08291
08292 IL_FLD(res_list_idx) = IR_Tbl_Idx;
08293 IL_IDX(res_list_idx) = loc_idx;
08294
08295 IR_RANK(ir_idx) = 0;
08296
08297 SH_IR_IDX(new_stmt_idx) = ir_idx;
08298 SH_P2_SKIP_ME(new_stmt_idx) = TRUE;
08299
08300 OPND_FLD((*result)) = AT_Tbl_Idx;
08301 OPND_IDX((*result)) = tmp_idx;
08302 OPND_LINE_NUM((*result)) = line;
08303 OPND_COL_NUM((*result)) = col;
08304
08305 if (ATD_IM_A_DOPE(tmp_idx)) {
08306 NTR_IR_TBL(dv_idx);
08307 IR_OPR(dv_idx) = Dv_Deref_Opr;
08308 IR_TYPE_IDX(dv_idx) = ATD_TYPE_IDX(tmp_idx);
08309 IR_LINE_NUM(dv_idx) = line;
08310 IR_COL_NUM(dv_idx) = col;
08311
08312 COPY_OPND(IR_OPND_L(dv_idx), (*result));
08313 OPND_FLD((*result)) = IR_Tbl_Idx;
08314 OPND_IDX((*result)) = dv_idx;
08315 }
08316
08317 if (ATD_ARRAY_IDX(tmp_idx)) {
08318 ok = gen_whole_subscript(result, &exp_desc);
08319 }
08320 else if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character) {
08321 ok = gen_whole_substring(result, 0);
08322 }
08323
08324 if (ATD_IM_A_DOPE(tmp_idx) &&
08325 ATD_ARRAY_IDX(tmp_idx) &&
08326 AT_IS_INTRIN(IR_IDX_L(ir_idx)) &&
08327 ATP_INTRIN_ENUM(IR_IDX_L(ir_idx)) != Spread_Intrinsic &&
08328 TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) != Character &&
08329 (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) != Structure ||
08330 ! ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(tmp_idx))))) {
08331
08332
08333
08334
08335 if (OPND_FLD((*result)) == IR_Tbl_Idx &&
08336 IR_OPR(OPND_IDX((*result))) == Whole_Subscript_Opr) {
08337
08338 IR_CONTIG_ARRAY(OPND_IDX((*result))) = TRUE;
08339 }
08340 }
08341 #ifdef KEY
08342
08343
08344
08345 if (ATD_ALLOCATABLE(attr_idx)) {
08346 int save_curr_stmt_sh_idx = curr_stmt_sh_idx;
08347
08348 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
08349 help_dealloc(line, col, AT_Tbl_Idx, tmp_idx, FALSE,
08350 TRUE, FALSE);
08351 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
08352 }
08353 #endif
08354 }
08355 else {
08356
08357
08358
08359
08360 ATD_ELEMENTAL_CALL_TMP(tmp_idx) = TRUE;
08361
08362 NTR_IR_TBL(asg_idx);
08363 IR_OPR(asg_idx) = Asg_Opr;
08364 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(attr_idx);
08365 IR_LINE_NUM(asg_idx) = IR_LINE_NUM(ir_idx);
08366 IR_COL_NUM(asg_idx) = IR_COL_NUM(ir_idx);
08367 ATD_TMP_IDX(tmp_idx) = asg_idx;
08368 ATD_FLD(tmp_idx) = IR_Tbl_Idx;
08369 AT_DEFINED(tmp_idx) = TRUE;
08370
08371 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
08372 IR_IDX_R(asg_idx) = ir_idx;
08373
08374 OPND_FLD(opnd) = AT_Tbl_Idx;
08375 OPND_IDX(opnd) = tmp_idx;
08376 OPND_LINE_NUM(opnd) = IR_LINE_NUM(ir_idx);
08377 OPND_COL_NUM(opnd) = IR_COL_NUM(ir_idx);
08378
08379 if (ATD_ARRAY_IDX(tmp_idx)) {
08380 ok = gen_whole_subscript(&opnd, &exp_desc);
08381 }
08382
08383 COPY_OPND(IR_OPND_L(asg_idx), opnd);
08384
08385 SH_IR_IDX(new_stmt_idx) = asg_idx;
08386 SH_P2_SKIP_ME(new_stmt_idx) = TRUE;
08387
08388 if (where_ir_idx) {
08389 change_asg_to_where(asg_idx);
08390 }
08391
08392 COPY_OPND((*result), opnd);
08393
08394 }
08395 }
08396 else {
08397 tmp_idx = get_stmt_tmp(ATD_TYPE_IDX(attr_idx),
08398 FALSE,
08399 0);
08400
08401 if (tmp_idx) {
08402 NTR_IR_TBL(asg_idx);
08403 IR_OPR(asg_idx) = Asg_Opr;
08404 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(attr_idx);
08405 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
08406 IR_IDX_L(asg_idx) = tmp_idx;
08407 IR_LINE_NUM_L(asg_idx) = IR_LINE_NUM(ir_idx);
08408 IR_LINE_NUM(asg_idx) = IR_LINE_NUM(ir_idx);
08409 IR_COL_NUM_L(asg_idx) = IR_COL_NUM(ir_idx);
08410 IR_COL_NUM(asg_idx) = IR_COL_NUM(ir_idx);
08411 ATD_TMP_IDX(tmp_idx) = asg_idx;
08412 ATD_FLD(tmp_idx) = IR_Tbl_Idx;
08413 AT_DEFINED(tmp_idx) = TRUE;
08414 #ifdef KEY
08415
08416 if ( ATD_F2C_ABI_VAR(attr_idx) ) {
08417 ATD_F2C_ABI_VAR(tmp_idx) = TRUE;
08418 ATD_TYPE_IDX(tmp_idx) = Real_4;
08419 }
08420 #endif
08421 }
08422 else {
08423 GEN_COMPILER_TMP_ASG(asg_idx,
08424 tmp_idx,
08425 TRUE,
08426 IR_LINE_NUM(ir_idx),
08427 IR_COL_NUM(ir_idx),
08428 ATD_TYPE_IDX(attr_idx),
08429 Priv);
08430 }
08431
08432 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
08433 IR_IDX_R(asg_idx) = ir_idx;
08434
08435 SH_IR_IDX(new_stmt_idx) = asg_idx;
08436 SH_P2_SKIP_ME(new_stmt_idx) = TRUE;
08437
08438 if (where_ir_idx) {
08439 change_asg_to_where(asg_idx);
08440 }
08441
08442 OPND_FLD((*result)) = AT_Tbl_Idx;
08443 OPND_IDX((*result)) = tmp_idx;
08444 OPND_LINE_NUM((*result)) = line;
08445 OPND_COL_NUM((*result)) = col;
08446
08447
08448
08449 }
08450
08451 orig_sh_idx = save_orig_sh_idx;
08452
08453 defer_stmt_expansion = save_defer_stmt_expansion;
08454 stmt_expansion_control_end(result);
08455
08456 EXIT:
08457
08458 TRACE (Func_Exit, "flatten_function_call", NULL);
08459
08460 return;
08461
08462 }
08463
08464
08465
08466
08467
08468
08469
08470
08471
08472
08473
08474
08475
08476
08477
08478
08479
08480 static int create_tmp_from_stmt_func(int sf_idx)
08481
08482 {
08483 int asg_idx;
08484 expr_arg_type exp_desc;
08485 opnd_type opnd;
08486 cif_usage_code_type save_xref_state;
08487 int tmp_idx;
08488
08489
08490 TRACE (Func_Entry, "create_tmp_from_stmt_func", NULL);
08491
08492 gen_opnd(&opnd, ATS_SF_IDX(sf_idx), (fld_type) ATS_SF_FLD(sf_idx),
08493 stmt_start_line, stmt_start_col);
08494 copy_subtree(&opnd, &opnd);
08495
08496
08497
08498
08499 exp_desc.rank = 0;
08500 save_xref_state = xref_state;
08501 xref_state = CIF_No_Usage_Rec;
08502 expr_semantics(&opnd, &exp_desc);
08503 xref_state = save_xref_state;
08504
08505 GEN_COMPILER_TMP_ASG(asg_idx,
08506 tmp_idx,
08507 TRUE,
08508 stmt_start_line,
08509 stmt_start_col,
08510 exp_desc.type_idx,
08511 Priv);
08512
08513
08514
08515
08516 update_components(&opnd);
08517
08518 COPY_OPND(IR_OPND_R(asg_idx), opnd);
08519
08520 gen_sh(Before, Assignment_Stmt, stmt_start_line,
08521 stmt_start_col, FALSE, FALSE, TRUE);
08522
08523 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
08524 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08525
08526 TRACE (Func_Exit, "create_tmp_from_stmt_func", NULL);
08527
08528 return(tmp_idx);
08529
08530 }
08531
08532
08533
08534
08535
08536
08537
08538
08539
08540
08541
08542
08543
08544
08545
08546
08547
08548
08549 static void make_new_bd_entries(int rslt_idx,
08550 int *new_type_idx,
08551 int *new_bd_idx)
08552
08553 {
08554 long attr_link_list[38];
08555 int attr_link_idx = NULL_IDX;
08556 int bd_idx;
08557 boolean constant_size_array;
08558 int dim;
08559 boolean had_variable_len_char = FALSE;
08560 int i;
08561 int ir_idx;
08562 int new_tmp_idx;
08563 boolean symbolic_constant_size_array;
08564 int tmp_idx;
08565 int type_idx;
08566 int ub_idx;
08567
08568
08569 TRACE (Func_Entry, "make_new_bd_entries", NULL);
08570
08571 type_idx = ATD_TYPE_IDX(rslt_idx);
08572 bd_idx = ATD_ARRAY_IDX(rslt_idx);
08573
08574 if (TYP_TYPE(type_idx) == Character &&
08575 (TYP_CHAR_CLASS(type_idx) == Var_Len_Char ||
08576 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char)) {
08577
08578
08579
08580
08581 if (TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) {
08582
08583 tmp_idx = TYP_IDX(type_idx);
08584 }
08585 else {
08586 tmp_idx = TYP_ORIG_LEN_IDX(type_idx);
08587 }
08588
08589 had_variable_len_char = TRUE;
08590
08591 new_tmp_idx = expand_user_bound(tmp_idx);
08592 attr_link_list[attr_link_idx++] = tmp_idx;
08593 tmp_idx = TYP_IDX(type_idx);
08594 new_tmp_idx = copy_and_replace_tmps(tmp_idx);
08595 attr_link_list[attr_link_idx++] = tmp_idx;
08596 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
08597
08598 if (ATD_CLASS(new_tmp_idx) == Constant) {
08599 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
08600 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx;
08601 TYP_IDX(TYP_WORK_IDX) = ATD_CONST_IDX(new_tmp_idx);
08602 }
08603 else {
08604 TYP_CHAR_CLASS(TYP_WORK_IDX) = Var_Len_Char;
08605 TYP_FLD(TYP_WORK_IDX) = AT_Tbl_Idx;
08606 TYP_IDX(TYP_WORK_IDX) = new_tmp_idx;
08607 TYP_ORIG_LEN_IDX(TYP_WORK_IDX) = new_tmp_idx;
08608 }
08609
08610 TYP_TYPE(TYP_WORK_IDX) = Character;
08611 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
08612 *new_type_idx = ntr_type_tbl();
08613 }
08614
08615 if (bd_idx != NULL_IDX &&
08616 ! ATD_IM_A_DOPE(rslt_idx) &&
08617 (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array ||
08618 had_variable_len_char)) {
08619
08620 *new_bd_idx = reserve_array_ntry(BD_RANK(bd_idx));
08621
08622 COPY_BD_NTRY(*new_bd_idx, bd_idx);
08623
08624 BD_LINE_NUM(*new_bd_idx) = stmt_start_line;
08625 BD_COLUMN_NUM(*new_bd_idx) = stmt_start_col;
08626 BD_RESOLVED(*new_bd_idx) = TRUE;
08627 constant_size_array = TRUE;
08628 symbolic_constant_size_array = FALSE;
08629
08630 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
08631
08632 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx &&
08633 !ATD_SYMBOLIC_CONSTANT(BD_LB_IDX(bd_idx,dim))) {
08634
08635 tmp_idx = BD_LB_IDX(bd_idx, dim);
08636 new_tmp_idx = expand_user_bound(tmp_idx);
08637 attr_link_list[attr_link_idx++] = tmp_idx;
08638
08639 if (ATD_CLASS(new_tmp_idx) == Constant) {
08640 BD_LB_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx);
08641 BD_LB_FLD(*new_bd_idx, dim) = CN_Tbl_Idx;
08642 }
08643 else {
08644
08645 # if defined(_TARGET_OS_MAX)
08646
08647 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) {
08648 symbolic_constant_size_array = TRUE;
08649 }
08650 else {
08651 constant_size_array = FALSE;
08652 }
08653 # else
08654 constant_size_array = FALSE;
08655 # endif
08656 gen_copyin_bounds_stmt(new_tmp_idx);
08657
08658 BD_LB_IDX(*new_bd_idx, dim) = new_tmp_idx;
08659 BD_LB_FLD(*new_bd_idx, dim) = AT_Tbl_Idx;
08660 }
08661 }
08662
08663 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx &&
08664 !ATD_SYMBOLIC_CONSTANT(BD_UB_IDX(bd_idx,dim))) {
08665 tmp_idx = BD_UB_IDX(bd_idx, dim);
08666 ub_idx = tmp_idx;
08667 new_tmp_idx = expand_user_bound(tmp_idx);
08668
08669 attr_link_list[attr_link_idx++] = tmp_idx;
08670
08671 if (ATD_CLASS(new_tmp_idx) == Constant) {
08672 BD_UB_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx);
08673 BD_UB_FLD(*new_bd_idx, dim) = CN_Tbl_Idx;
08674 }
08675 else {
08676
08677 # if defined(_TARGET_OS_MAX)
08678
08679 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) {
08680 symbolic_constant_size_array = TRUE;
08681 }
08682 else {
08683 constant_size_array = FALSE;
08684 }
08685 # else
08686 constant_size_array = FALSE;
08687 # endif
08688 gen_copyin_bounds_stmt(new_tmp_idx);
08689
08690 BD_UB_IDX(*new_bd_idx, dim) = new_tmp_idx;
08691 BD_UB_FLD(*new_bd_idx, dim) = AT_Tbl_Idx;
08692 }
08693 }
08694 else {
08695 ub_idx = NULL_IDX;
08696 }
08697
08698 if (BD_XT_FLD(bd_idx, dim) == AT_Tbl_Idx &&
08699 !ATD_SYMBOLIC_CONSTANT(BD_XT_IDX(bd_idx,dim))) {
08700
08701
08702
08703
08704
08705
08706
08707
08708
08709
08710
08711
08712
08713
08714
08715 tmp_idx = BD_XT_IDX(bd_idx, dim);
08716
08717 if (ATD_FLD(tmp_idx) == IR_Tbl_Idx) {
08718 ir_idx = IR_IDX_R(ATD_TMP_IDX(tmp_idx));
08719
08720 # ifdef _DEBUG
08721 if (IR_OPR(ir_idx) != Max_Opr ||
08722 IL_FLD(IR_IDX_L(ir_idx)) != AT_Tbl_Idx) {
08723 PRINTMSG(BD_LINE_NUM(bd_idx), 775, Internal,
08724 BD_COLUMN_NUM(bd_idx),
08725 AT_OBJ_NAME_PTR(tmp_idx),
08726 tmp_idx);
08727 }
08728 # endif
08729
08730 tmp_idx = IL_IDX(IR_IDX_L(ir_idx));
08731
08732 if (tmp_idx != ub_idx) {
08733 new_tmp_idx = copy_and_replace_tmps(tmp_idx);
08734 attr_link_list[attr_link_idx++] = tmp_idx;
08735 }
08736 }
08737
08738 tmp_idx = BD_XT_IDX(bd_idx, dim);
08739 new_tmp_idx = copy_and_replace_tmps(tmp_idx);
08740 attr_link_list[attr_link_idx++] = tmp_idx;
08741
08742 if (ATD_CLASS(new_tmp_idx) == Constant) {
08743 BD_XT_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx);
08744 BD_XT_FLD(*new_bd_idx, dim) = CN_Tbl_Idx;
08745 }
08746 else {
08747
08748 # if defined(_TARGET_OS_MAX)
08749
08750 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) {
08751 symbolic_constant_size_array = TRUE;
08752 }
08753 else {
08754 constant_size_array = FALSE;
08755 }
08756 # else
08757 constant_size_array = FALSE;
08758 # endif
08759 gen_copyin_bounds_stmt(new_tmp_idx);
08760
08761 BD_XT_IDX(*new_bd_idx, dim) = new_tmp_idx;
08762 BD_XT_FLD(*new_bd_idx, dim) = AT_Tbl_Idx;
08763 }
08764 }
08765
08766 if (BD_SM_FLD(bd_idx, dim) == AT_Tbl_Idx &&
08767 !ATD_SYMBOLIC_CONSTANT(BD_SM_IDX(bd_idx, dim))) {
08768 tmp_idx = BD_SM_IDX(bd_idx, dim);
08769 new_tmp_idx = copy_and_replace_tmps(tmp_idx);
08770 attr_link_list[attr_link_idx++] = tmp_idx;
08771
08772 if (ATD_CLASS(new_tmp_idx) == Constant) {
08773 BD_SM_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx);
08774 BD_SM_FLD(*new_bd_idx, dim) = CN_Tbl_Idx;
08775 }
08776 else {
08777
08778 # if defined(_TARGET_OS_MAX)
08779
08780 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) {
08781 symbolic_constant_size_array = TRUE;
08782 }
08783 else {
08784 constant_size_array = FALSE;
08785 }
08786 # else
08787 constant_size_array = FALSE;
08788 # endif
08789 BD_SM_IDX(*new_bd_idx, dim) = new_tmp_idx;
08790 BD_SM_FLD(*new_bd_idx, dim) = AT_Tbl_Idx;
08791 }
08792 }
08793 }
08794
08795 if (BD_LEN_FLD(bd_idx) == AT_Tbl_Idx &&
08796 !ATD_SYMBOLIC_CONSTANT(BD_LEN_IDX(bd_idx))) {
08797 tmp_idx = BD_LEN_IDX(bd_idx);
08798 new_tmp_idx = copy_and_replace_tmps(tmp_idx);
08799 attr_link_list[attr_link_idx++]= tmp_idx;
08800
08801 if (ATD_CLASS(new_tmp_idx) == Constant) {
08802 BD_LEN_IDX(*new_bd_idx) = ATD_CONST_IDX(new_tmp_idx);
08803 BD_LEN_FLD(*new_bd_idx) = CN_Tbl_Idx;
08804 }
08805 else {
08806
08807 # if defined(_TARGET_OS_MAX)
08808
08809 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) {
08810 symbolic_constant_size_array = TRUE;
08811 }
08812 else {
08813 constant_size_array = FALSE;
08814 }
08815 # else
08816 constant_size_array = FALSE;
08817 # endif
08818 BD_LEN_IDX(*new_bd_idx) = new_tmp_idx;
08819 BD_LEN_FLD(*new_bd_idx) = AT_Tbl_Idx;
08820 }
08821 }
08822
08823 if (constant_size_array) {
08824 BD_ARRAY_SIZE(*new_bd_idx) = Constant_Size;
08825 }
08826
08827 BD_FLOW_DEPENDENT(*new_bd_idx) = TRUE;
08828 *new_bd_idx = ntr_array_in_bd_tbl(*new_bd_idx);
08829 }
08830
08831 for (i = 0; i < attr_link_idx; i++) {
08832 AT_ATTR_LINK(attr_link_list[i]) = NULL_IDX;
08833 }
08834
08835 TRACE (Func_Exit, "make_new_bd_entries", NULL);
08836
08837 return;
08838
08839 }
08840
08841
08842
08843
08844
08845
08846
08847
08848
08849
08850
08851
08852
08853
08854
08855
08856
08857
08858
08859
08860
08861
08862
08863
08864
08865
08866
08867
08868 static int copy_and_replace_tmps(int attr_idx)
08869
08870 {
08871 expr_arg_type exp_desc;
08872 int ir_idx;
08873 opnd_type opnd;
08874 cif_usage_code_type save_xref_state;
08875 int tmp_attr_idx;
08876
08877
08878 TRACE (Func_Entry, "copy_and_replace_tmps", NULL);
08879
08880 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx)));
08881 copy_subtree(&opnd, &opnd);
08882
08883 exp_desc.rank = 0;
08884 save_xref_state = xref_state;
08885 xref_state = CIF_No_Usage_Rec;
08886
08887 expr_semantics(&opnd, &exp_desc);
08888
08889 xref_state = save_xref_state;
08890
08891 if (OPND_FLD(opnd) == CN_Tbl_Idx) {
08892 tmp_attr_idx = gen_compiler_tmp(stmt_start_line,
08893 stmt_start_col,
08894 Priv, TRUE);
08895 ATD_CLASS(tmp_attr_idx) = Constant;
08896 AT_TYPED(tmp_attr_idx) = TRUE;
08897 ATD_TYPE_IDX(tmp_attr_idx) = exp_desc.type_idx;
08898 AT_DEFINED(tmp_attr_idx) = FALSE;
08899 AT_REFERENCED(tmp_attr_idx) = Not_Referenced;
08900 AT_SEMANTICS_DONE(tmp_attr_idx) = TRUE;
08901 ATD_CONST_IDX(tmp_attr_idx) = OPND_IDX(opnd);
08902 ATD_FLD(tmp_attr_idx) = CN_Tbl_Idx;
08903 }
08904 else {
08905 GEN_COMPILER_TMP_ASG(ir_idx,
08906 tmp_attr_idx,
08907 TRUE,
08908 stmt_start_line,
08909 stmt_start_col,
08910 exp_desc.type_idx,
08911 Priv);
08912
08913 COPY_OPND(IR_OPND_R(ATD_TMP_IDX(tmp_attr_idx)), opnd);
08914
08915 gen_sh(Before, Assignment_Stmt, stmt_start_line,
08916 stmt_start_col, FALSE, FALSE, TRUE);
08917
08918 AT_DEFINED(tmp_attr_idx) = TRUE;
08919 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
08920 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
08921 }
08922
08923 AT_ATTR_LINK(attr_idx) = tmp_attr_idx;
08924
08925 TRACE (Func_Exit, "copy_and_replace_tmps", NULL);
08926
08927 return(tmp_attr_idx);
08928
08929 }
08930
08931
08932
08933
08934
08935
08936
08937
08938
08939
08940
08941
08942
08943
08944
08945
08946
08947
08948
08949
08950
08951 static int expand_user_bound(int tmp_idx)
08952
08953 {
08954 int const_idx;
08955 int ir_idx;
08956 int new_tmp_idx;
08957 opnd_type opnd;
08958 int sf_attr_idx;
08959 int sh_idx;
08960
08961
08962 TRACE (Func_Exit, "expand_user_bound", NULL);
08963
08964
08965
08966
08967 NTR_ATTR_TBL(sf_attr_idx);
08968 AT_OBJ_CLASS(sf_attr_idx) = Stmt_Func;
08969 AT_COMPILER_GEND(sf_attr_idx)= TRUE;
08970 ATD_TYPE_IDX(sf_attr_idx) = CG_INTEGER_DEFAULT_TYPE;
08971 ATS_SF_FLD(sf_attr_idx) = IR_FLD_R(ATD_TMP_IDX(tmp_idx));
08972 ATS_SF_IDX(sf_attr_idx) = IR_IDX_R(ATD_TMP_IDX(tmp_idx));
08973
08974 new_tmp_idx = create_tmp_from_stmt_func(sf_attr_idx);
08975 AT_ATTR_LINK(tmp_idx) = new_tmp_idx;
08976 OPND_FLD(opnd) = IR_FLD_R(ATD_TMP_IDX(new_tmp_idx));
08977 OPND_IDX(opnd) = IR_IDX_R(ATD_TMP_IDX(new_tmp_idx));
08978
08979 if (OPND_FLD(opnd) == CN_Tbl_Idx) {
08980 const_idx = OPND_IDX(opnd);
08981 CLEAR_VARIANT_ATTR_INFO(new_tmp_idx, Data_Obj);
08982 ATD_CLASS(new_tmp_idx) = Constant;
08983 AT_TYPED(new_tmp_idx) = TRUE;
08984 ATD_TYPE_IDX(new_tmp_idx) = CN_TYPE_IDX(const_idx);
08985 AT_DEFINED(new_tmp_idx) = FALSE;
08986 AT_REFERENCED(new_tmp_idx) = Not_Referenced;
08987 ATD_CONST_IDX(new_tmp_idx) = const_idx;
08988 ATD_FLD(new_tmp_idx) = CN_Tbl_Idx;
08989
08990
08991
08992 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
08993 remove_sh(sh_idx);
08994 FREE_IR_NODE(SH_IR_IDX(sh_idx));
08995 FREE_SH_NODE(sh_idx);
08996 }
08997
08998 # if defined(_TARGET_OS_MAX)
08999
09000 else if (expr_is_symbolic_constant(&opnd)) {
09001 ATD_SYMBOLIC_CONSTANT(new_tmp_idx) = TRUE;
09002 AT_DEFINED(new_tmp_idx) = FALSE;
09003 AT_REFERENCED(new_tmp_idx) = Not_Referenced;
09004 ATD_FLD(new_tmp_idx) = OPND_FLD(opnd);
09005 ATD_TMP_IDX(new_tmp_idx) = OPND_IDX(opnd);
09006
09007
09008
09009 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
09010 remove_sh(sh_idx);
09011 FREE_IR_NODE(SH_IR_IDX(sh_idx));
09012 FREE_SH_NODE(sh_idx);
09013 }
09014
09015 # endif
09016
09017 else {
09018 AT_DEFINED(new_tmp_idx) = TRUE;
09019 AT_REFERENCED(new_tmp_idx) = Referenced;
09020
09021 if (ATD_FLD(new_tmp_idx) == AT_Tbl_Idx) {
09022 find_attrs_used_in_bound(ATD_TMP_IDX(new_tmp_idx));
09023 }
09024 else if (ATD_FLD(new_tmp_idx) == IR_Tbl_Idx) {
09025 ir_idx = ATD_TMP_IDX(new_tmp_idx);
09026
09027 switch (IR_FLD_R(ir_idx)) {
09028 case AT_Tbl_Idx:
09029 find_attrs_used_in_bound(IR_IDX_R(ir_idx));
09030 break;
09031
09032 case IR_Tbl_Idx:
09033 find_attrs_in_ir(IR_IDX_R(ir_idx));
09034 break;
09035
09036 case IL_Tbl_Idx:
09037 find_attrs_in_il(IR_IDX_R(ir_idx));
09038 break;
09039 }
09040 }
09041 }
09042
09043 TRACE (Func_Exit, "expand_user_bound", NULL);
09044
09045 return(new_tmp_idx);
09046
09047 }
09048
09049
09050
09051
09052
09053
09054
09055
09056
09057
09058
09059
09060
09061
09062
09063 static void find_attrs_used_in_bound(int attr_idx)
09064
09065 {
09066 int asg_idx;
09067 int ir_idx;
09068 int list_idx;
09069 int name_idx;
09070 int old_attr_idx;
09071
09072
09073 TRACE (Func_Entry, "find_attrs_used_in_bound", NULL);
09074
09075 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
09076
09077 if (ATD_CLASS(attr_idx) == Struct_Component) {
09078 return;
09079 }
09080
09081 if (ATD_CLASS(attr_idx) == Function_Result) {
09082 attr_idx = ATD_FUNC_IDX(attr_idx);
09083 }
09084 }
09085
09086 old_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(attr_idx),
09087 AT_NAME_LEN(attr_idx),
09088 &name_idx);
09089
09090
09091
09092 if (old_attr_idx == attr_idx) {
09093 return;
09094 }
09095 else if (old_attr_idx != NULL_IDX &&
09096 AT_OBJ_CLASS(old_attr_idx) == Interface &&
09097 ATI_PROC_IDX(old_attr_idx) != NULL_IDX &&
09098 attr_idx == ATI_PROC_IDX(old_attr_idx)) {
09099 return;
09100 }
09101
09102 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
09103 ATD_CLASS(attr_idx) == Compiler_Tmp) {
09104
09105 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) {
09106 find_attrs_used_in_bound(ATD_TMP_IDX(attr_idx));
09107 }
09108 else if (ATD_FLD(attr_idx) == IR_Tbl_Idx) {
09109 ir_idx = ATD_TMP_IDX(attr_idx);
09110
09111 switch (IR_FLD_R(ir_idx)) {
09112 case AT_Tbl_Idx:
09113 find_attrs_used_in_bound(IR_IDX_R(ir_idx));
09114 break;
09115
09116 case IR_Tbl_Idx:
09117 find_attrs_in_ir(IR_IDX_R(ir_idx));
09118 break;
09119
09120 case IL_Tbl_Idx:
09121 find_attrs_in_il(IR_IDX_R(ir_idx));
09122 break;
09123 }
09124 }
09125 else if (ATD_FLD(attr_idx) == CN_Tbl_Idx) {
09126
09127 if (SB_ORIG_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) {
09128
09129
09130
09131
09132
09133
09134
09135
09136
09137
09138
09139
09140
09141 NTR_IR_TBL(asg_idx);
09142 IR_OPR(asg_idx) = Init_Opr;
09143 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
09144 IR_LINE_NUM(asg_idx) = AT_DEF_LINE(attr_idx);
09145 IR_COL_NUM(asg_idx) = AT_DEF_COLUMN(attr_idx);
09146 IR_LINE_NUM_L(asg_idx) = AT_DEF_LINE(attr_idx);
09147 IR_COL_NUM_L(asg_idx) = AT_DEF_COLUMN(attr_idx);
09148 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
09149 IR_IDX_L(asg_idx) = attr_idx;
09150 AT_DEFINED(attr_idx) = TRUE;
09151
09152 NTR_IR_LIST_TBL(list_idx);
09153 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
09154 IR_IDX_R(asg_idx) = list_idx;
09155 IR_LIST_CNT_R(asg_idx) = 3;
09156
09157 IL_FLD(list_idx) = CN_Tbl_Idx;
09158 IL_IDX(list_idx) = ATD_TMP_IDX(attr_idx);
09159 IL_LINE_NUM(list_idx) = AT_DEF_LINE(attr_idx);
09160 IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
09161
09162 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
09163 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
09164
09165 list_idx = IL_NEXT_LIST_IDX(list_idx);
09166 IL_FLD(list_idx) = CN_Tbl_Idx;
09167 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
09168 IL_LINE_NUM(list_idx) = AT_DEF_LINE(attr_idx);
09169 IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
09170
09171 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
09172 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
09173
09174 list_idx = IL_NEXT_LIST_IDX(list_idx);
09175 IL_FLD(list_idx) = CN_Tbl_Idx;
09176 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
09177 IL_LINE_NUM(list_idx) = AT_DEF_LINE(attr_idx);
09178 IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
09179
09180 gen_sh(Before,
09181 Assignment_Stmt,
09182 AT_DEF_LINE(attr_idx),
09183 AT_DEF_COLUMN(attr_idx),
09184 FALSE,
09185 FALSE,
09186 TRUE);
09187
09188 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
09189 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
09190 }
09191 }
09192 }
09193
09194 AT_REFERENCED(attr_idx) = Referenced;
09195
09196 host_associated_attr_semantics(attr_idx, TRUE);
09197
09198 TRACE (Func_Exit, "find_attrs_used_in_bound", NULL);
09199
09200 return;
09201
09202 }
09203
09204
09205
09206
09207
09208
09209
09210
09211
09212
09213
09214
09215
09216
09217
09218 static void find_attrs_in_ir(int ir_idx)
09219 {
09220
09221 TRACE (Func_Entry, "find_attrs_in_ir", NULL);
09222
09223 switch (IR_FLD_L(ir_idx)) {
09224 case AT_Tbl_Idx:
09225 find_attrs_used_in_bound(IR_IDX_L(ir_idx));
09226 break;
09227
09228 case IR_Tbl_Idx:
09229 find_attrs_in_ir(IR_IDX_L(ir_idx));
09230 break;
09231
09232 case IL_Tbl_Idx:
09233 find_attrs_in_il(IR_IDX_L(ir_idx));
09234 break;
09235 }
09236
09237 switch (IR_FLD_R(ir_idx)) {
09238 case AT_Tbl_Idx:
09239 find_attrs_used_in_bound(IR_IDX_R(ir_idx));
09240 break;
09241
09242 case IR_Tbl_Idx:
09243 find_attrs_in_ir(IR_IDX_R(ir_idx));
09244 break;
09245
09246 case IL_Tbl_Idx:
09247 find_attrs_in_il(IR_IDX_R(ir_idx));
09248 break;
09249 }
09250
09251 TRACE (Func_Exit, "find_attrs_in_ir", NULL);
09252
09253 return;
09254
09255 }
09256
09257
09258
09259
09260
09261
09262
09263
09264
09265
09266
09267
09268
09269
09270
09271 static void find_attrs_in_il(int list_idx)
09272 {
09273
09274 TRACE (Func_Entry, "find_attrs_in_il", NULL);
09275
09276 while (list_idx != NULL_IDX) {
09277
09278 switch (IL_FLD(list_idx)) {
09279
09280 case AT_Tbl_Idx:
09281 find_attrs_used_in_bound(IL_IDX(list_idx));
09282 break;
09283
09284 case IR_Tbl_Idx:
09285 find_attrs_in_ir(IL_IDX(list_idx));
09286 break;
09287
09288 case IL_Tbl_Idx:
09289 find_attrs_in_il(IL_IDX(list_idx));
09290 break;
09291
09292 }
09293 list_idx = IL_NEXT_LIST_IDX(list_idx);
09294 }
09295
09296 TRACE (Func_Exit, "find_attrs_in_il", NULL);
09297
09298 return;
09299
09300 }
09301
09302
09303
09304
09305
09306
09307
09308
09309
09310
09311
09312
09313
09314
09315
09316
09317
09318
09319
09320
09321
09322
09323
09324 int get_stmt_tmp(int type_idx,
09325 boolean dope_vector,
09326 int rank)
09327
09328 {
09329
09330 linear_type_type linear_type;
09331 int list_idx;
09332 int tmp_idx = NULL_IDX;
09333
09334 # if 0
09335 int save_curr_stmt_sh_idx;
09336 # endif
09337
09338
09339 TRACE (Func_Entry, "get_stmt_tmp", NULL);
09340
09341 if (comp_phase != Pass2_Semantics) {
09342 goto EXIT;
09343 }
09344
09345 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
09346 if (dump_flags.mp) {
09347 goto EXIT;
09348 }
09349 # endif
09350
09351 if (cdir_switches.parallel_region) {
09352 goto EXIT;
09353 }
09354
09355 linear_type = TYP_LINEAR(type_idx);
09356
09357 if (stmt_tmp_tbl[linear_type].scalar_tmps_head < 0) {
09358 goto EXIT;
09359 }
09360
09361 if (! dope_vector && rank != 0) {
09362 goto EXIT;
09363 }
09364
09365 if (dope_vector) {
09366
09367 if (stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] == NULL_IDX) {
09368
09369 goto EXIT;
09370 # if 0
09371
09372
09373 tmp_idx = gen_compiler_tmp(stmt_start_line,
09374 stmt_start_col,
09375 Priv, TRUE);
09376 ATD_TYPE_IDX(tmp_idx) = type_idx;
09377 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
09378 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
09379
09380 if (rank) {
09381
09382 ATD_ARRAY_IDX(tmp_idx) = rank;
09383 }
09384
09385 ATD_IM_A_DOPE(tmp_idx) = TRUE;
09386
09387 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
09388 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
09389
09390 gen_entry_dope_code(tmp_idx);
09391
09392 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
09393
09394 NTR_IR_LIST_TBL(list_idx);
09395 IL_LINE_NUM(list_idx) = stmt_start_line;
09396 IL_COL_NUM(list_idx) = stmt_start_col;
09397 IL_IDX(list_idx) = tmp_idx;
09398 IL_FLD(list_idx) = AT_Tbl_Idx;
09399 stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] = list_idx;
09400 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank] = list_idx;
09401 # endif
09402 }
09403 else {
09404
09405 list_idx = stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank];
09406
09407 if (IL_LINE_NUM(list_idx) == stmt_start_line &&
09408 IL_COL_NUM(list_idx) == stmt_start_col) {
09409
09410
09411
09412
09413 goto EXIT;
09414 # if 0
09415 tmp_idx = gen_compiler_tmp(stmt_start_line,
09416 stmt_start_col,
09417 Priv, TRUE);
09418 ATD_TYPE_IDX(tmp_idx) = type_idx;
09419 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
09420 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
09421
09422 if (rank) {
09423
09424 ATD_ARRAY_IDX(tmp_idx) = rank;
09425 }
09426
09427 ATD_IM_A_DOPE(tmp_idx) = TRUE;
09428
09429 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
09430 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
09431
09432 gen_entry_dope_code(tmp_idx);
09433
09434 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
09435
09436 NTR_IR_LIST_TBL(list_idx);
09437 IL_LINE_NUM(list_idx) = stmt_start_line;
09438 IL_COL_NUM(list_idx) = stmt_start_col;
09439 IL_IDX(list_idx) = tmp_idx;
09440 IL_FLD(list_idx) = AT_Tbl_Idx;
09441
09442 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type].
09443 dope_vector_tmps_tail[rank]) = list_idx;
09444 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank] = list_idx;
09445 # endif
09446
09447 }
09448 else {
09449 tmp_idx = IL_IDX(list_idx);
09450 IL_LINE_NUM(list_idx) = stmt_start_line;
09451 IL_COL_NUM(list_idx) = stmt_start_col;
09452
09453
09454
09455 if (stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] ==
09456 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank]) {
09457
09458
09459 }
09460 else {
09461 stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] =
09462 IL_NEXT_LIST_IDX(list_idx);
09463 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type].
09464 dope_vector_tmps_tail[rank]) = list_idx;
09465 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank] = list_idx;
09466 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
09467 }
09468 }
09469 }
09470 }
09471 else {
09472
09473 if (stmt_tmp_tbl[linear_type].scalar_tmps_head == NULL_IDX) {
09474
09475
09476
09477 tmp_idx = gen_compiler_tmp(stmt_start_line,
09478 stmt_start_col,
09479 Priv, TRUE);
09480 ATD_TYPE_IDX(tmp_idx) = type_idx;
09481 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
09482 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
09483
09484 NTR_IR_LIST_TBL(list_idx);
09485 IL_LINE_NUM(list_idx) = stmt_start_line;
09486 IL_COL_NUM(list_idx) = stmt_start_col;
09487 IL_IDX(list_idx) = tmp_idx;
09488 IL_FLD(list_idx) = AT_Tbl_Idx;
09489 stmt_tmp_tbl[linear_type].scalar_tmps_head = list_idx;
09490 stmt_tmp_tbl[linear_type].scalar_tmps_tail = list_idx;
09491 }
09492 else {
09493
09494 list_idx = stmt_tmp_tbl[linear_type].scalar_tmps_head;
09495
09496 if (IL_LINE_NUM(list_idx) == stmt_start_line &&
09497 IL_COL_NUM(list_idx) == stmt_start_col) {
09498
09499
09500
09501
09502 tmp_idx = gen_compiler_tmp(stmt_start_line,
09503 stmt_start_col,
09504 Priv, TRUE);
09505 ATD_TYPE_IDX(tmp_idx) = type_idx;
09506 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
09507 AT_SEMANTICS_DONE(tmp_idx) = TRUE;
09508
09509 NTR_IR_LIST_TBL(list_idx);
09510 IL_LINE_NUM(list_idx) = stmt_start_line;
09511 IL_COL_NUM(list_idx) = stmt_start_col;
09512 IL_IDX(list_idx) = tmp_idx;
09513 IL_FLD(list_idx) = AT_Tbl_Idx;
09514
09515 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type].scalar_tmps_tail) =
09516 list_idx;
09517 stmt_tmp_tbl[linear_type].scalar_tmps_tail = list_idx;
09518
09519 }
09520 else {
09521 tmp_idx = IL_IDX(list_idx);
09522 IL_LINE_NUM(list_idx) = stmt_start_line;
09523 IL_COL_NUM(list_idx) = stmt_start_col;
09524
09525
09526
09527 if (stmt_tmp_tbl[linear_type].scalar_tmps_head ==
09528 stmt_tmp_tbl[linear_type].scalar_tmps_tail) {
09529
09530
09531 }
09532 else {
09533 stmt_tmp_tbl[linear_type].scalar_tmps_head =
09534 IL_NEXT_LIST_IDX(list_idx);
09535 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type].scalar_tmps_tail) =
09536 list_idx;
09537 stmt_tmp_tbl[linear_type].scalar_tmps_tail = list_idx;
09538 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
09539 }
09540 }
09541 }
09542 }
09543
09544 EXIT:
09545
09546 if (tmp_idx) {
09547 ATD_ASG_TMP(tmp_idx) = FALSE;
09548 ATD_ELEMENTAL_CALL_TMP(tmp_idx) = FALSE;
09549 }
09550
09551 TRACE (Func_Exit, "get_stmt_tmp", NULL);
09552
09553 return(tmp_idx);
09554
09555 }
09556
09557
09558
09559
09560
09561
09562
09563
09564
09565
09566
09567
09568
09569
09570
09571
09572
09573 static void process_variable_size_func(int rslt_idx,
09574 int arg_list_idx,
09575 int sf_darg_idx,
09576 int sf_num_dargs,
09577 int *new_type_idx,
09578 int *new_bd_idx)
09579
09580 {
09581 int a_list_idx;
09582 int association;
09583 int bd_idx;
09584 int column;
09585 int dummy_idx;
09586 int d_bd_idx;
09587 int d_type_idx;
09588 expr_arg_type exp_desc;
09589 int i;
09590 int ir_idx;
09591 int k;
09592 int line;
09593 int list_idx;
09594 opnd_type list_opnd;
09595 opnd_type opnd;
09596 boolean save_variable_size_func_expr;
09597 int sn_idx;
09598 int tmp_dv_idx;
09599 int type_idx;
09600
09601
09602 TRACE (Func_Entry, "process_variable_size_func", NULL);
09603
09604 sn_idx = sf_darg_idx;
09605
09606 a_list_idx = arg_list_idx;
09607
09608 for (i = sf_num_dargs; i > 0; i--) {
09609 if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Data_Obj) {
09610 ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = TRUE;
09611 }
09612 else if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Pgm_Unit &&
09613 ATP_PROC(SN_ATTR_IDX(sn_idx)) == Dummy_Proc) {
09614
09615 ATP_DUMMY_PROC_LINK(SN_ATTR_IDX(sn_idx)) = IL_IDX(a_list_idx);
09616 }
09617
09618 sn_idx++;
09619 a_list_idx = IL_NEXT_LIST_IDX(a_list_idx);
09620 }
09621
09622 type_idx = ATD_TYPE_IDX(rslt_idx);
09623 bd_idx = ATD_ARRAY_IDX(rslt_idx);
09624
09625 list_opnd = null_opnd;
09626
09627 check_bd_typ_for_dargs(bd_idx,
09628 type_idx,
09629 &list_opnd);
09630
09631 list_idx = OPND_IDX(list_opnd);
09632
09633
09634
09635 for (i = 0; i < OPND_LIST_CNT(list_opnd); i++) {
09636 sn_idx = sf_darg_idx;
09637 a_list_idx = arg_list_idx;
09638 dummy_idx = IL_IDX(list_idx);
09639
09640
09641
09642
09643 for (k = 0; k < sf_num_dargs; k++) {
09644 if (SN_ATTR_IDX(sn_idx) == dummy_idx) {
09645 goto FOUND;
09646 }
09647 sn_idx++;
09648 a_list_idx = IL_NEXT_LIST_IDX(a_list_idx);
09649 }
09650
09651 # ifdef _DEBUG
09652 print_at(dummy_idx);
09653 # endif
09654 PRINTMSG(stmt_start_line, 1020, Internal, stmt_start_col);
09655
09656 FOUND:
09657
09658 if (AT_OBJ_CLASS(dummy_idx) == Data_Obj) {
09659
09660 ATD_SF_LINK(dummy_idx) = IL_ARG_DESC_IDX(a_list_idx);
09661
09662 association = arg_info_list[IL_ARG_DESC_IDX(a_list_idx)].association;
09663
09664 COPY_OPND(opnd, IL_OPND(a_list_idx));
09665
09666 switch (association) {
09667 case PASS_ADDRESS:
09668 case PASS_SECTION_ADDRESS :
09669 case PASS_DV :
09670 case PASS_DV_COPY :
09671 case COPY_IN :
09672 case COPY_IN_COPY_OUT :
09673 case MAKE_DV :
09674 case COPY_IN_MAKE_DV :
09675 #ifdef KEY
09676 case COPY_INOUT_MAKE_DV :
09677 #endif
09678 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
09679 (IR_OPR(OPND_IDX(opnd)) == Loc_Opr ||
09680 IR_OPR(OPND_IDX(opnd)) == Aloc_Opr ||
09681 IR_OPR(OPND_IDX(opnd)) == Const_Tmp_Loc_Opr)) {
09682
09683 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
09684 }
09685 break;
09686
09687 case CHECK_CONTIG_FLAG :
09688
09689 break;
09690
09691 case PASS_ADDRESS_FROM_DV:
09692 if (arg_info_list[IL_ARG_DESC_IDX(a_list_idx)].ed.rank == 0) {
09693 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
09694 }
09695 break;
09696 }
09697
09698 if (ATD_ARRAY_IDX(dummy_idx) != NULL_IDX &&
09699 ! ATD_IM_A_DOPE(dummy_idx)) {
09700
09701
09702
09703
09704
09705
09706 d_bd_idx = ATD_ARRAY_IDX(dummy_idx);
09707 d_type_idx = ATD_TYPE_IDX(dummy_idx);
09708
09709 if (TYP_TYPE(d_type_idx) == Character &&
09710 TYP_CHAR_CLASS(d_type_idx) == Assumed_Size_Char) {
09711
09712
09713
09714 if (association == CHECK_CONTIG_FLAG) {
09715 ATD_FLD(dummy_idx) = ATD_FLD(OPND_IDX(opnd));
09716 ATD_SF_ARG_IDX(dummy_idx) = ATD_TMP_IDX(OPND_IDX(opnd));
09717 }
09718 else {
09719 ATD_FLD(dummy_idx) = OPND_FLD(opnd);
09720 ATD_SF_ARG_IDX(dummy_idx) = OPND_IDX(opnd);
09721 }
09722 }
09723
09724 if ((TYP_TYPE(d_type_idx) == Character &&
09725 (TYP_CHAR_CLASS(d_type_idx) == Var_Len_Char ||
09726 TYP_CHAR_CLASS(d_type_idx) == Assumed_Size_Char)) ||
09727 BD_ARRAY_SIZE(d_bd_idx) == Var_Len_Array) {
09728
09729 make_new_bd_entries(dummy_idx,
09730 &d_type_idx,
09731 &d_bd_idx);
09732 }
09733
09734
09735 exp_desc = arg_info_list[IL_ARG_DESC_IDX(a_list_idx)].ed;
09736
09737 exp_desc.rank = BD_RANK(d_bd_idx);
09738 for (k = 0; k < BD_RANK(d_bd_idx); k++) {
09739 exp_desc.shape[k].fld = BD_XT_FLD(d_bd_idx, k + 1);
09740 exp_desc.shape[k].idx = BD_XT_IDX(d_bd_idx, k + 1);
09741 }
09742 exp_desc.dope_vector = TRUE;
09743
09744 arg_info_list_base = arg_info_list_top;
09745 arg_info_list_top = arg_info_list_base + 1;
09746
09747 if (arg_info_list_top >= arg_info_list_size) {
09748 enlarge_info_list_table();
09749 }
09750
09751 ATD_SF_LINK(dummy_idx) = arg_info_list_top;
09752 arg_info_list[arg_info_list_top] = init_arg_info;
09753 arg_info_list[arg_info_list_top].ed = exp_desc;
09754
09755 tmp_dv_idx = gen_sf_dv_whole_def(&opnd, d_type_idx, d_bd_idx);
09756
09757 find_opnd_line_and_column(&opnd, &line, &column);
09758
09759 NTR_IR_TBL(ir_idx);
09760 IR_OPR(ir_idx) = Dv_Deref_Opr;
09761 IR_TYPE_IDX(ir_idx) = type_idx;
09762 IR_LINE_NUM(ir_idx) = line;
09763 IR_COL_NUM(ir_idx) = column;
09764 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
09765 IR_IDX_L(ir_idx) = tmp_dv_idx;
09766 IR_LINE_NUM_L(ir_idx) = line;
09767 IR_COL_NUM_L(ir_idx) = column;
09768
09769 OPND_FLD(opnd) = IR_Tbl_Idx;
09770 OPND_IDX(opnd) = ir_idx;
09771 }
09772
09773 ATD_FLD(dummy_idx) = OPND_FLD(opnd);
09774 ATD_SF_ARG_IDX(dummy_idx) = OPND_IDX(opnd);
09775
09776 if (ATD_ARRAY_IDX(dummy_idx) &&
09777 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy_idx)) == Assumed_Shape) {
09778
09779 # ifdef _DEBUG
09780 if (OPND_FLD(opnd) != AT_Tbl_Idx ||
09781 AT_OBJ_CLASS(OPND_IDX(opnd)) != Data_Obj ||
09782 ATD_CLASS(OPND_IDX(opnd)) != Compiler_Tmp) {
09783 PRINTMSG(stmt_start_line, 626, Internal,
09784 stmt_start_col,
09785 "Compiler_Tmp", "process_variable_size_func");
09786 }
09787 # endif
09788
09789 ATD_RESHAPE_ARRAY_IDX(OPND_IDX(opnd)) =
09790 ATD_ARRAY_IDX(OPND_IDX(opnd));
09791 ATD_ARRAY_IDX(OPND_IDX(opnd)) = ATD_ARRAY_IDX(dummy_idx);
09792 }
09793 }
09794
09795
09796 list_idx = IL_NEXT_LIST_IDX(list_idx);
09797 }
09798
09799
09800 save_variable_size_func_expr = variable_size_func_expr;
09801 variable_size_func_expr = TRUE;
09802
09803
09804
09805 make_new_bd_entries(rslt_idx,
09806 new_type_idx,
09807 new_bd_idx);
09808
09809 variable_size_func_expr = save_variable_size_func_expr;
09810
09811 sn_idx = sf_darg_idx;
09812
09813 for (i = sf_num_dargs; i > 0; i--) {
09814 if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Data_Obj) {
09815 ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = FALSE;
09816
09817 if (ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx)) &&
09818 BD_ARRAY_CLASS(ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx))) ==
09819 Assumed_Shape &&
09820 ATD_FLD(SN_ATTR_IDX(sn_idx)) == AT_Tbl_Idx &&
09821 ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx)) != NULL_IDX) {
09822
09823 ATD_ARRAY_IDX(ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx))) =
09824 ATD_RESHAPE_ARRAY_IDX(ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx)));
09825 ATD_RESHAPE_ARRAY_IDX(ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx))) =
09826 NULL_IDX;
09827 }
09828 }
09829 else if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Pgm_Unit &&
09830 ATP_PROC(SN_ATTR_IDX(sn_idx)) == Dummy_Proc) {
09831 ATP_DUMMY_PROC_LINK(SN_ATTR_IDX(sn_idx)) = NULL_IDX;
09832 }
09833
09834 sn_idx++;
09835 }
09836
09837 TRACE (Func_Exit, "process_variable_size_func", NULL);
09838
09839 return;
09840
09841 }
09842
09843
09844
09845
09846
09847
09848
09849
09850
09851
09852
09853
09854
09855
09856
09857
09858
09859 static void check_bd_typ_for_dargs(int bd_idx,
09860 int type_idx,
09861 opnd_type *list_opnd)
09862
09863 {
09864 int dim;
09865 opnd_type opnd;
09866
09867 TRACE (Func_Entry, "check_bd_typ_for_dargs", NULL);
09868
09869 if (TYP_TYPE(type_idx) == Character &&
09870 TYP_CHAR_CLASS(type_idx) == Var_Len_Char) {
09871 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_ORIG_LEN_IDX(type_idx))));
09872 search_expr_for_dargs(&opnd, list_opnd);
09873 }
09874
09875 if (bd_idx != NULL_IDX) {
09876 if (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) {
09877
09878 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
09879
09880 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
09881
09882 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(BD_LB_IDX(bd_idx, dim))));
09883 search_expr_for_dargs(&opnd, list_opnd);
09884 }
09885
09886 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
09887
09888 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(BD_UB_IDX(bd_idx, dim))));
09889 search_expr_for_dargs(&opnd, list_opnd);
09890 }
09891 }
09892 }
09893 else if (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) {
09894 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
09895
09896 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
09897
09898 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(BD_LB_IDX(bd_idx, dim))));
09899 search_expr_for_dargs(&opnd, list_opnd);
09900 }
09901 }
09902 }
09903 }
09904
09905 TRACE (Func_Exit, "check_bd_typ_for_dargs", NULL);
09906
09907 return;
09908
09909 }
09910
09911
09912
09913
09914
09915
09916
09917
09918
09919
09920
09921
09922
09923
09924
09925
09926
09927 static void search_expr_for_dargs(opnd_type *opnd,
09928 opnd_type *list_opnd)
09929
09930 {
09931 int list_idx;
09932 opnd_type loc_opnd;
09933
09934 TRACE (Func_Entry, "search_expr_for_dargs", NULL);
09935
09936 switch(OPND_FLD((*opnd))) {
09937 case AT_Tbl_Idx:
09938 if (AT_OBJ_CLASS(OPND_IDX((*opnd))) == Data_Obj &&
09939 ATD_CLASS(OPND_IDX((*opnd))) == Dummy_Argument &&
09940 ATD_SF_DARG(OPND_IDX((*opnd)))) {
09941
09942 if (OPND_FLD((*list_opnd)) != NO_Tbl_Idx) {
09943 list_idx = OPND_IDX((*list_opnd));
09944
09945 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
09946 if (IL_IDX(list_idx) == OPND_IDX((*opnd))) {
09947
09948
09949 goto OUT;
09950 }
09951 list_idx = IL_NEXT_LIST_IDX(list_idx);
09952 }
09953 }
09954
09955 if (ATD_ARRAY_IDX(OPND_IDX((*opnd))) != NULL_IDX ||
09956 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*opnd)))) == Character) {
09957
09958 check_bd_typ_for_dargs(ATD_ARRAY_IDX(OPND_IDX((*opnd))),
09959 ATD_TYPE_IDX(OPND_IDX((*opnd))),
09960 list_opnd);
09961 }
09962
09963 if (OPND_FLD((*list_opnd)) == NO_Tbl_Idx) {
09964 NTR_IR_LIST_TBL(list_idx);
09965 OPND_FLD((*list_opnd)) = IL_Tbl_Idx;
09966 OPND_IDX((*list_opnd)) = list_idx;
09967 OPND_LIST_CNT((*list_opnd)) = 1;
09968 }
09969 else {
09970
09971 list_idx = OPND_IDX((*list_opnd));
09972
09973 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
09974 list_idx = IL_NEXT_LIST_IDX(list_idx);
09975 }
09976
09977 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
09978 OPND_LIST_CNT((*list_opnd)) += 1;
09979 list_idx = IL_NEXT_LIST_IDX(list_idx);
09980 }
09981
09982 IL_FLD(list_idx) = AT_Tbl_Idx;
09983 IL_IDX(list_idx) = OPND_IDX((*opnd));
09984 IL_LINE_NUM(list_idx) = stmt_start_line;
09985 IL_COL_NUM(list_idx) = stmt_start_col;
09986 }
09987 break;
09988
09989 case IR_Tbl_Idx:
09990 COPY_OPND(loc_opnd, IR_OPND_L(OPND_IDX((*opnd))));
09991 search_expr_for_dargs(&loc_opnd, list_opnd);
09992
09993 COPY_OPND(loc_opnd, IR_OPND_R(OPND_IDX((*opnd))));
09994 search_expr_for_dargs(&loc_opnd, list_opnd);
09995
09996 break;
09997
09998 case IL_Tbl_Idx:
09999
10000 list_idx = OPND_IDX((*opnd));
10001
10002 while (list_idx) {
10003 COPY_OPND(loc_opnd, IL_OPND(list_idx));
10004 search_expr_for_dargs(&loc_opnd, list_opnd);
10005 list_idx = IL_NEXT_LIST_IDX(list_idx);
10006 }
10007
10008 break;
10009
10010 default :
10011 break;
10012
10013 }
10014
10015 OUT:
10016
10017 TRACE (Func_Exit, "search_expr_for_dargs", NULL);
10018
10019 return;
10020
10021 }
10022
10023
10024
10025
10026
10027
10028
10029
10030
10031
10032
10033
10034
10035
10036
10037
10038
10039 int create_argchck_descriptor(opnd_type *call_opnd)
10040
10041 {
10042 int arg_idx;
10043 int asg_idx;
10044 boolean this_is_call;
10045 int col;
10046 int count;
10047 int desc_idx;
10048 int entry_attr_idx;
10049 expr_arg_type exp_desc;
10050 int i;
10051 int ir_idx;
10052 int line;
10053 int list_idx;
10054 int loc_idx;
10055 boolean ok;
10056 opnd_type opnd;
10057 int rslt_idx;
10058 int shift_idx;
10059 int sub_idx;
10060 long_type the_constant;
10061 long_type the_constant2;
10062 int static_tmp_idx;
10063 int stack_tmp_idx;
10064
10065
10066 TRACE (Func_Entry, "create_argchck_descriptor", NULL);
10067
10068 if (OPND_FLD((*call_opnd)) == IR_Tbl_Idx) {
10069
10070 this_is_call = TRUE;
10071 count = IR_LIST_CNT_R(OPND_IDX((*call_opnd)));
10072 entry_attr_idx = IR_IDX_L(OPND_IDX((*call_opnd)));
10073 line = IR_LINE_NUM(OPND_IDX((*call_opnd)));
10074 col = IR_COL_NUM(OPND_IDX((*call_opnd)));
10075 arg_idx = IR_IDX_R(OPND_IDX((*call_opnd)));
10076
10077 if (ATP_EXTRA_DARG(entry_attr_idx)) {
10078 count--;
10079 arg_idx = IL_NEXT_LIST_IDX(arg_idx);
10080 }
10081 }
10082 else {
10083
10084 this_is_call = FALSE;
10085 entry_attr_idx = OPND_IDX((*call_opnd));
10086 count = ATP_NUM_DARGS(entry_attr_idx);
10087 line = AT_DEF_LINE(entry_attr_idx);
10088 col = AT_DEF_COLUMN(entry_attr_idx);
10089 arg_idx = ATP_FIRST_IDX(entry_attr_idx);
10090
10091 if (ATP_EXTRA_DARG(entry_attr_idx)) {
10092 count--;
10093 arg_idx++;
10094 }
10095 }
10096
10097
10098
10099
10100
10101 if (num_argchck_suppress_msg > 0) {
10102 static_tmp_idx =
10103 gen_static_integer_array_tmp(3 + count + num_argchck_suppress_msg,
10104 line,
10105 col);
10106 }
10107 else {
10108 static_tmp_idx = gen_static_integer_array_tmp(2 + count, line, col);
10109 }
10110
10111 stack_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
10112
10113 ATD_TYPE_IDX(stack_tmp_idx) = ATD_TYPE_IDX(static_tmp_idx);
10114 ATD_STOR_BLK_IDX(stack_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
10115
10116
10117
10118 AT_SEMANTICS_DONE(stack_tmp_idx) = TRUE;
10119
10120 ATD_ARRAY_IDX(stack_tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx);
10121
10122
10123
10124
10125
10126
10127 OPND_FLD(opnd) = AT_Tbl_Idx;
10128 OPND_IDX(opnd) = stack_tmp_idx;
10129 OPND_LINE_NUM(opnd) = line;
10130 OPND_COL_NUM(opnd) = col;
10131
10132 ok = gen_whole_subscript(&opnd, &exp_desc);
10133
10134 NTR_IR_TBL(asg_idx);
10135 IR_OPR(asg_idx) = Asg_Opr;
10136 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
10137 IR_LINE_NUM(asg_idx) = line;
10138 IR_COL_NUM(asg_idx) = col;
10139
10140 COPY_OPND(IR_OPND_L(asg_idx), opnd);
10141
10142 OPND_FLD(opnd) = AT_Tbl_Idx;
10143 OPND_IDX(opnd) = static_tmp_idx;
10144 OPND_LINE_NUM(opnd) = line;
10145 OPND_COL_NUM(opnd) = col;
10146
10147 ok = gen_whole_subscript(&opnd, &exp_desc);
10148
10149 COPY_OPND(IR_OPND_R(asg_idx), opnd);
10150
10151 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10152
10153 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10154 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10155
10156 if (this_is_call) {
10157
10158
10159
10160
10161 NTR_IR_TBL(asg_idx);
10162 IR_OPR(asg_idx) = Asg_Opr;
10163 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
10164 IR_LINE_NUM(asg_idx) = line;
10165 IR_COL_NUM(asg_idx) = col;
10166
10167 NTR_IR_TBL(sub_idx);
10168 IR_OPR(sub_idx) = Subscript_Opr;
10169 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10170 IR_LINE_NUM(sub_idx) = line;
10171 IR_COL_NUM(sub_idx) = col;
10172
10173 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10174 IR_IDX_L(sub_idx) = static_tmp_idx;
10175 IR_LINE_NUM_L(sub_idx) = line;
10176 IR_COL_NUM_L(sub_idx) = col;
10177 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10178 IR_IDX_L(asg_idx) = sub_idx;
10179
10180 NTR_IR_LIST_TBL(list_idx);
10181 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10182 IR_IDX_R(sub_idx) = list_idx;
10183 IR_LIST_CNT_R(sub_idx) = 1;
10184
10185 IL_FLD(list_idx) = CN_Tbl_Idx;
10186 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10187 IL_LINE_NUM(list_idx) = line;
10188 IL_COL_NUM(list_idx) = col;
10189
10190 NTR_IR_TBL(shift_idx);
10191 IR_OPR(shift_idx) = Shiftl_Opr;
10192 IR_TYPE_IDX(shift_idx) = CG_INTEGER_DEFAULT_TYPE;
10193 IR_LINE_NUM(shift_idx) = line;
10194 IR_COL_NUM(shift_idx) = col;
10195
10196 NTR_IR_LIST_TBL(list_idx);
10197 IR_FLD_L(shift_idx) = IL_Tbl_Idx;
10198 IR_IDX_L(shift_idx) = list_idx;
10199 IR_LIST_CNT_L(shift_idx) = 2;
10200
10201 IL_FLD(list_idx) = CN_Tbl_Idx;
10202 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10203 IL_LINE_NUM(list_idx) = line;
10204 IL_COL_NUM(list_idx) = col;
10205
10206 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10207 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10208 list_idx = IL_NEXT_LIST_IDX(list_idx);
10209
10210 the_constant = TARGET_BITS_PER_WORD - 1;
10211
10212 IL_FLD(list_idx) = CN_Tbl_Idx;
10213 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
10214 the_constant);
10215 IL_LINE_NUM(list_idx) = line;
10216 IL_COL_NUM(list_idx) = col;
10217
10218 NTR_IR_TBL(ir_idx);
10219 IR_OPR(ir_idx) = Bor_Opr;
10220 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
10221 IR_LINE_NUM(ir_idx) = line;
10222 IR_COL_NUM(ir_idx) = col;
10223
10224 IR_FLD_R(ir_idx) = IR_Tbl_Idx;
10225 IR_IDX_R(ir_idx) = shift_idx;
10226
10227 NTR_IR_TBL(sub_idx);
10228 IR_OPR(sub_idx) = Subscript_Opr;
10229 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10230 IR_LINE_NUM(sub_idx) = line;
10231 IR_COL_NUM(sub_idx) = col;
10232
10233 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10234 IR_IDX_L(sub_idx) = static_tmp_idx;
10235 IR_LINE_NUM_L(sub_idx) = line;
10236 IR_COL_NUM_L(sub_idx) = col;
10237 IR_FLD_L(ir_idx) = IR_Tbl_Idx;
10238 IR_IDX_L(ir_idx) = sub_idx;
10239
10240 NTR_IR_LIST_TBL(list_idx);
10241 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10242 IR_IDX_R(sub_idx) = list_idx;
10243 IR_LIST_CNT_R(sub_idx) = 1;
10244
10245 IL_FLD(list_idx) = CN_Tbl_Idx;
10246 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10247 IL_LINE_NUM(list_idx) = line;
10248 IL_COL_NUM(list_idx) = col;
10249
10250 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
10251 IR_IDX_R(asg_idx) = ir_idx;
10252
10253 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10254
10255 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10256 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10257 }
10258
10259
10260
10261
10262
10263 NTR_IR_TBL(asg_idx);
10264 IR_OPR(asg_idx) = Init_Opr;
10265 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
10266 IR_LINE_NUM(asg_idx) = line;
10267 IR_COL_NUM(asg_idx) = col;
10268
10269 NTR_IR_TBL(sub_idx);
10270 IR_OPR(sub_idx) = Subscript_Opr;
10271 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10272 IR_LINE_NUM(sub_idx) = line;
10273 IR_COL_NUM(sub_idx) = col;
10274
10275 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10276 IR_IDX_L(sub_idx) = static_tmp_idx;
10277 IR_LINE_NUM_L(sub_idx) = line;
10278 IR_COL_NUM_L(sub_idx) = col;
10279 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10280 IR_IDX_L(asg_idx) = sub_idx;
10281
10282 NTR_IR_LIST_TBL(list_idx);
10283 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10284 IR_IDX_R(sub_idx) = list_idx;
10285 IR_LIST_CNT_R(sub_idx) = 1;
10286
10287 IL_FLD(list_idx) = CN_Tbl_Idx;
10288 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10289 IL_LINE_NUM(list_idx) = line;
10290 IL_COL_NUM(list_idx) = col;
10291
10292 NTR_IR_LIST_TBL(list_idx);
10293 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
10294 IR_IDX_R(asg_idx) = list_idx;
10295 IR_LIST_CNT_R(asg_idx) = 3;
10296
10297 the_constant = 0;
10298
10299 ((arg_desc_header_type *)&the_constant)->seen_this = 0;
10300 ((arg_desc_header_type *)&the_constant)->f90_flag = 1;
10301 ((arg_desc_header_type *)&the_constant)->num_ck_only =
10302 cmd_line_flags.runtime_arg_count_only;
10303 ((arg_desc_header_type *)&the_constant)->arg_count = count;
10304
10305 if (num_argchck_suppress_msg > 0) {
10306 ((arg_desc_header_type *)&the_constant)->suppress_msg = 1;
10307 }
10308
10309 IL_FLD(list_idx) = CN_Tbl_Idx;
10310 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
10311 the_constant);
10312 IL_LINE_NUM(list_idx) = line;
10313 IL_COL_NUM(list_idx) = col;
10314
10315 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10316 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10317 list_idx = IL_NEXT_LIST_IDX(list_idx);
10318
10319 IL_FLD(list_idx) = CN_Tbl_Idx;
10320 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10321 IL_LINE_NUM(list_idx) = line;
10322 IL_COL_NUM(list_idx) = col;
10323
10324 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10325 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10326 list_idx = IL_NEXT_LIST_IDX(list_idx);
10327
10328 IL_FLD(list_idx) = CN_Tbl_Idx;
10329 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
10330 IL_LINE_NUM(list_idx) = line;
10331 IL_COL_NUM(list_idx) = col;
10332
10333 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10334
10335 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10336 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10337
10338
10339 # if defined(_INIT_RELOC_BASE_OFFSET) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
10340
10341
10342
10343
10344 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(static_tmp_idx)) == NULL_IDX) {
10345 set_sb_first_attr_idx(static_tmp_idx);
10346 }
10347 # endif
10348
10349
10350
10351
10352
10353 if (ATP_PGM_UNIT(entry_attr_idx) == Function) {
10354 if (this_is_call &&
10355 ATP_EXTRA_DARG(entry_attr_idx)) {
10356
10357 COPY_OPND(opnd, IL_OPND(IR_IDX_R(OPND_IDX((*call_opnd)))));
10358 rslt_idx = find_left_attr(&opnd);
10359 }
10360 else {
10361 rslt_idx = ATP_RSLT_IDX(entry_attr_idx);
10362 }
10363 }
10364 else {
10365 rslt_idx = NULL_IDX;
10366 }
10367
10368 the_constant = 2;
10369
10370 desc_idx = gen_call_type_descriptor(entry_attr_idx,
10371 rslt_idx,
10372 this_is_call,
10373 line,
10374 col);
10375
10376 if (ATD_STOR_BLK_IDX(desc_idx) == SCP_SB_STACK_IDX(curr_scp_idx)) {
10377 NTR_IR_TBL(sub_idx);
10378 IR_OPR(sub_idx) = Subscript_Opr;
10379 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10380 IR_LINE_NUM(sub_idx) = line;
10381 IR_COL_NUM(sub_idx) = col;
10382 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10383 IR_IDX_L(sub_idx) = stack_tmp_idx;
10384 IR_LINE_NUM_L(sub_idx) = line;
10385 IR_COL_NUM_L(sub_idx) = col;
10386
10387 NTR_IR_LIST_TBL(list_idx);
10388 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10389 IR_IDX_R(sub_idx) = list_idx;
10390 IR_LIST_CNT_R(sub_idx) = 1;
10391 IL_FLD(list_idx) = CN_Tbl_Idx;
10392 IL_IDX(list_idx) = CN_INTEGER_TWO_IDX;
10393 IL_LINE_NUM(list_idx) = line;
10394 IL_COL_NUM(list_idx) = col;
10395
10396 NTR_IR_TBL(asg_idx);
10397 IR_OPR(asg_idx) = Asg_Opr;
10398 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
10399 IR_LINE_NUM(asg_idx) = line;
10400 IR_COL_NUM(asg_idx) = col;
10401
10402 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10403 IR_IDX_L(asg_idx) = sub_idx;
10404
10405 NTR_IR_TBL(loc_idx);
10406 IR_OPR(loc_idx) = Loc_Opr;
10407 IR_LINE_NUM(loc_idx) = line;
10408 IR_COL_NUM(loc_idx) = col;
10409
10410 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
10411
10412 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
10413 IR_IDX_L(loc_idx) = desc_idx;
10414 IR_LINE_NUM_L(loc_idx) = line;
10415 IR_COL_NUM_L(loc_idx) = col;
10416
10417 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
10418 IR_IDX_R(asg_idx) = loc_idx;
10419 }
10420 else {
10421 NTR_IR_TBL(sub_idx);
10422 IR_OPR(sub_idx) = Subscript_Opr;
10423 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10424 IR_LINE_NUM(sub_idx) = line;
10425 IR_COL_NUM(sub_idx) = col;
10426 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10427 IR_IDX_L(sub_idx) = static_tmp_idx;
10428 IR_LINE_NUM_L(sub_idx) = line;
10429 IR_COL_NUM_L(sub_idx) = col;
10430
10431 NTR_IR_LIST_TBL(list_idx);
10432 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10433 IR_IDX_R(sub_idx) = list_idx;
10434 IR_LIST_CNT_R(sub_idx) = 1;
10435 IL_FLD(list_idx) = CN_Tbl_Idx;
10436 IL_IDX(list_idx) = CN_INTEGER_TWO_IDX;
10437 IL_LINE_NUM(list_idx) = line;
10438 IL_COL_NUM(list_idx) = col;
10439
10440 NTR_IR_TBL(asg_idx);
10441 IR_OPR(asg_idx) = Init_Reloc_Opr;
10442 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
10443 IR_LINE_NUM(asg_idx) = line;
10444 IR_COL_NUM(asg_idx) = col;
10445
10446 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10447 IR_IDX_L(asg_idx) = sub_idx;
10448
10449 NTR_IR_TBL(loc_idx);
10450 IR_OPR(loc_idx) = Loc_Opr;
10451 IR_LINE_NUM(loc_idx) = line;
10452 IR_COL_NUM(loc_idx) = col;
10453
10454 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
10455
10456 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
10457 IR_IDX_L(loc_idx) = desc_idx;
10458 IR_LINE_NUM_L(loc_idx) = line;
10459 IR_COL_NUM_L(loc_idx) = col;
10460
10461 NTR_IR_LIST_TBL(list_idx);
10462 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
10463 IR_IDX_R(asg_idx) = list_idx;
10464 IR_LIST_CNT_R(asg_idx) = 2;
10465 IL_FLD(list_idx) = IR_Tbl_Idx;
10466 IL_IDX(list_idx) = loc_idx;
10467
10468 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10469 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10470 list_idx = IL_NEXT_LIST_IDX(list_idx);
10471
10472 IL_FLD(list_idx) = CN_Tbl_Idx;
10473 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
10474 IL_LINE_NUM(list_idx) = line;
10475 IL_COL_NUM(list_idx) = col;
10476 }
10477
10478
10479 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10480
10481 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10482 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10483
10484
10485
10486
10487
10488
10489 for (i = 0; i < count; i++) {
10490
10491 the_constant++;
10492
10493 NTR_IR_TBL(sub_idx);
10494 IR_OPR(sub_idx) = Subscript_Opr;
10495 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10496 IR_LINE_NUM(sub_idx) = line;
10497 IR_COL_NUM(sub_idx) = col;
10498 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10499 IR_IDX_L(sub_idx) = static_tmp_idx;
10500 IR_LINE_NUM_L(sub_idx) = line;
10501 IR_COL_NUM_L(sub_idx) = col;
10502
10503 NTR_IR_LIST_TBL(list_idx);
10504 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10505 IR_IDX_R(sub_idx) = list_idx;
10506 IR_LIST_CNT_R(sub_idx) = 1;
10507 IL_FLD(list_idx) = CN_Tbl_Idx;
10508 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant);
10509 IL_LINE_NUM(list_idx) = line;
10510 IL_COL_NUM(list_idx) = col;
10511
10512 if (this_is_call &&
10513 IL_ARG_DESC_IDX(arg_idx) == NULL_IDX) {
10514
10515
10516
10517 NTR_IR_TBL(asg_idx);
10518 IR_OPR(asg_idx) = Init_Opr;
10519 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
10520 IR_LINE_NUM(asg_idx) = line;
10521 IR_COL_NUM(asg_idx) = col;
10522
10523 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10524 IR_IDX_L(asg_idx) = sub_idx;
10525
10526 NTR_IR_LIST_TBL(list_idx);
10527 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
10528 IR_IDX_R(asg_idx) = list_idx;
10529 IR_LIST_CNT_R(asg_idx) = 3;
10530
10531 IL_FLD(list_idx) = CN_Tbl_Idx;
10532 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
10533 IL_LINE_NUM(list_idx) = line;
10534 IL_COL_NUM(list_idx) = col;
10535
10536 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10537 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10538 list_idx = IL_NEXT_LIST_IDX(list_idx);
10539
10540 IL_FLD(list_idx) = CN_Tbl_Idx;
10541 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10542 IL_LINE_NUM(list_idx) = line;
10543 IL_COL_NUM(list_idx) = col;
10544
10545 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10546 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10547 list_idx = IL_NEXT_LIST_IDX(list_idx);
10548
10549 IL_FLD(list_idx) = CN_Tbl_Idx;
10550 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
10551 IL_LINE_NUM(list_idx) = line;
10552 IL_COL_NUM(list_idx) = col;
10553 }
10554 else {
10555
10556 desc_idx = gen_arg_type_descriptor(arg_idx,
10557 this_is_call,
10558 line,
10559 col);
10560
10561 if (ATD_STOR_BLK_IDX(desc_idx) == SCP_SB_STACK_IDX(curr_scp_idx)) {
10562
10563 IR_IDX_L(sub_idx) = stack_tmp_idx;
10564
10565 NTR_IR_TBL(asg_idx);
10566 IR_OPR(asg_idx) = Asg_Opr;
10567 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
10568 IR_LINE_NUM(asg_idx) = line;
10569 IR_COL_NUM(asg_idx) = col;
10570
10571 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10572 IR_IDX_L(asg_idx) = sub_idx;
10573
10574 NTR_IR_TBL(loc_idx);
10575 IR_OPR(loc_idx) = Loc_Opr;
10576 IR_LINE_NUM(loc_idx) = line;
10577 IR_COL_NUM(loc_idx) = col;
10578
10579 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
10580
10581 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
10582 IR_IDX_L(loc_idx) = desc_idx;
10583 IR_LINE_NUM_L(loc_idx) = line;
10584 IR_COL_NUM_L(loc_idx) = col;
10585
10586 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
10587 IR_IDX_R(asg_idx) = loc_idx;
10588 }
10589 else {
10590
10591 NTR_IR_TBL(asg_idx);
10592 IR_OPR(asg_idx) = Init_Reloc_Opr;
10593 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
10594 IR_LINE_NUM(asg_idx) = line;
10595 IR_COL_NUM(asg_idx) = col;
10596
10597 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10598 IR_IDX_L(asg_idx) = sub_idx;
10599
10600 NTR_IR_TBL(loc_idx);
10601 IR_OPR(loc_idx) = Loc_Opr;
10602 IR_LINE_NUM(loc_idx) = line;
10603 IR_COL_NUM(loc_idx) = col;
10604
10605 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
10606
10607 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
10608 IR_IDX_L(loc_idx) = desc_idx;
10609 IR_LINE_NUM_L(loc_idx) = line;
10610 IR_COL_NUM_L(loc_idx) = col;
10611
10612 NTR_IR_LIST_TBL(list_idx);
10613 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
10614 IR_IDX_R(asg_idx) = list_idx;
10615 IR_LIST_CNT_R(asg_idx) = 2;
10616 IL_FLD(list_idx) = IR_Tbl_Idx;
10617 IL_IDX(list_idx) = loc_idx;
10618
10619 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10620 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10621 list_idx = IL_NEXT_LIST_IDX(list_idx);
10622
10623 IL_FLD(list_idx) = CN_Tbl_Idx;
10624 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
10625 IL_LINE_NUM(list_idx) = line;
10626 IL_COL_NUM(list_idx) = col;
10627 }
10628 }
10629
10630
10631 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10632
10633 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10634 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10635
10636
10637 if (this_is_call) {
10638 arg_idx = IL_NEXT_LIST_IDX(arg_idx);
10639 }
10640 else {
10641 arg_idx++;
10642 }
10643 }
10644
10645 if (num_argchck_suppress_msg > 0) {
10646 for (i = 1; i <= num_argchck_suppress_msg+1; i++) {
10647 the_constant++;
10648
10649 NTR_IR_TBL(sub_idx);
10650 IR_OPR(sub_idx) = Subscript_Opr;
10651 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10652 IR_LINE_NUM(sub_idx) = line;
10653 IR_COL_NUM(sub_idx) = col;
10654 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10655 IR_IDX_L(sub_idx) = static_tmp_idx;
10656 IR_LINE_NUM_L(sub_idx) = line;
10657 IR_COL_NUM_L(sub_idx) = col;
10658
10659 NTR_IR_LIST_TBL(list_idx);
10660 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10661 IR_IDX_R(sub_idx) = list_idx;
10662 IR_LIST_CNT_R(sub_idx) = 1;
10663 IL_FLD(list_idx) = CN_Tbl_Idx;
10664 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant);
10665 IL_LINE_NUM(list_idx) = line;
10666 IL_COL_NUM(list_idx) = col;
10667
10668 NTR_IR_TBL(asg_idx);
10669 IR_OPR(asg_idx) = Init_Opr;
10670 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
10671 IR_LINE_NUM(asg_idx) = line;
10672 IR_COL_NUM(asg_idx) = col;
10673
10674 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10675 IR_IDX_L(asg_idx) = sub_idx;
10676
10677 NTR_IR_LIST_TBL(list_idx);
10678 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
10679 IR_IDX_R(asg_idx) = list_idx;
10680 IR_LIST_CNT_R(asg_idx) = 3;
10681
10682 the_constant2 = argchck_suppress_msg[i];
10683
10684 IL_FLD(list_idx) = CN_Tbl_Idx;
10685 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant2);
10686 IL_LINE_NUM(list_idx) = line;
10687 IL_COL_NUM(list_idx) = col;
10688
10689 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10690 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10691 list_idx = IL_NEXT_LIST_IDX(list_idx);
10692
10693 IL_FLD(list_idx) = CN_Tbl_Idx;
10694 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10695 IL_LINE_NUM(list_idx) = line;
10696 IL_COL_NUM(list_idx) = col;
10697
10698 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10699 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10700 list_idx = IL_NEXT_LIST_IDX(list_idx);
10701
10702 IL_FLD(list_idx) = CN_Tbl_Idx;
10703 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
10704 IL_LINE_NUM(list_idx) = line;
10705 IL_COL_NUM(list_idx) = col;
10706
10707 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10708
10709 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10710 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10711 }
10712 }
10713
10714 TRACE (Func_Exit, "create_argchck_descriptor", NULL);
10715
10716 return(stack_tmp_idx);
10717
10718 }
10719
10720
10721
10722
10723
10724
10725
10726
10727
10728
10729
10730
10731
10732
10733
10734
10735
10736 static int gen_call_type_descriptor(int attr_idx,
10737 int rslt_idx,
10738 boolean this_is_call,
10739 int line,
10740 int col)
10741
10742 {
10743 int act_file_line;
10744 int asg_idx;
10745 int const_idx;
10746 expr_arg_type exp_desc;
10747 int glb_idx;
10748 int idx;
10749 int list_idx;
10750 int loc_idx;
10751 long_type num[MAX_WORDS_FOR_INTEGER];
10752 boolean ok;
10753 opnd_type opnd;
10754 int sub_idx;
10755 int static_tmp_idx;
10756 int stack_tmp_idx = NULL_IDX;
10757 long_type the_constant;
10758 int type_idx;
10759
10760
10761 TRACE (Func_Entry, "gen_call_type_descriptor", NULL);
10762
10763
10764
10765
10766
10767 static_tmp_idx = gen_static_integer_array_tmp(NUM_TARGET_ARGCHCK_DESC_WORDS,
10768 line,
10769 col);
10770
10771
10772 if (ATP_PGM_UNIT(attr_idx) == Function &&
10773 ((ATD_ARRAY_IDX(rslt_idx) != NULL_IDX &&
10774 BD_LEN_FLD(ATD_ARRAY_IDX(rslt_idx)) != CN_Tbl_Idx &&
10775 BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)) != NULL_IDX) ||
10776 (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character &&
10777 TYP_FLD(ATD_TYPE_IDX(rslt_idx)) != CN_Tbl_Idx))) {
10778
10779 stack_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
10780
10781 ATD_TYPE_IDX(stack_tmp_idx) = ATD_TYPE_IDX(static_tmp_idx);
10782 ATD_STOR_BLK_IDX(stack_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
10783
10784
10785
10786 AT_SEMANTICS_DONE(stack_tmp_idx) = TRUE;
10787
10788 ATD_ARRAY_IDX(stack_tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx);
10789
10790
10791
10792
10793
10794
10795 OPND_FLD(opnd) = AT_Tbl_Idx;
10796 OPND_IDX(opnd) = stack_tmp_idx;
10797 OPND_LINE_NUM(opnd) = line;
10798 OPND_COL_NUM(opnd) = col;
10799
10800 ok = gen_whole_subscript(&opnd, &exp_desc);
10801
10802 NTR_IR_TBL(asg_idx);
10803 IR_OPR(asg_idx) = Asg_Opr;
10804 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
10805 IR_LINE_NUM(asg_idx) = line;
10806 IR_COL_NUM(asg_idx) = col;
10807
10808 COPY_OPND(IR_OPND_L(asg_idx), opnd);
10809
10810 OPND_FLD(opnd) = AT_Tbl_Idx;
10811 OPND_IDX(opnd) = static_tmp_idx;
10812 OPND_LINE_NUM(opnd) = line;
10813 OPND_COL_NUM(opnd) = col;
10814
10815 ok = gen_whole_subscript(&opnd, &exp_desc);
10816
10817 COPY_OPND(IR_OPND_R(asg_idx), opnd);
10818
10819 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10820
10821 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10822 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10823
10824 }
10825
10826
10827
10828
10829
10830 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
10831 TYP_TYPE(TYP_WORK_IDX) = Typeless;
10832 TYP_BIT_LEN(TYP_WORK_IDX) = (NUM_TARGET_ARGCHCK_DESC_WORDS - 1) *
10833 TARGET_BITS_PER_WORD;
10834 type_idx = ntr_type_tbl();
10835
10836 const_idx = ntr_const_tbl(type_idx, FALSE, NULL);
10837
10838 NTR_IR_TBL(sub_idx);
10839 IR_OPR(sub_idx) = Subscript_Opr;
10840 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10841 IR_LINE_NUM(sub_idx) = line;
10842 IR_COL_NUM(sub_idx) = col;
10843 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10844 IR_IDX_L(sub_idx) = static_tmp_idx;
10845 IR_LINE_NUM_L(sub_idx) = line;
10846 IR_COL_NUM_L(sub_idx) = col;
10847
10848 NTR_IR_LIST_TBL(list_idx);
10849 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10850 IR_IDX_R(sub_idx) = list_idx;
10851 IR_LIST_CNT_R(sub_idx) = 1;
10852 IL_FLD(list_idx) = CN_Tbl_Idx;
10853 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10854 IL_LINE_NUM(list_idx) = line;
10855 IL_COL_NUM(list_idx) = col;
10856
10857
10858 NTR_IR_TBL(asg_idx);
10859 IR_OPR(asg_idx) = Init_Opr;
10860 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
10861 IR_LINE_NUM(asg_idx) = line;
10862 IR_COL_NUM(asg_idx) = col;
10863
10864 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10865 IR_IDX_L(asg_idx) = sub_idx;
10866
10867 NTR_IR_LIST_TBL(list_idx);
10868 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
10869 IR_IDX_R(asg_idx) = list_idx;
10870 IR_LIST_CNT_R(asg_idx) = 3;
10871
10872 IL_FLD(list_idx) = CN_Tbl_Idx;
10873 IL_IDX(list_idx) = const_idx;
10874 IL_LINE_NUM(list_idx) = line;
10875 IL_COL_NUM(list_idx) = col;
10876
10877 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10878 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10879 list_idx = IL_NEXT_LIST_IDX(list_idx);
10880
10881 IL_FLD(list_idx) = CN_Tbl_Idx;
10882 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
10883 IL_LINE_NUM(list_idx) = line;
10884 IL_COL_NUM(list_idx) = col;
10885
10886 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
10887 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
10888 list_idx = IL_NEXT_LIST_IDX(list_idx);
10889
10890 IL_FLD(list_idx) = CN_Tbl_Idx;
10891 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
10892 IL_LINE_NUM(list_idx) = line;
10893 IL_COL_NUM(list_idx) = col;
10894
10895 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10896
10897 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10898 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10899
10900
10901
10902
10903
10904
10905
10906
10907
10908 strcpy(((arg_desc_node_type *)&(CN_CONST(const_idx)))->name,
10909 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
10910
10911 if (this_is_call) {
10912 GLOBAL_LINE_TO_FILE_LINE(line, glb_idx, act_file_line);
10913 C_TO_F_INT(num, act_file_line, CG_INTEGER_DEFAULT_TYPE);
10914
10915 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->line = num[0];
10916 }
10917
10918 if (ATP_PGM_UNIT(attr_idx) == Function) {
10919 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type =
10920 get_arg_type(ATD_TYPE_IDX(rslt_idx),
10921 TRUE);
10922 C_TO_F_INT(num,
10923 linear_to_kind_type[TYP_LINEAR(ATD_TYPE_IDX(rslt_idx))],
10924 CG_INTEGER_DEFAULT_TYPE);
10925 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->kind = num[0];
10926
10927 if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX) {
10928
10929 C_TO_F_INT(num,
10930 BD_RANK(ATD_ARRAY_IDX(rslt_idx)),
10931 CG_INTEGER_DEFAULT_TYPE);
10932
10933 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0];
10934
10935 if (BD_LEN_FLD(ATD_ARRAY_IDX(rslt_idx)) == CN_Tbl_Idx &&
10936 BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)) != NULL_IDX) {
10937
10938 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size =
10939 CN_CONST(BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)));
10940 }
10941 else if (BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)) != NULL_IDX) {
10942
10943
10944 NTR_IR_TBL(sub_idx);
10945 IR_OPR(sub_idx) = Subscript_Opr;
10946 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
10947 IR_LINE_NUM(sub_idx) = line;
10948 IR_COL_NUM(sub_idx) = col;
10949 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
10950 IR_IDX_L(sub_idx) = stack_tmp_idx;
10951 IR_LINE_NUM_L(sub_idx) = line;
10952 IR_COL_NUM_L(sub_idx) = col;
10953
10954 NTR_IR_LIST_TBL(list_idx);
10955 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
10956 IR_IDX_R(sub_idx) = list_idx;
10957 IR_LIST_CNT_R(sub_idx) = 1;
10958 IL_FLD(list_idx) = CN_Tbl_Idx;
10959
10960 the_constant = ARGCHCK_SIZE_IDX;
10961 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
10962 the_constant);
10963 IL_LINE_NUM(list_idx) = line;
10964 IL_COL_NUM(list_idx) = col;
10965
10966 NTR_IR_TBL(asg_idx);
10967 IR_OPR(asg_idx) = Asg_Opr;
10968 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
10969 IR_LINE_NUM(asg_idx) = line;
10970 IR_COL_NUM(asg_idx) = col;
10971
10972 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
10973 IR_IDX_L(asg_idx) = sub_idx;
10974
10975 IR_FLD_R(asg_idx) = BD_LEN_FLD(ATD_ARRAY_IDX(rslt_idx));
10976 IR_IDX_R(asg_idx) = BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx));
10977 IR_LINE_NUM_R(asg_idx) = line;
10978 IR_COL_NUM_R(asg_idx) = col;
10979
10980 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
10981
10982 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
10983 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
10984 }
10985 }
10986 else {
10987 C_TO_F_INT(num, 1, CG_INTEGER_DEFAULT_TYPE);
10988 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = num[0];
10989
10990 C_TO_F_INT(num, 0, CG_INTEGER_DEFAULT_TYPE);
10991 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0];
10992 }
10993
10994 if (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character) {
10995
10996 if (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character &&
10997 TYP_CHAR_CLASS(ATD_TYPE_IDX(rslt_idx)) == Assumed_Size_Char) {
10998 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_size_char =
10999 TRUE;
11000 }
11001 else if (TYP_FLD(ATD_TYPE_IDX(rslt_idx)) == CN_Tbl_Idx) {
11002 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->char_len =
11003 CN_CONST(TYP_IDX(ATD_TYPE_IDX(rslt_idx)));
11004 }
11005 else {
11006
11007
11008 NTR_IR_TBL(sub_idx);
11009 IR_OPR(sub_idx) = Subscript_Opr;
11010 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
11011 IR_LINE_NUM(sub_idx) = line;
11012 IR_COL_NUM(sub_idx) = col;
11013 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
11014 IR_IDX_L(sub_idx) = stack_tmp_idx;
11015 IR_LINE_NUM_L(sub_idx) = line;
11016 IR_COL_NUM_L(sub_idx) = col;
11017
11018 NTR_IR_LIST_TBL(list_idx);
11019 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
11020 IR_IDX_R(sub_idx) = list_idx;
11021 IR_LIST_CNT_R(sub_idx) = 1;
11022 IL_FLD(list_idx) = CN_Tbl_Idx;
11023 IL_LINE_NUM(list_idx) = line;
11024 IL_COL_NUM(list_idx) = col;
11025
11026 the_constant = ARGCHCK_CHAR_LEN_IDX;
11027 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
11028 the_constant);
11029
11030 NTR_IR_TBL(asg_idx);
11031 IR_OPR(asg_idx) = Asg_Opr;
11032 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
11033 IR_LINE_NUM(asg_idx) = line;
11034 IR_COL_NUM(asg_idx) = col;
11035
11036 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
11037 IR_IDX_L(asg_idx) = sub_idx;
11038
11039 IR_FLD_R(asg_idx) = TYP_FLD(ATD_TYPE_IDX(rslt_idx));
11040 IR_IDX_R(asg_idx) = TYP_IDX(ATD_TYPE_IDX(rslt_idx));
11041 IR_LINE_NUM_R(asg_idx) = line;
11042 IR_COL_NUM_R(asg_idx) = col;
11043
11044 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
11045
11046 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
11047 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
11048
11049 }
11050 }
11051 else if (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Structure) {
11052
11053
11054 NTR_IR_TBL(sub_idx);
11055 IR_OPR(sub_idx) = Subscript_Opr;
11056 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
11057 IR_LINE_NUM(sub_idx) = line;
11058 IR_COL_NUM(sub_idx) = col;
11059 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
11060 IR_IDX_L(sub_idx) = static_tmp_idx;
11061 IR_LINE_NUM_L(sub_idx) = line;
11062 IR_COL_NUM_L(sub_idx) = col;
11063
11064 NTR_IR_LIST_TBL(list_idx);
11065 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
11066 IR_IDX_R(sub_idx) = list_idx;
11067 IR_LIST_CNT_R(sub_idx) = 1;
11068 IL_FLD(list_idx) = CN_Tbl_Idx;
11069 the_constant = ARGCHCK_STRUCT_TBL_IDX;
11070 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant);
11071 IL_LINE_NUM(list_idx) = line;
11072 IL_COL_NUM(list_idx) = col;
11073
11074 NTR_IR_TBL(asg_idx);
11075 IR_OPR(asg_idx) = Init_Reloc_Opr;
11076 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
11077 IR_LINE_NUM(asg_idx) = line;
11078 IR_COL_NUM(asg_idx) = col;
11079
11080 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
11081 IR_IDX_L(asg_idx) = sub_idx;
11082
11083 NTR_IR_TBL(loc_idx);
11084 IR_OPR(loc_idx) = Loc_Opr;
11085 IR_LINE_NUM(loc_idx) = line;
11086 IR_COL_NUM(loc_idx) = col;
11087 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
11088
11089 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
11090 idx = create_struct_argchck_tbl(TYP_IDX(ATD_TYPE_IDX(rslt_idx)));
11091 IR_IDX_L(loc_idx) = idx;
11092 IR_LINE_NUM_L(loc_idx) = line;
11093 IR_COL_NUM_L(loc_idx) = col;
11094
11095 NTR_IR_LIST_TBL(list_idx);
11096 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
11097 IR_IDX_R(asg_idx) = list_idx;
11098 IR_LIST_CNT_R(asg_idx) = 2;
11099 IL_FLD(list_idx) = IR_Tbl_Idx;
11100 IL_IDX(list_idx) = loc_idx;
11101
11102 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
11103 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
11104 list_idx = IL_NEXT_LIST_IDX(list_idx);
11105
11106 IL_FLD(list_idx) = CN_Tbl_Idx;
11107 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
11108 IL_LINE_NUM(list_idx) = line;
11109 IL_COL_NUM(list_idx) = col;
11110
11111 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
11112
11113 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
11114 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
11115 }
11116
11117 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pointer =
11118 ATD_POINTER(rslt_idx);
11119 }
11120 else if (ATP_PGM_UNIT(attr_idx) == Subroutine) {
11121 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type =
11122 Subroutine_Arg;
11123 }
11124 else {
11125 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type =
11126 Subprogram_Arg;
11127 }
11128
11129 TRACE (Func_Exit, "gen_call_type_descriptor", NULL);
11130
11131 return((stack_tmp_idx ? stack_tmp_idx : static_tmp_idx));
11132
11133 }
11134
11135
11136
11137
11138
11139
11140
11141
11142
11143
11144
11145
11146
11147
11148
11149
11150
11151 static int gen_arg_type_descriptor(int idx,
11152 boolean this_is_call,
11153 int line,
11154 int col)
11155
11156 {
11157 int asg_idx;
11158 int attr_idx = NULL_IDX;
11159 int bd_idx = NULL_IDX;
11160 opnd_type char_len_opnd;
11161 int const_idx;
11162 expr_arg_type exp_desc;
11163 long_type folded_const[MAX_WORDS_FOR_INTEGER];
11164 int i;
11165 #ifdef KEY
11166 int info_idx = 0;
11167 #else
11168 int info_idx;
11169 #endif
11170 opnd_type len_opnd;
11171 int list_idx;
11172 int loc_idx;
11173 int mult_idx;
11174 long_type num[MAX_WORDS_FOR_INTEGER];
11175 boolean ok;
11176 opnd_type opnd;
11177 boolean pgm_unit = FALSE;
11178 int rank = 0;
11179 expr_mode_type save_expr_mode;
11180 cif_usage_code_type save_xref_state;
11181 int sub_idx;
11182 int static_tmp_idx;
11183 int stack_tmp_idx = NULL_IDX;
11184 int type_idx = NULL_IDX;
11185 int type_idx2;
11186 int unused1;
11187 int unused2;
11188
11189
11190 TRACE (Func_Entry, "gen_arg_type_descriptor", NULL);
11191
11192 len_opnd = null_opnd;
11193 OPND_LINE_NUM(len_opnd) = line;
11194 OPND_COL_NUM(len_opnd) = col;
11195
11196 if (this_is_call) {
11197
11198
11199 info_idx = IL_ARG_DESC_IDX(idx);
11200
11201 # ifdef _DEBUG
11202 if (info_idx == NULL_IDX) {
11203 PRINTMSG(line, 626, Internal, col,
11204 "valid info_idx", "gen_arg_type_descriptor");
11205 }
11206 # endif
11207
11208 pgm_unit = arg_info_list[info_idx].pgm_unit;
11209
11210 COPY_OPND(opnd, IL_OPND(idx));
11211
11212 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
11213 (IR_OPR(OPND_IDX(opnd)) == Loc_Opr ||
11214 IR_OPR(OPND_IDX(opnd)) == Aloc_Opr ||
11215 IR_OPR(OPND_IDX(opnd)) == Const_Tmp_Loc_Opr)) {
11216
11217 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
11218 }
11219
11220 if (OPND_FLD(opnd) == IR_Tbl_Idx &&
11221 (IR_OPR(OPND_IDX(opnd)) == Substring_Opr ||
11222 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr)) {
11223
11224 COPY_OPND(char_len_opnd,
11225 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
11226 IR_IDX_R(OPND_IDX(opnd))))));
11227 }
11228
11229 type_idx = arg_info_list[info_idx].ed.type_idx;
11230 rank = arg_info_list[info_idx].ed.rank;
11231
11232 if (arg_info_list[info_idx].association == PASS_SECTION_ADDRESS ||
11233 arg_info_list[info_idx].association == PASS_ADDRESS_FROM_DV ||
11234 arg_info_list[info_idx].association == CHECK_CONTIG_FLAG) {
11235
11236
11237 COPY_OPND(len_opnd, arg_info_list[info_idx].ed.shape[0]);
11238
11239 for (i = 1; i < rank; i++) {
11240 NTR_IR_TBL(mult_idx);
11241 IR_OPR(mult_idx) = Mult_Opr;
11242 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
11243 IR_LINE_NUM(mult_idx) = line;
11244 IR_COL_NUM(mult_idx) = col;
11245
11246 COPY_OPND(IR_OPND_L(mult_idx), len_opnd);
11247
11248 COPY_OPND(IR_OPND_R(mult_idx),
11249 arg_info_list[info_idx].ed.shape[i]);
11250
11251 OPND_FLD(len_opnd) = IR_Tbl_Idx;
11252 OPND_IDX(len_opnd) = mult_idx;
11253 }
11254
11255 save_xref_state = xref_state;
11256 xref_state = CIF_No_Usage_Rec;
11257 save_expr_mode = expr_mode;
11258 expr_mode = Regular_Expr;
11259
11260 exp_desc.rank = 0;
11261 ok = expr_semantics(&len_opnd, &exp_desc);
11262 xref_state = save_xref_state;
11263 expr_mode = save_expr_mode;
11264 }
11265 else if (IL_FLD(idx) != CN_Tbl_Idx) {
11266
11267 COPY_OPND(opnd, IL_OPND(idx));
11268 attr_idx = find_base_attr(&opnd, &unused1, &unused2);
11269
11270 if (attr_idx != NULL_IDX &&
11271 AT_OBJ_CLASS(attr_idx) == Data_Obj &&
11272 ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
11273
11274 bd_idx = ATD_ARRAY_IDX(attr_idx);
11275
11276 if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape ||
11277 BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) {
11278
11279
11280 COPY_OPND(len_opnd, arg_info_list[info_idx].ed.shape[0]);
11281
11282 for (i = 1; i < rank; i++) {
11283 NTR_IR_TBL(mult_idx);
11284 IR_OPR(mult_idx) = Mult_Opr;
11285 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
11286 IR_LINE_NUM(mult_idx) = line;
11287 IR_COL_NUM(mult_idx) = col;
11288
11289 COPY_OPND(IR_OPND_L(mult_idx), len_opnd);
11290
11291 COPY_OPND(IR_OPND_R(mult_idx),
11292 arg_info_list[info_idx].ed.shape[i]);
11293
11294 OPND_FLD(len_opnd) = IR_Tbl_Idx;
11295 OPND_IDX(len_opnd) = mult_idx;
11296 }
11297
11298 save_xref_state = xref_state;
11299 xref_state = CIF_No_Usage_Rec;
11300 save_expr_mode = expr_mode;
11301 expr_mode = Regular_Expr;
11302
11303 exp_desc.rank = 0;
11304 ok = expr_semantics(&len_opnd, &exp_desc);
11305 xref_state = save_xref_state;
11306 expr_mode = save_expr_mode;
11307 }
11308 else {
11309 OPND_FLD(len_opnd) = BD_LEN_FLD(bd_idx);
11310 OPND_IDX(len_opnd) = BD_LEN_IDX(bd_idx);
11311 }
11312 }
11313 }
11314 }
11315 else {
11316
11317 attr_idx = SN_ATTR_IDX(idx);
11318
11319 pgm_unit = (AT_OBJ_CLASS(attr_idx) == Pgm_Unit);
11320
11321 if (pgm_unit) {
11322 if (ATP_PGM_UNIT(attr_idx) == Function) {
11323
11324 if (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)) != NULL_IDX) {
11325 bd_idx = ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx));
11326
11327 rank = BD_RANK(bd_idx);
11328
11329 OPND_FLD(len_opnd) = BD_LEN_FLD(bd_idx);
11330 OPND_IDX(len_opnd) = BD_LEN_IDX(bd_idx);
11331 }
11332
11333 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
11334
11335 if (TYP_TYPE(type_idx) == Character) {
11336 OPND_FLD(char_len_opnd) = TYP_FLD(type_idx);
11337 OPND_IDX(char_len_opnd) = TYP_IDX(type_idx);
11338 }
11339 }
11340 }
11341 else {
11342 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
11343 ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
11344 bd_idx = ATD_ARRAY_IDX(attr_idx);
11345
11346 rank = BD_RANK(bd_idx);
11347
11348 OPND_FLD(len_opnd) = BD_LEN_FLD(bd_idx);
11349 OPND_IDX(len_opnd) = BD_LEN_IDX(bd_idx);
11350 }
11351
11352 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
11353 type_idx = ATD_TYPE_IDX(attr_idx);
11354
11355 if (TYP_TYPE(type_idx) == Character) {
11356 OPND_FLD(char_len_opnd) = TYP_FLD(type_idx);
11357 OPND_IDX(char_len_opnd) = TYP_IDX(type_idx);
11358 }
11359 }
11360 }
11361 }
11362
11363
11364
11365
11366
11367 static_tmp_idx = gen_static_integer_array_tmp(NUM_TARGET_ARGCHCK_DESC_WORDS,
11368 line,
11369 col);
11370
11371 if (type_idx &&
11372 ((rank != 0 &&
11373 OPND_FLD(len_opnd) != CN_Tbl_Idx &&
11374 OPND_IDX(len_opnd) != NULL_IDX) ||
11375 (TYP_TYPE(type_idx) == Character &&
11376 TYP_FLD(type_idx) != CN_Tbl_Idx))) {
11377
11378 stack_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE);
11379
11380 ATD_TYPE_IDX(stack_tmp_idx) = ATD_TYPE_IDX(static_tmp_idx);
11381 ATD_STOR_BLK_IDX(stack_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
11382
11383
11384
11385 AT_SEMANTICS_DONE(stack_tmp_idx) = TRUE;
11386
11387 ATD_ARRAY_IDX(stack_tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx);
11388
11389
11390
11391
11392
11393
11394 OPND_FLD(opnd) = AT_Tbl_Idx;
11395 OPND_IDX(opnd) = stack_tmp_idx;
11396 OPND_LINE_NUM(opnd) = line;
11397 OPND_COL_NUM(opnd) = col;
11398
11399 ok = gen_whole_subscript(&opnd, &exp_desc);
11400
11401 NTR_IR_TBL(asg_idx);
11402 IR_OPR(asg_idx) = Asg_Opr;
11403 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
11404 IR_LINE_NUM(asg_idx) = line;
11405 IR_COL_NUM(asg_idx) = col;
11406
11407 COPY_OPND(IR_OPND_L(asg_idx), opnd);
11408
11409 OPND_FLD(opnd) = AT_Tbl_Idx;
11410 OPND_IDX(opnd) = static_tmp_idx;
11411 OPND_LINE_NUM(opnd) = line;
11412 OPND_COL_NUM(opnd) = col;
11413
11414 ok = gen_whole_subscript(&opnd, &exp_desc);
11415
11416 COPY_OPND(IR_OPND_R(asg_idx), opnd);
11417
11418 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
11419
11420 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
11421 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
11422
11423 }
11424
11425
11426
11427
11428
11429
11430 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
11431 TYP_TYPE(TYP_WORK_IDX) = Typeless;
11432 TYP_BIT_LEN(TYP_WORK_IDX) = (NUM_TARGET_ARGCHCK_DESC_WORDS - 1) *
11433 TARGET_BITS_PER_WORD;
11434 type_idx2 = ntr_type_tbl();
11435
11436 const_idx = ntr_const_tbl(type_idx2, FALSE, NULL);
11437
11438 NTR_IR_TBL(sub_idx);
11439 IR_OPR(sub_idx) = Subscript_Opr;
11440 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
11441 IR_LINE_NUM(sub_idx) = line;
11442 IR_COL_NUM(sub_idx) = col;
11443 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
11444 IR_IDX_L(sub_idx) = static_tmp_idx;
11445 IR_LINE_NUM_L(sub_idx) = line;
11446 IR_COL_NUM_L(sub_idx) = col;
11447
11448 NTR_IR_LIST_TBL(list_idx);
11449 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
11450 IR_IDX_R(sub_idx) = list_idx;
11451 IR_LIST_CNT_R(sub_idx) = 1;
11452 IL_FLD(list_idx) = CN_Tbl_Idx;
11453 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
11454 IL_LINE_NUM(list_idx) = line;
11455 IL_COL_NUM(list_idx) = col;
11456
11457
11458 NTR_IR_TBL(asg_idx);
11459 IR_OPR(asg_idx) = Init_Opr;
11460 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
11461 IR_LINE_NUM(asg_idx) = line;
11462 IR_COL_NUM(asg_idx) = col;
11463
11464 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
11465 IR_IDX_L(asg_idx) = sub_idx;
11466
11467 NTR_IR_LIST_TBL(list_idx);
11468 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
11469 IR_IDX_R(asg_idx) = list_idx;
11470 IR_LIST_CNT_R(asg_idx) = 3;
11471
11472 IL_FLD(list_idx) = CN_Tbl_Idx;
11473 IL_IDX(list_idx) = const_idx;
11474 IL_LINE_NUM(list_idx) = line;
11475 IL_COL_NUM(list_idx) = col;
11476
11477 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
11478 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
11479 list_idx = IL_NEXT_LIST_IDX(list_idx);
11480
11481 IL_FLD(list_idx) = CN_Tbl_Idx;
11482 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
11483 IL_LINE_NUM(list_idx) = line;
11484 IL_COL_NUM(list_idx) = col;
11485
11486 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
11487 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
11488 list_idx = IL_NEXT_LIST_IDX(list_idx);
11489
11490 IL_FLD(list_idx) = CN_Tbl_Idx;
11491 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
11492 IL_LINE_NUM(list_idx) = line;
11493 IL_COL_NUM(list_idx) = col;
11494
11495 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
11496
11497 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
11498 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
11499
11500
11501
11502
11503
11504 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pgm_unit = pgm_unit;
11505
11506 if (attr_idx &&
11507 AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
11508 ATP_PGM_UNIT(attr_idx) == Subroutine) {
11509
11510 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type =
11511 Subroutine_Arg;
11512 }
11513 else if (type_idx) {
11514 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type =
11515 get_arg_type(type_idx, pgm_unit);
11516
11517 C_TO_F_INT(num,
11518 linear_to_kind_type[TYP_LINEAR(type_idx)],
11519 CG_INTEGER_DEFAULT_TYPE);
11520
11521 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->kind = num[0];
11522 C_TO_F_INT(num, rank, CG_INTEGER_DEFAULT_TYPE);
11523
11524 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0];
11525
11526 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->default_kind =
11527 (TYP_DESC(type_idx) == Default_Typed);
11528 }
11529
11530 if (attr_idx &&
11531 AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
11532 ATP_PGM_UNIT(attr_idx) == Pgm_Unknown) {
11533 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pgm_unknown = 1;
11534 }
11535
11536 if (this_is_call &&
11537 arg_info_list[info_idx].ed.array_elt) {
11538
11539
11540 }
11541 else if (rank != 0) {
11542
11543 if (OPND_FLD(len_opnd) == CN_Tbl_Idx &&
11544 OPND_IDX(len_opnd) != NULL_IDX &&
11545 TYP_TYPE(type_idx) != Character) {
11546
11547
11548
11549
11550 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size =
11551 CN_CONST(OPND_IDX(len_opnd));
11552 }
11553 else if (OPND_FLD(len_opnd) == CN_Tbl_Idx &&
11554 OPND_IDX(len_opnd) != NULL_IDX &&
11555 TYP_TYPE(type_idx) == Character &&
11556 TYP_FLD(type_idx) == CN_Tbl_Idx) {
11557
11558 type_idx2 = (TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) >
11559 TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(type_idx)))) ?
11560 CN_TYPE_IDX(OPND_IDX(len_opnd)) :
11561 CN_TYPE_IDX(TYP_IDX(type_idx));
11562
11563 ok = folder_driver((char *)&CN_CONST(OPND_IDX(len_opnd)),
11564 CN_TYPE_IDX(OPND_IDX(len_opnd)),
11565 (char *)&CN_CONST(TYP_IDX(type_idx)),
11566 CN_TYPE_IDX(TYP_IDX(type_idx)),
11567 folded_const,
11568 &type_idx2,
11569 stmt_start_line,
11570 stmt_start_col,
11571 2,
11572 Mult_Opr);
11573
11574
11575
11576 # if defined(_TARGET32)
11577 if (TYP_LINEAR(type_idx2) == Integer_8) {
11578 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size =
11579 folded_const[1];
11580 }
11581 else {
11582 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size =
11583 folded_const[0];
11584 }
11585 # else
11586 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = folded_const[0];
11587 # endif
11588 }
11589 else if (OPND_IDX(len_opnd) != NULL_IDX) {
11590
11591
11592 NTR_IR_TBL(sub_idx);
11593 IR_OPR(sub_idx) = Subscript_Opr;
11594 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
11595 IR_LINE_NUM(sub_idx) = line;
11596 IR_COL_NUM(sub_idx) = col;
11597 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
11598 IR_IDX_L(sub_idx) = stack_tmp_idx;
11599 IR_LINE_NUM_L(sub_idx) = line;
11600 IR_COL_NUM_L(sub_idx) = col;
11601
11602 NTR_IR_LIST_TBL(list_idx);
11603 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
11604 IR_IDX_R(sub_idx) = list_idx;
11605 IR_LIST_CNT_R(sub_idx) = 1;
11606 IL_FLD(list_idx) = CN_Tbl_Idx;
11607
11608 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
11609 ARGCHCK_SIZE_IDX);
11610 IL_LINE_NUM(list_idx) = line;
11611 IL_COL_NUM(list_idx) = col;
11612
11613 NTR_IR_TBL(asg_idx);
11614 IR_OPR(asg_idx) = Asg_Opr;
11615 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
11616 IR_LINE_NUM(asg_idx) = line;
11617 IR_COL_NUM(asg_idx) = col;
11618
11619 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
11620 IR_IDX_L(asg_idx) = sub_idx;
11621
11622 if (TYP_TYPE(type_idx) == Character) {
11623 NTR_IR_TBL(mult_idx);
11624 IR_OPR(mult_idx) = Mult_Opr;
11625 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
11626 IR_LINE_NUM(mult_idx) = line;
11627 IR_COL_NUM(mult_idx) = col;
11628
11629 COPY_OPND(IR_OPND_L(mult_idx), len_opnd);
11630 IR_FLD_R(mult_idx) = TYP_FLD(type_idx);
11631 IR_IDX_R(mult_idx) = TYP_IDX(type_idx);
11632 IR_LINE_NUM_R(mult_idx) = line;
11633 IR_COL_NUM_R(mult_idx) = col;
11634
11635 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
11636 IR_IDX_R(asg_idx) = mult_idx;
11637 }
11638 else {
11639 COPY_OPND(IR_OPND_R(asg_idx), len_opnd);
11640 }
11641
11642 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
11643
11644 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
11645 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
11646 }
11647 }
11648 else {
11649 C_TO_F_INT(num, 1, CG_INTEGER_DEFAULT_TYPE);
11650 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = num[0];
11651 C_TO_F_INT(num, 0, CG_INTEGER_DEFAULT_TYPE);
11652 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0];
11653 }
11654
11655 if (type_idx &&
11656 TYP_TYPE(type_idx) == Character) {
11657
11658 if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
11659 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->char_len =
11660 CN_CONST(TYP_IDX(type_idx));
11661 }
11662 else {
11663
11664
11665 NTR_IR_TBL(sub_idx);
11666 IR_OPR(sub_idx) = Subscript_Opr;
11667 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
11668 IR_LINE_NUM(sub_idx) = line;
11669 IR_COL_NUM(sub_idx) = col;
11670 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
11671 IR_IDX_L(sub_idx) = stack_tmp_idx;
11672 IR_LINE_NUM_L(sub_idx) = line;
11673 IR_COL_NUM_L(sub_idx) = col;
11674
11675 NTR_IR_LIST_TBL(list_idx);
11676 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
11677 IR_IDX_R(sub_idx) = list_idx;
11678 IR_LIST_CNT_R(sub_idx) = 1;
11679 IL_FLD(list_idx) = CN_Tbl_Idx;
11680
11681 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
11682 ARGCHCK_CHAR_LEN_IDX);
11683 IL_LINE_NUM(list_idx) = line;
11684 IL_COL_NUM(list_idx) = col;
11685
11686 NTR_IR_TBL(asg_idx);
11687 IR_OPR(asg_idx) = Asg_Opr;
11688 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
11689 IR_LINE_NUM(asg_idx) = line;
11690 IR_COL_NUM(asg_idx) = col;
11691
11692 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
11693 IR_IDX_L(asg_idx) = sub_idx;
11694
11695 IR_FLD_R(asg_idx) = TYP_FLD(type_idx);
11696 IR_IDX_R(asg_idx) = TYP_IDX(type_idx);
11697 IR_LINE_NUM_R(asg_idx) = line;
11698 IR_COL_NUM_R(asg_idx) = col;
11699
11700 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
11701
11702 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
11703 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
11704
11705 }
11706 }
11707 else if (type_idx &&
11708 TYP_TYPE(type_idx) == Structure) {
11709
11710
11711 NTR_IR_TBL(sub_idx);
11712 IR_OPR(sub_idx) = Subscript_Opr;
11713 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
11714 IR_LINE_NUM(sub_idx) = line;
11715 IR_COL_NUM(sub_idx) = col;
11716 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
11717 IR_IDX_L(sub_idx) = static_tmp_idx;
11718 IR_LINE_NUM_L(sub_idx) = line;
11719 IR_COL_NUM_L(sub_idx) = col;
11720
11721 NTR_IR_LIST_TBL(list_idx);
11722 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
11723 IR_IDX_R(sub_idx) = list_idx;
11724 IR_LIST_CNT_R(sub_idx) = 1;
11725 IL_FLD(list_idx) = CN_Tbl_Idx;
11726 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
11727 ARGCHCK_STRUCT_TBL_IDX);
11728 IL_LINE_NUM(list_idx) = line;
11729 IL_COL_NUM(list_idx) = col;
11730
11731 NTR_IR_TBL(asg_idx);
11732 IR_OPR(asg_idx) = Init_Reloc_Opr;
11733 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
11734 IR_LINE_NUM(asg_idx) = line;
11735 IR_COL_NUM(asg_idx) = col;
11736
11737 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
11738 IR_IDX_L(asg_idx) = sub_idx;
11739
11740 NTR_IR_TBL(loc_idx);
11741 IR_OPR(loc_idx) = Loc_Opr;
11742 IR_LINE_NUM(loc_idx) = line;
11743 IR_COL_NUM(loc_idx) = col;
11744 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
11745
11746 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
11747 i = create_struct_argchck_tbl(TYP_IDX(type_idx));
11748 IR_IDX_L(loc_idx) = i;
11749 IR_LINE_NUM_L(loc_idx) = line;
11750 IR_COL_NUM_L(loc_idx) = col;
11751
11752 NTR_IR_LIST_TBL(list_idx);
11753 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
11754 IR_IDX_R(asg_idx) = list_idx;
11755 IR_LIST_CNT_R(asg_idx) = 2;
11756 IL_FLD(list_idx) = IR_Tbl_Idx;
11757 IL_IDX(list_idx) = loc_idx;
11758
11759 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
11760 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
11761 list_idx = IL_NEXT_LIST_IDX(list_idx);
11762
11763 IL_FLD(list_idx) = CN_Tbl_Idx;
11764 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
11765 IL_LINE_NUM(list_idx) = line;
11766 IL_COL_NUM(list_idx) = col;
11767
11768 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
11769
11770 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
11771 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
11772 }
11773
11774 if (this_is_call) {
11775
11776 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->defineable =
11777 arg_info_list[info_idx].ed.reference;
11778 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->array_element =
11779 arg_info_list[info_idx].ed.array_elt;
11780 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pointer =
11781 arg_info_list[info_idx].ed.pointer;
11782
11783 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->dope_vector =
11784 arg_info_list[info_idx].ed.dope_vector;
11785 }
11786 else {
11787
11788 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->optional =
11789 AT_OPTIONAL(attr_idx);
11790 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
11791 (ATD_INTENT(attr_idx) == Intent_Out ||
11792 ATD_INTENT(attr_idx) == Intent_Inout)) {
11793
11794 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->intent_out = TRUE;
11795 }
11796
11797 if (bd_idx) {
11798 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_shape =
11799 (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape);
11800 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_size_array =
11801 (BD_ARRAY_CLASS(bd_idx) == Assumed_Size);
11802 }
11803
11804 if (type_idx &&
11805 TYP_TYPE(type_idx) == Character &&
11806 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) {
11807 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_size_char =
11808 TRUE;
11809 }
11810
11811 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
11812 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pointer =
11813 ATD_POINTER(attr_idx);
11814
11815 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->dope_vector =
11816 ATD_IM_A_DOPE(attr_idx);
11817
11818 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->ignore_tkr =
11819 ATD_IGNORE_TKR(attr_idx);
11820 }
11821 }
11822
11823 TRACE (Func_Exit, "gen_arg_type_descriptor", NULL);
11824
11825 return((stack_tmp_idx ? stack_tmp_idx : static_tmp_idx));
11826
11827 }
11828
11829
11830
11831
11832
11833
11834
11835
11836
11837
11838
11839
11840
11841
11842
11843
11844
11845 static long_type get_arg_type(int type_idx,
11846 boolean is_pgm_unit)
11847
11848 {
11849 #ifdef KEY
11850 long_type arg_type = 0;
11851 #else
11852 long_type arg_type;
11853 #endif
11854
11855
11856 TRACE (Func_Entry, "get_arg_type", NULL);
11857
11858 switch (TYP_LINEAR(type_idx)) {
11859
11860 case Typeless_4:
11861 case Typeless_8:
11862 case Short_Typeless_Const:
11863 case Long_Typeless:
11864 arg_type = (is_pgm_unit ?
11865 Typeless_Function_Arg : Typeless_Arg);
11866 break;
11867
11868 case Integer_1:
11869 case Integer_2:
11870 case Integer_4:
11871 arg_type = (is_pgm_unit ?
11872 Short_Integer_Function_Arg : Short_Integer_Arg);
11873 break;
11874
11875 case Integer_8:
11876 arg_type = (is_pgm_unit ?
11877 Long_Integer_Function_Arg : Long_Integer_Arg);
11878 break;
11879
11880 case Real_4:
11881 # ifdef _TARGET64
11882 case Real_8:
11883 # endif
11884 arg_type = (is_pgm_unit ?
11885 Real_Function_Arg : Real_Arg);
11886 break;
11887
11888 # ifdef _TARGET32
11889 case Real_8:
11890 # endif
11891 case Real_16:
11892 arg_type = (is_pgm_unit ?
11893 Double_Function_Arg : Double_Arg);
11894 break;
11895
11896 case Complex_4:
11897 case Complex_8:
11898 case Complex_16:
11899 arg_type = (is_pgm_unit ?
11900 Complex_Function_Arg : Complex_Arg);
11901 break;
11902
11903 case CRI_Ptr_8:
11904 arg_type = (is_pgm_unit ?
11905 Pointer_Function_Arg : Pointer_Arg);
11906 break;
11907
11908 case Logical_1:
11909 case Logical_2:
11910 case Logical_4:
11911 case Logical_8:
11912 arg_type = (is_pgm_unit ?
11913 Logical_Function_Arg : Logical_Arg);
11914 break;
11915
11916 case Character_1:
11917 case Character_2:
11918 case Character_4:
11919 case Short_Char_Const:
11920 arg_type = (is_pgm_unit ?
11921 Character_Function_Arg : Character_Arg);
11922 break;
11923
11924 case CRI_Ch_Ptr_8:
11925 arg_type = (is_pgm_unit ?
11926 Character_Pointer_Function_Arg : Character_Pointer_Arg);
11927 break;
11928
11929 case Structure_Type:
11930 arg_type = (is_pgm_unit ?
11931 Derived_Type_Function_Arg : Derived_Type_Arg);
11932 break;
11933
11934 case CRI_Parcel_Ptr_8:
11935 arg_type = (is_pgm_unit ?
11936 Pointer_Function_Arg : Pointer_Arg);
11937 break;
11938
11939 default :
11940 PRINTMSG(stmt_start_line, 626, Internal, 1,
11941 "valid type",
11942 "get_arg_type");
11943 break;
11944 }
11945
11946
11947 TRACE (Func_Exit, "get_arg_type", NULL);
11948
11949 return(arg_type);
11950
11951 }
11952
11953
11954
11955
11956
11957
11958
11959
11960
11961
11962
11963
11964
11965
11966
11967
11968
11969
11970 static int create_struct_argchck_tbl(int dt_idx)
11971
11972 {
11973 int asg_idx;
11974 int cn_idx;
11975 int i;
11976 int list_idx;
11977 int sub_idx;
11978 int tmp_idx;
11979 int total_word_cnt;
11980 int type_idx;
11981
11982
11983 TRACE (Func_Entry, "create_struct_argchck_tbl", NULL);
11984
11985
11986
11987 total_word_cnt = 2 + determine_struct_tbl_size(dt_idx);
11988
11989
11990
11991 tmp_idx = gen_static_integer_array_tmp(total_word_cnt,
11992 stmt_start_line,
11993 stmt_start_col);
11994
11995
11996
11997 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
11998 TYP_TYPE(TYP_WORK_IDX) = Typeless;
11999 TYP_BIT_LEN(TYP_WORK_IDX) = total_word_cnt * TARGET_BITS_PER_WORD;
12000 type_idx = ntr_type_tbl();
12001
12002 cn_idx = ntr_const_tbl(type_idx, FALSE, NULL);
12003
12004
12005
12006 NTR_IR_TBL(sub_idx);
12007 IR_OPR(sub_idx) = Subscript_Opr;
12008 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE;
12009 IR_LINE_NUM(sub_idx) = stmt_start_line;
12010 IR_COL_NUM(sub_idx) = stmt_start_col;
12011 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
12012 IR_IDX_L(sub_idx) = tmp_idx;
12013 IR_LINE_NUM_L(sub_idx) = stmt_start_line;
12014 IR_COL_NUM_L(sub_idx) = stmt_start_col;
12015
12016 NTR_IR_LIST_TBL(list_idx);
12017 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
12018 IR_IDX_R(sub_idx) = list_idx;
12019 IR_LIST_CNT_R(sub_idx) = 1;
12020 IL_FLD(list_idx) = CN_Tbl_Idx;
12021 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
12022 IL_LINE_NUM(list_idx) = stmt_start_line;
12023 IL_COL_NUM(list_idx) = stmt_start_col;
12024
12025
12026 NTR_IR_TBL(asg_idx);
12027 IR_OPR(asg_idx) = Init_Opr;
12028 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
12029 IR_LINE_NUM(asg_idx) = stmt_start_line;
12030 IR_COL_NUM(asg_idx) = stmt_start_col;
12031
12032 IR_FLD_L(asg_idx) = IR_Tbl_Idx;
12033 IR_IDX_L(asg_idx) = sub_idx;
12034
12035 NTR_IR_LIST_TBL(list_idx);
12036 IR_FLD_R(asg_idx) = IL_Tbl_Idx;
12037 IR_IDX_R(asg_idx) = list_idx;
12038 IR_LIST_CNT_R(asg_idx) = 3;
12039
12040 IL_FLD(list_idx) = CN_Tbl_Idx;
12041 IL_IDX(list_idx) = cn_idx;
12042 IL_LINE_NUM(list_idx) = stmt_start_line;
12043 IL_COL_NUM(list_idx) = stmt_start_col;
12044
12045 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
12046 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
12047 list_idx = IL_NEXT_LIST_IDX(list_idx);
12048
12049 IL_FLD(list_idx) = CN_Tbl_Idx;
12050 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
12051 IL_LINE_NUM(list_idx) = stmt_start_line;
12052 IL_COL_NUM(list_idx) = stmt_start_col;
12053
12054 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
12055 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
12056 list_idx = IL_NEXT_LIST_IDX(list_idx);
12057
12058 IL_FLD(list_idx) = CN_Tbl_Idx;
12059 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
12060 IL_LINE_NUM(list_idx) = stmt_start_line;
12061 IL_COL_NUM(list_idx) = stmt_start_col;
12062
12063 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
12064 FALSE, FALSE, TRUE);
12065
12066 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
12067 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
12068
12069
12070
12071
12072
12073 i = 0;
12074
12075
12076
12077 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = total_word_cnt;
12078 i++;
12079
12080 if (cmd_line_flags.dalign) {
12081 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = TRUE;
12082 }
12083 i++;
12084
12085 fill_in_struct_argchck_const(dt_idx, cn_idx, &i);
12086
12087 # ifdef _DEBUG
12088 if (i != total_word_cnt) {
12089 printf("i = %d, total_word_cnt = %d \n", i, total_word_cnt);
12090 PRINTMSG(stmt_start_line, 1117, Internal, stmt_start_col);
12091 }
12092 # endif
12093
12094 TRACE (Func_Exit, "create_struct_argchck_tbl", NULL);
12095
12096 return(tmp_idx);
12097
12098 }
12099
12100
12101
12102
12103
12104
12105
12106
12107
12108
12109
12110
12111
12112
12113
12114
12115
12116
12117 static int determine_struct_tbl_size(int dt_idx)
12118
12119 {
12120 int i;
12121 int size = 0;
12122 int sn_idx;
12123
12124 TRACE (Func_Entry, "determine_struct_tbl_size", NULL);
12125
12126
12127
12128 size += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(dt_idx));
12129
12130
12131
12132 size += 1;
12133
12134 sn_idx = ATT_FIRST_CPNT_IDX(dt_idx);
12135
12136 for (i = 0; i < ATT_NUM_CPNTS(dt_idx); i++) {
12137
12138
12139
12140 size += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(SN_ATTR_IDX(sn_idx)));
12141
12142
12143
12144 size += 1;
12145
12146
12147
12148 if (ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx)) != NULL_IDX &&
12149 BD_ARRAY_CLASS(ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx))) ==
12150 Explicit_Shape) {
12151
12152 size += 2 * BD_RANK(ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx)));
12153 }
12154
12155 if (TYP_TYPE(ATD_TYPE_IDX(SN_ATTR_IDX(sn_idx))) == Character) {
12156
12157 size += 1;
12158 }
12159 else if (TYP_TYPE(ATD_TYPE_IDX(SN_ATTR_IDX(sn_idx))) == Structure &&
12160 !ATD_POINTER(SN_ATTR_IDX(sn_idx))) {
12161 size += determine_struct_tbl_size(TYP_IDX(ATD_TYPE_IDX(
12162 SN_ATTR_IDX(sn_idx))));
12163 }
12164
12165 sn_idx = SN_SIBLING_LINK(sn_idx);
12166 }
12167
12168 TRACE (Func_Exit, "determine_struct_tbl_size", NULL);
12169
12170 return(size);
12171
12172 }
12173
12174
12175
12176
12177
12178
12179
12180
12181
12182
12183
12184
12185
12186
12187
12188
12189
12190 static void fill_in_struct_argchck_const(int dt_idx,
12191 int cn_idx,
12192 int *idx)
12193
12194 {
12195 int attr_idx;
12196 char *char_ptr;
12197 int i;
12198 int k;
12199 int l;
12200 int sn_idx;
12201 long_type the_constant[MAX_WORDS_FOR_INTEGER];
12202
12203
12204 TRACE (Func_Entry, "fill_in_struct_argchck_const", NULL);
12205
12206 i = *idx;
12207
12208
12209
12210 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) =
12211 ((long_type)(AT_NAME_LEN(dt_idx)) << (TARGET_BITS_PER_WORD - 8));
12212
12213 char_ptr = (char *)&(CP_CONSTANT(CN_POOL_IDX(cn_idx) + i));
12214
12215 char_ptr++;
12216
12217 strncpy(char_ptr, AT_OBJ_NAME_PTR(dt_idx), AT_NAME_LEN(dt_idx));
12218
12219 i += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(dt_idx));
12220
12221 C_TO_F_INT(the_constant, ATT_NUM_CPNTS(dt_idx), CG_INTEGER_DEFAULT_TYPE);
12222
12223 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = the_constant[0];
12224
12225 i++;
12226
12227 sn_idx = ATT_FIRST_CPNT_IDX(dt_idx);
12228
12229 for (k = 0; k < ATT_NUM_CPNTS(dt_idx); k++) {
12230 attr_idx = SN_ATTR_IDX(sn_idx);
12231
12232
12233
12234 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) =
12235 ((long_type)(AT_NAME_LEN(attr_idx)) << (TARGET_BITS_PER_WORD - 8));
12236
12237 char_ptr = (char *)&(CP_CONSTANT(CN_POOL_IDX(cn_idx) + i));
12238 char_ptr++;
12239 strncpy(char_ptr, AT_OBJ_NAME_PTR(attr_idx), AT_NAME_LEN(attr_idx));
12240 i += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(attr_idx));
12241
12242 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |=
12243 (get_arg_type(ATD_TYPE_IDX(attr_idx), FALSE) << 24);
12244
12245 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |=
12246 (linear_to_kind_type[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))] << 16);
12247
12248 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
12249 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |=
12250 (BD_RANK(ATD_ARRAY_IDX(attr_idx)) << 8);
12251 }
12252
12253 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |= ATD_POINTER(attr_idx);
12254
12255 i++;
12256
12257
12258
12259 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX &&
12260 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Explicit_Shape) {
12261
12262 for (l = 1; l <= BD_RANK(ATD_ARRAY_IDX(attr_idx)); l++) {
12263 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) =
12264 CN_CONST(BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), l));
12265 i++;
12266 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) =
12267 CN_CONST(BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), l));
12268 i++;
12269 }
12270 }
12271
12272 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
12273
12274 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) =
12275 CN_CONST(TYP_IDX(ATD_TYPE_IDX(attr_idx)));
12276 i++;
12277 }
12278 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
12279 !ATD_POINTER(attr_idx)) {
12280 fill_in_struct_argchck_const(TYP_IDX(ATD_TYPE_IDX(attr_idx)),
12281 cn_idx, &i);
12282 }
12283
12284 sn_idx = SN_SIBLING_LINK(sn_idx);
12285 }
12286
12287 *idx = i;
12288
12289 TRACE (Func_Exit, "fill_in_struct_argchck_const", NULL);
12290
12291 return;
12292
12293 }
12294
12295
12296
12297
12298
12299
12300
12301
12302
12303
12304
12305
12306
12307
12308
12309
12310
12311 void gen_dbg_write_stmt(opnd_type *opnd,
12312 sh_position_type position)
12313
12314 {
12315 int i;
12316 int ir_idx;
12317 int list_idx;
12318
12319
12320 TRACE (Func_Entry, "gen_dbg_write_stmt", NULL);
12321
12322 NTR_IR_TBL(ir_idx);
12323 IR_OPR(ir_idx) = Write_Formatted_Opr;
12324 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
12325 IR_LINE_NUM(ir_idx) = stmt_start_line;
12326 IR_COL_NUM(ir_idx) = stmt_start_col;
12327
12328
12329 NTR_IR_LIST_TBL(list_idx);
12330 IR_FLD_L(ir_idx) = IL_Tbl_Idx;
12331 IR_LIST_CNT_L(ir_idx) = 10;
12332 IR_IDX_L(ir_idx) = list_idx;
12333
12334 IL_FLD(list_idx) = CN_Tbl_Idx;
12335 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
12336 IL_LINE_NUM(list_idx) = stmt_start_line;
12337 IL_COL_NUM(list_idx) = stmt_start_col;
12338
12339 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
12340 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
12341 list_idx = IL_NEXT_LIST_IDX(list_idx);
12342
12343 IL_FLD(list_idx) = CN_Tbl_Idx;
12344 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
12345 IL_LINE_NUM(list_idx) = stmt_start_line;
12346 IL_COL_NUM(list_idx) = stmt_start_col;
12347
12348 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
12349 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
12350 list_idx = IL_NEXT_LIST_IDX(list_idx);
12351
12352 IL_FLD(list_idx) = CN_Tbl_Idx;
12353 IL_IDX(list_idx) = CN_INTEGER_THREE_IDX;
12354 IL_LINE_NUM(list_idx) = stmt_start_line;
12355 IL_COL_NUM(list_idx) = stmt_start_col;
12356
12357 for (i = 0; i < 7; i++) {
12358 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
12359 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
12360 list_idx = IL_NEXT_LIST_IDX(list_idx);
12361 IL_LINE_NUM(list_idx) = stmt_start_line;
12362 IL_COL_NUM(list_idx) = stmt_start_col;
12363 }
12364
12365 if (OPND_FLD((*opnd)) == IL_Tbl_Idx) {
12366 COPY_OPND(IR_OPND_R(ir_idx), (*opnd));
12367 }
12368 else {
12369 NTR_IR_LIST_TBL(list_idx);
12370 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
12371 IR_LIST_CNT_R(ir_idx) = 1;
12372 IR_IDX_R(ir_idx) = list_idx;
12373
12374 COPY_OPND(IL_OPND(list_idx), (*opnd));
12375 }
12376
12377 gen_sh(position, Assignment_Stmt, stmt_start_line, stmt_start_col,
12378 FALSE, FALSE, TRUE);
12379
12380 if (position == After) {
12381 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
12382 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
12383 }
12384 else {
12385 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
12386 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
12387 }
12388
12389 TRACE (Func_Exit, "gen_dbg_write_stmt", NULL);
12390
12391 return;
12392
12393 }
12394
12395
12396
12397
12398
12399
12400
12401
12402
12403
12404
12405
12406
12407
12408
12409
12410
12411 static void make_base_assumed_size(opnd_type *old_opnd,
12412 opnd_type *new_opnd)
12413
12414 {
12415 int attr_idx;
12416 int bd_idx;
12417 int col;
12418 int i;
12419 int line;
12420 int list_idx;
12421 int sub_idx;
12422
12423 TRACE (Func_Entry, "make_base_assumed_size", NULL);
12424
12425 find_opnd_line_and_column(old_opnd, &line, &col);
12426
12427 # ifdef _DEBUG
12428 if (OPND_FLD((*old_opnd)) != AT_Tbl_Idx) {
12429 PRINTMSG(line, 626, Internal, col,
12430 "AT_Tbl_Idx", "make_base_assumed_size");
12431 }
12432 # endif
12433
12434 attr_idx = OPND_IDX((*old_opnd));
12435 bd_idx = ATD_ARRAY_IDX(attr_idx);
12436
12437 # ifdef _DEBUG
12438 if (bd_idx == NULL_IDX ||
12439 BD_ARRAY_CLASS(bd_idx) != Assumed_Size) {
12440
12441 PRINTMSG(line, 626, Internal, col,
12442 "Assumed Size array", "make_base_assumed_size");
12443 }
12444 # endif
12445
12446 NTR_IR_TBL(sub_idx);
12447 IR_OPR(sub_idx) = Subscript_Opr;
12448 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx);
12449 IR_LINE_NUM(sub_idx) = line;
12450 IR_COL_NUM(sub_idx) = col;
12451 IR_IDX_L(sub_idx) = attr_idx;
12452 IR_FLD_L(sub_idx) = AT_Tbl_Idx;
12453 IR_LINE_NUM_L(sub_idx) = line;
12454 IR_COL_NUM_L(sub_idx) = col;
12455
12456 NTR_IR_LIST_TBL(list_idx);
12457 IR_IDX_R(sub_idx) = list_idx;
12458 IR_FLD_R(sub_idx) = IL_Tbl_Idx;
12459 IR_LIST_CNT_R(sub_idx) = BD_RANK(bd_idx);
12460
12461 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1);
12462 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1);
12463 IL_LINE_NUM(list_idx) = line;
12464 IL_COL_NUM(list_idx) = col;
12465
12466 for (i = 2; i <= BD_RANK(bd_idx); i++) {
12467 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
12468 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
12469 list_idx = IL_NEXT_LIST_IDX(list_idx);
12470
12471 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i);
12472 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i);
12473 IL_LINE_NUM(list_idx) = line;
12474 IL_COL_NUM(list_idx) = col;
12475 }
12476
12477 OPND_FLD((*new_opnd)) = IR_Tbl_Idx;
12478 OPND_IDX((*new_opnd)) = sub_idx;
12479
12480 TRACE (Func_Exit, "make_base_assumed_size", NULL);
12481
12482 return;
12483
12484 }
12485
12486
12487
12488
12489
12490
12491
12492
12493
12494
12495
12496
12497
12498
12499
12500
12501
12502 static void check_call_for_global_def(int list_idx,
12503 int spec_idx,
12504 int num_dargs)
12505
12506 {
12507 uint act_file_line;
12508 int ga_idx;
12509 int gl_idx;
12510 char line_name[256];
12511 int name_idx;
12512 int new_ga_idx;
12513
12514
12515 TRACE (Func_Entry, "check_call_for_global_def", NULL);
12516
12517 if (ATP_PROC(spec_idx) == Dummy_Proc || ATP_NAME_IN_STONE(spec_idx)) {
12518
12519
12520
12521
12522
12523 return;
12524 }
12525
12526 ga_idx = NULL_IDX;
12527
12528
12529
12530
12531
12532
12533
12534
12535
12536 if (srch_global_name_tbl(AT_OBJ_NAME_PTR(spec_idx),
12537 AT_NAME_LEN(spec_idx),
12538 &name_idx)) {
12539
12540 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) {
12541 ga_idx = GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx));
12542 }
12543 else {
12544
12545 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Pgm_Unit) {
12546 ga_idx = GN_ATTR_IDX(name_idx);
12547 }
12548
12549 # if defined(_DEBUG)
12550
12551
12552
12553 if (ga_idx == NULL_IDX) {
12554 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
12555 "valid attr_idx",
12556 "check_call_for_global_def");
12557 }
12558 # endif
12559 }
12560
12561 if (ga_idx == NULL_IDX) {
12562 ga_idx = ntr_global_attr_tbl(spec_idx, name_idx);
12563
12564 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) {
12565 GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)) = ga_idx;
12566 }
12567 else {
12568
12569
12570
12571
12572 GN_ATTR_IDX(name_idx) = ga_idx;
12573 }
12574
12575 ntr_ref_in_global_tbl(list_idx,
12576 spec_idx,
12577 num_dargs,
12578 &ga_idx,
12579 name_idx);
12580 }
12581 else if (GAP_NEEDS_EXPL_ITRFC(ga_idx)) {
12582 line_name[0] = '\0';
12583 GLOBAL_LINE_TO_FILE_LINE(GA_DEF_LINE(ga_idx), gl_idx, act_file_line);
12584
12585 sprintf(line_name, "%d (%s)", act_file_line, GL_FILE_NAME_PTR(gl_idx));
12586 PRINTMSG(stmt_start_line, 1277, Error, stmt_start_col,
12587 AT_OBJ_NAME_PTR(spec_idx),
12588 "defined",
12589 line_name);
12590 }
12591 else if (!GA_DEFINED(ga_idx)) {
12592
12593
12594
12595
12596
12597
12598
12599
12600 global_name_semantics(ga_idx, NULL_IDX, list_idx, spec_idx, NULL_IDX);
12601
12602 new_ga_idx = ntr_global_attr_tbl(spec_idx, name_idx);
12603 GAP_NEXT_PGM_UNIT_IDX(new_ga_idx) = ga_idx;
12604
12605 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) {
12606 GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)) = new_ga_idx;
12607 }
12608 else {
12609 GN_ATTR_IDX(name_idx) = new_ga_idx;
12610 }
12611 ga_idx = new_ga_idx;
12612
12613 ntr_ref_in_global_tbl(list_idx,
12614 spec_idx,
12615 num_dargs,
12616 &ga_idx,
12617 name_idx);
12618 }
12619 else {
12620 global_name_semantics(ga_idx, NULL_IDX, list_idx, spec_idx, NULL_IDX);
12621 }
12622 }
12623 else {
12624 ga_idx = NULL_IDX;
12625 ntr_ref_in_global_tbl(list_idx,
12626 spec_idx,
12627 num_dargs,
12628 &ga_idx,
12629 name_idx);
12630 }
12631
12632
12633 TRACE (Func_Exit, "check_call_for_global_def", NULL);
12634
12635 return;
12636
12637 }
12638
12639
12640
12641
12642
12643
12644
12645
12646
12647
12648
12649
12650
12651
12652
12653
12654
12655
12656
12657
12658
12659
12660
12661
12662
12663
12664
12665 static void ntr_ref_in_global_tbl(int list_idx,
12666 int spec_idx,
12667 int num_dargs,
12668 int *ga_idx,
12669 int name_idx)
12670
12671 {
12672 static int arg_name_idx = NULL_IDX;
12673
12674 int arg_idx;
12675 id_str_type darg_name;
12676 int i;
12677 int il_idx;
12678 int info_idx;
12679 int kwd_idx;
12680 long_type *name_id;
12681 int next_il_idx;
12682 int rslt_idx;
12683 int str_idx;
12684 int type_idx;
12685 int word_len;
12686
12687
12688
12689 TRACE (Func_Entry, "ntr_ref_in_global_tbl", NULL);
12690
12691 if (*ga_idx == NULL_IDX) {
12692
12693
12694
12695
12696
12697
12698 ntr_global_name_tbl(spec_idx, NULL_IDX, name_idx);
12699 *ga_idx = GN_ATTR_IDX(name_idx);
12700 }
12701
12702 fill_in_global_attr_ntry(*ga_idx, spec_idx, NULL_IDX);
12703
12704 GA_REFERENCED(*ga_idx) = TRUE;
12705
12706 if (num_dargs == 0) {
12707 goto DONE;
12708 }
12709
12710
12711
12712 GAP_FIRST_IDX(*ga_idx) = global_attr_tbl_idx + 1;
12713 GAP_NUM_DARGS(*ga_idx) = num_dargs;
12714
12715
12716
12717
12718 next_il_idx = list_idx;
12719 rslt_idx = ATP_RSLT_IDX(spec_idx);
12720
12721 #ifdef KEY
12722 boolean fcn_to_sub = (rslt_idx != NULL_IDX &&
12723 (FUNCTION_MUST_BE_SUBROUTINE(spec_idx, rslt_idx)));
12724 if (fcn_to_sub)
12725 #else
12726 if (rslt_idx != NULL_IDX && FUNCTION_MUST_BE_SUBROUTINE(rslt_idx))
12727 #endif
12728 {
12729 next_il_idx = IL_NEXT_LIST_IDX(next_il_idx);
12730 }
12731
12732 for (i = 0; i < num_dargs; i++ ) {
12733 il_idx = next_il_idx;
12734 info_idx = IL_ARG_DESC_IDX(il_idx);
12735 # ifdef _DEBUG
12736 if (info_idx == NULL_IDX) {
12737 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
12738 "valid info_idx", "ntr_ref_in_global_tbl");
12739 }
12740 # endif
12741
12742 next_il_idx = IL_NEXT_LIST_IDX(il_idx);
12743
12744 TBL_REALLOC_CK(global_attr_tbl, 1);
12745 CLEAR_TBL_NTRY(global_attr_tbl, global_attr_tbl_idx);
12746
12747 arg_idx = global_attr_tbl_idx;
12748 GA_DEF_LINE(arg_idx) = AT_DEF_LINE(spec_idx);
12749 GA_DEF_COLUMN(arg_idx) = AT_DEF_COLUMN(spec_idx);
12750
12751 if (info_idx != NULL_IDX && arg_info_list[info_idx].kwd != NULL_IDX) {
12752
12753
12754
12755 kwd_idx = arg_info_list[info_idx].kwd;
12756 GA_NAME_IDX(arg_idx) = str_pool_idx + 1;
12757 GA_NAME_LEN(arg_idx) = (uint) CN_INT_TO_C(TYP_IDX(
12758 CN_TYPE_IDX(kwd_idx)));
12759 name_id = &(CN_CONST(kwd_idx));
12760 word_len = WORD_LEN(GN_NAME_LEN(arg_idx)) + EXTRA_WORD;
12761
12762 TBL_REALLOC_CK(str_pool, word_len);
12763
12764 for (str_idx = 0; str_idx < word_len; str_idx++) {
12765 str_pool[GA_NAME_IDX(arg_idx)+str_idx].name_long = name_id[str_idx];
12766 }
12767 }
12768 else {
12769
12770 if (arg_name_idx == NULL_IDX) {
12771 CREATE_ID(darg_name, "_darg", 5);
12772 arg_name_idx = str_pool_idx + 1;
12773 name_id = (long_type *) &(darg_name.words[0]);
12774 word_len = WORD_LEN(5) + EXTRA_WORD;
12775
12776 TBL_REALLOC_CK(str_pool, word_len);
12777
12778 for (str_idx = 0; str_idx < word_len; str_idx++) {
12779 str_pool[arg_name_idx + str_idx].name_long = name_id[str_idx];
12780 }
12781 }
12782 GA_NAME_IDX(arg_idx) = arg_name_idx;
12783 GA_NAME_LEN(arg_idx) = 5;
12784 }
12785 GA_ORIG_NAME_IDX(arg_idx) = GA_NAME_IDX(arg_idx);
12786 GA_ORIG_NAME_LEN(arg_idx) = GA_NAME_LEN(arg_idx);
12787 }
12788
12789 next_il_idx = list_idx;
12790
12791 #ifdef KEY
12792 if (rslt_idx != NULL_IDX && fcn_to_sub)
12793 #else
12794 if (rslt_idx != NULL_IDX && FUNCTION_MUST_BE_SUBROUTINE(rslt_idx))
12795 #endif
12796 {
12797 next_il_idx = IL_NEXT_LIST_IDX(next_il_idx);
12798 }
12799
12800 arg_idx = GAP_FIRST_IDX(*ga_idx);
12801
12802 arg_idx--;
12803
12804 while (next_il_idx != NULL_IDX) {
12805 il_idx = next_il_idx;
12806 info_idx = IL_ARG_DESC_IDX(il_idx);
12807 next_il_idx = IL_NEXT_LIST_IDX(il_idx);
12808
12809 arg_idx++;
12810
12811 if (arg_info_list[info_idx].pgm_unit) {
12812
12813
12814
12815 GA_OBJ_CLASS(arg_idx) = Pgm_Unit;
12816
12817
12818 }
12819 else {
12820
12821
12822
12823
12824 if (IL_FLD(il_idx) == CN_Tbl_Idx) {
12825 GA_OBJ_CLASS(arg_idx) = Data_Obj;
12826 GAD_CLASS(arg_idx) = Constant;
12827
12828
12829 GAD_HOLLERITH(arg_idx) = CN_HOLLERITH_TYPE(IL_IDX(il_idx));
12830 }
12831 else if (IL_FLD(il_idx) == AT_Tbl_Idx) {
12832 GA_OBJ_CLASS(arg_idx) = AT_OBJ_CLASS(IL_IDX(il_idx));
12833
12834 if (AT_OBJ_CLASS(IL_IDX(il_idx)) == Data_Obj) {
12835 GAD_CLASS(arg_idx) = ATD_CLASS(IL_IDX(il_idx));
12836 }
12837 }
12838 else {
12839 GA_OBJ_CLASS(arg_idx) = Data_Obj;
12840 GAD_CLASS(arg_idx) = Dummy_Argument;
12841 }
12842
12843 if (GA_OBJ_CLASS(arg_idx) == Data_Obj) {
12844 GAD_RANK(arg_idx) = arg_info_list[info_idx].ed.rank;
12845 GAD_ARRAY_ELEMENT_REF(arg_idx)=arg_info_list[info_idx].ed.array_elt;
12846
12847
12848
12849 if (arg_info_list[info_idx].ed.type_idx != NULL_IDX) {
12850
12851
12852
12853 type_idx =
12854 ntr_global_type_tbl(arg_info_list[info_idx].ed.type_idx);
12855 GAD_TYPE_IDX(arg_idx) = type_idx;
12856 }
12857 else {
12858 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
12859 TYP_TYPE(TYP_WORK_IDX) =arg_info_list[info_idx].ed.type;
12860 TYP_LINEAR(TYP_WORK_IDX) =arg_info_list[info_idx].ed.linear_type;
12861
12862 if (TYP_TYPE(TYP_WORK_IDX) == Character) {
12863 TYP_FLD(TYP_WORK_IDX) = OPND_FLD(
12864 arg_info_list[info_idx].ed.char_len);
12865 TYP_IDX(TYP_WORK_IDX) = OPND_IDX(
12866 arg_info_list[info_idx].ed.char_len);
12867 }
12868 }
12869 }
12870 }
12871 }
12872
12873 DONE:
12874
12875 TRACE (Func_Exit, "ntr_ref_in_global_tbl", NULL);
12876
12877 return;
12878
12879 }
12880
12881 #ifdef KEY
12882
12883
12884
12885
12886 static boolean has_array_arg(int start_il_idx)
12887 {
12888 boolean result = FALSE;
12889 for (int list_idx = start_il_idx; list_idx && !result;
12890 list_idx = IL_NEXT_LIST_IDX(list_idx)) {
12891 int info_idx = IL_ARG_DESC_IDX(list_idx);
12892 expr_arg_type exp_desc = arg_info_list[info_idx].ed;
12893 result = (exp_desc.rank > 0);
12894 }
12895 return result;
12896 }
12897 #endif
12898
12899
12900
12901
12902
12903
12904
12905
12906
12907
12908
12909
12910
12911
12912
12913
12914 static boolean check_elemental_conformance(int start_il_idx,
12915 expr_arg_type *res_exp_desc,
12916 #ifdef KEY
12917 int spec_idx
12918 #endif
12919 )
12920
12921 {
12922 int array_info_idx = NULL_IDX;
12923 int col;
12924 expr_arg_type exp_desc;
12925 int i;
12926 int info_idx;
12927 int line;
12928 int list_idx;
12929 boolean ok = TRUE;
12930
12931 TRACE (Func_Entry, "check_elemental_conformance", NULL);
12932
12933 #ifdef KEY
12934 boolean subroutine_and_array_args = (AT_OBJ_CLASS(spec_idx) == Pgm_Unit &&
12935 ATP_PGM_UNIT(spec_idx) == Subroutine && has_array_arg(start_il_idx));
12936 int dummy_cnt = !!ATP_EXTRA_DARG(spec_idx);
12937 #endif
12938
12939 list_idx = start_il_idx;
12940
12941 while (list_idx && ok) {
12942 info_idx = IL_ARG_DESC_IDX(list_idx);
12943
12944 if (info_idx == NULL_IDX) {
12945 #ifdef KEY
12946
12947
12948
12949 list_idx = IL_NEXT_LIST_IDX(list_idx);
12950 continue;
12951 #else
12952 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
12953 "valid info_idx", "check_elemental_conformance");
12954 #endif
12955 }
12956
12957 exp_desc = arg_info_list[info_idx].ed;
12958
12959 #ifdef KEY
12960
12961
12962
12963
12964
12965
12966
12967 if (subroutine_and_array_args && exp_desc.rank == 0) {
12968 int dummy_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + dummy_cnt);
12969 intent_type intent = ATD_INTENT(dummy_idx);
12970 if (intent == Intent_Inout || intent == Intent_Out) {
12971 find_opnd_line_and_column(&IL_OPND(list_idx), &line, &col);
12972 PRINTMSG(line, 1311, Error, col);
12973 ok = FALSE;
12974 }
12975 }
12976 dummy_cnt += 1;
12977 #endif
12978
12979 if (exp_desc.rank > 0) {
12980 if (array_info_idx == NULL_IDX) {
12981 array_info_idx = info_idx;
12982 res_exp_desc->rank = exp_desc.rank;
12983 COPY_SHAPE(res_exp_desc->shape, exp_desc.shape, exp_desc.rank);
12984 }
12985 else {
12986 if (exp_desc.rank != res_exp_desc->rank) {
12987
12988 find_opnd_line_and_column(&IL_OPND(list_idx),
12989 &line,
12990 &col);
12991 PRINTMSG(line, 1311, Error, col);
12992 ok = FALSE;
12993 }
12994 else {
12995 for (i = 0; i < exp_desc.rank; i++) {
12996
12997 if (OPND_FLD(res_exp_desc->shape[i]) == CN_Tbl_Idx &&
12998 OPND_FLD(exp_desc.shape[i]) == CN_Tbl_Idx) {
12999
13000 if (fold_relationals(OPND_IDX(res_exp_desc->shape[i]),
13001 OPND_IDX(exp_desc.shape[i]),
13002 Ne_Opr)) {
13003
13004 find_opnd_line_and_column(&IL_OPND(list_idx),
13005 &line,
13006 &col);
13007 PRINTMSG(line, 1311, Error, col);
13008 ok = FALSE;
13009 break;
13010 }
13011 }
13012 else if (SHAPE_FOLDABLE(exp_desc.shape[i])) {
13013 COPY_OPND(res_exp_desc->shape[i], exp_desc.shape[i]);
13014 }
13015 }
13016 }
13017 }
13018 }
13019
13020 list_idx = IL_NEXT_LIST_IDX(list_idx);
13021 }
13022
13023 TRACE (Func_Exit, "check_elemental_conformance", NULL);
13024
13025 return(ok);
13026
13027 }
13028
13029
13030
13031
13032
13033
13034
13035
13036
13037
13038
13039
13040
13041
13042
13043
13044
13045 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
13046 static void set_inline_state(int ir_idx,
13047 int attr_idx)
13048
13049 {
13050 int ga_idx = NULL_IDX;
13051 int name_idx;
13052
13053 TRACE (Func_Entry, "set_inline_state", NULL);
13054
13055 if (srch_global_name_tbl(AT_OBJ_NAME_PTR(attr_idx),
13056 AT_NAME_LEN(attr_idx),
13057 &name_idx)) {
13058
13059 ga_idx = GN_ATTR_IDX(name_idx);
13060 }
13061
13062 if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit ||
13063 IR_INLINE_STATE(ir_idx) != Not_Specified_Sgi) {
13064
13065 }
13066 else if (ATP_SGI_LOCAL_INLINE(attr_idx)) {
13067 IR_INLINE_STATE(ir_idx) = Inline_Sgi;
13068 }
13069 else if (ATP_SGI_LOCAL_NOINLINE(attr_idx)) {
13070 IR_INLINE_STATE(ir_idx) = Noinline_Sgi;
13071 }
13072 else if (cdir_switches.inline_here_sgi) {
13073 IR_INLINE_STATE(ir_idx) = Inline_Sgi;
13074 }
13075 else if (cdir_switches.noinline_here_sgi) {
13076 IR_INLINE_STATE(ir_idx) = Noinline_Sgi;
13077 }
13078 else if (ATP_SGI_ROUTINE_INLINE(attr_idx)) {
13079 IR_INLINE_STATE(ir_idx) = Inline_Sgi;
13080 }
13081 else if (ATP_SGI_ROUTINE_NOINLINE(attr_idx)) {
13082 IR_INLINE_STATE(ir_idx) = Noinline_Sgi;
13083 }
13084 else if (SCP_INLINE_SGI(curr_scp_idx)) {
13085 IR_INLINE_STATE(ir_idx) = Inline_Sgi;
13086 }
13087 else if (SCP_NOINLINE_SGI(curr_scp_idx)) {
13088 IR_INLINE_STATE(ir_idx) = Noinline_Sgi;
13089 }
13090 else if (ATP_SGI_GLOBAL_INLINE(attr_idx)) {
13091 IR_INLINE_STATE(ir_idx) = Inline_Sgi;
13092 }
13093 else if (ATP_SGI_GLOBAL_NOINLINE(attr_idx)) {
13094 IR_INLINE_STATE(ir_idx) = Noinline_Sgi;
13095 }
13096 else if (ga_idx != NULL_IDX &&
13097 GA_OBJ_CLASS(ga_idx) == Pgm_Unit &&
13098 GAP_INLINE_STATE(ga_idx) == Inline_Sgi) {
13099 IR_INLINE_STATE(ir_idx) = Inline_Sgi;
13100 }
13101 else if (ga_idx != NULL_IDX &&
13102 GA_OBJ_CLASS(ga_idx) == Pgm_Unit &&
13103 GAP_INLINE_STATE(ga_idx) == Noinline_Sgi) {
13104 IR_INLINE_STATE(ir_idx) = Noinline_Sgi;
13105 }
13106 else if (inline_global_sgi) {
13107 IR_INLINE_STATE(ir_idx) = Inline_Sgi;
13108 }
13109 else if (noinline_global_sgi) {
13110 IR_INLINE_STATE(ir_idx) = Noinline_Sgi;
13111 }
13112
13113
13114 TRACE (Func_Exit, "set_inline_state", NULL);
13115
13116 return;
13117
13118 }
13119 # endif
13120
13121
13122
13123
13124
13125
13126
13127
13128
13129
13130
13131
13132
13133
13134
13135
13136
13137 static void check_for_constructors(opnd_type *top_opnd,
13138 expr_arg_type *exp_desc)
13139
13140 {
13141 int ir_idx;
13142 int list_idx;
13143 expr_arg_type loc_exp_desc;
13144 opnd_type opnd;
13145
13146 TRACE (Func_Entry, "check_for_constructors", NULL);
13147
13148 switch (OPND_FLD((*top_opnd))) {
13149 case IR_Tbl_Idx:
13150 ir_idx = OPND_IDX((*top_opnd));
13151
13152 switch (IR_OPR(ir_idx)) {
13153 case Stmt_Expansion_Opr:
13154 case Call_Opr:
13155 break;
13156
13157 case Array_Construct_Opr :
13158
13159 loc_exp_desc = arg_info_list[IR_IDX_L(ir_idx)].ed;
13160 create_runtime_array_constructor(top_opnd, &loc_exp_desc);
13161 if (exp_desc != NULL) {
13162 COPY_SHAPE((exp_desc->shape),
13163 loc_exp_desc.shape, loc_exp_desc.rank);
13164 }
13165
13166 break;
13167
13168 default:
13169 COPY_OPND(opnd, IR_OPND_L(ir_idx));
13170 check_for_constructors(&opnd, exp_desc);
13171 COPY_OPND(IR_OPND_L(ir_idx), opnd);
13172
13173 COPY_OPND(opnd, IR_OPND_R(ir_idx));
13174 check_for_constructors(&opnd, exp_desc);
13175 COPY_OPND(IR_OPND_R(ir_idx), opnd);
13176 break;
13177 }
13178 break;
13179
13180 case IL_Tbl_Idx:
13181 list_idx = OPND_IDX((*top_opnd));
13182 while (list_idx) {
13183 COPY_OPND(opnd, IL_OPND(list_idx));
13184 check_for_constructors(&opnd, exp_desc);
13185 COPY_OPND(IL_OPND(list_idx), opnd);
13186 list_idx = IL_NEXT_LIST_IDX(list_idx);
13187 }
13188 break;
13189 }
13190
13191
13192 TRACE (Func_Exit, "check_for_constructors", NULL);
13193
13194 return;
13195
13196 }
13197
13198
13199
13200
13201
13202
13203
13204
13205
13206
13207
13208
13209
13210
13211
13212
13213
13214
13215 static boolean compare_darg_to_actual_arg(int gen_idx,
13216 int spec_idx,
13217 int arg_attr,
13218 opnd_type list_opnd,
13219 int info_idx,
13220 int spec_count)
13221
13222
13223 {
13224 int a_linear_type;
13225 int a_type;
13226 int a_type_idx;
13227 int aa_rank;
13228 int attr_idx;
13229 int da_rank;
13230 expr_arg_type exp_desc;
13231 int idx;
13232 opnd_type opnd;
13233 int opnd_line;
13234 int opnd_column;
13235 boolean pgm_unit;
13236 boolean pointer;
13237 boolean same = TRUE;
13238 int type_idx;
13239 char type_word1[40];
13240 char type_word2[40];
13241
13242
13243 TRACE (Func_Entry, "compare_darg_to_actual_arg", NULL);
13244
13245 # if defined(_DEBUG)
13246
13247 if (info_idx == NULL_IDX && OPND_FLD(list_opnd) != AT_Tbl_Idx) {
13248 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
13249 "IL_FLD to be AT_Tbl_Idx",
13250 "compare_darg_to_actual_arg");
13251 }
13252 # endif
13253
13254 find_opnd_line_and_column((opnd_type *) &list_opnd, &opnd_line,
13255 &opnd_column);
13256
13257 attr_idx = OPND_IDX(list_opnd);
13258
13259 if (info_idx == NULL_IDX) {
13260 pgm_unit = (AT_OBJ_CLASS(attr_idx) == Pgm_Unit);
13261 }
13262 else {
13263 pgm_unit = arg_info_list[info_idx].pgm_unit;
13264 }
13265
13266 switch (AT_OBJ_CLASS(arg_attr)) {
13267 case Data_Obj:
13268 #ifdef KEY
13269 if (pgm_unit && strcmp(AT_OBJ_NAME_PTR(gen_idx), "SIGNAL") != 0)
13270 #else
13271 if (pgm_unit)
13272 #endif
13273 {
13274 same = FALSE;
13275
13276 if (spec_count == 0) {
13277 PRINTMSG(opnd_line, 503, Error, opnd_column,
13278 AT_OBJ_NAME_PTR(attr_idx),
13279 "PROGRAM UNIT",
13280 AT_OBJ_NAME_PTR(arg_attr),
13281 "DATA OBJECT");
13282 }
13283 break;
13284 }
13285
13286 if (ATD_IGNORE_TKR(arg_attr)) {
13287
13288
13289
13290
13291 }
13292 else if (OPND_FLD(list_opnd) == IR_Tbl_Idx &&
13293 IR_OPR(OPND_IDX(list_opnd)) == Null_Intrinsic_Opr) {
13294
13295
13296
13297 }
13298 #ifdef KEY
13299 else if (!((strcmp(AT_OBJ_NAME_PTR(gen_idx), "EOSHIFT") == 0) &&
13300 (strcmp(AT_OBJ_NAME_PTR(arg_attr), "BOUNDARY") == 0)) &&
13301 strcmp(AT_OBJ_NAME_PTR(gen_idx), "SIGNAL") != 0)
13302 #else
13303 else if (!((strcmp(AT_OBJ_NAME_PTR(gen_idx), "EOSHIFT") == 0) &&
13304 (strcmp(AT_OBJ_NAME_PTR(arg_attr), "BOUNDARY") == 0)))
13305 #endif
13306 {
13307
13308 if (!(strcmp(AT_OBJ_NAME_PTR(gen_idx), "RESHAPE") == 0) ||
13309 ((strcmp(AT_OBJ_NAME_PTR(arg_attr), "PAD") != 0) &&
13310 (strcmp(AT_OBJ_NAME_PTR(arg_attr), "ORDER") != 0))) {
13311
13312 aa_rank = 0;
13313 da_rank = (ATD_ARRAY_IDX(arg_attr) ?
13314 BD_RANK(ATD_ARRAY_IDX(arg_attr)) : 0);
13315
13316 if (info_idx == NULL_IDX) {
13317 pointer = ATD_POINTER(attr_idx);
13318
13319 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
13320 aa_rank = BD_RANK(ATD_ARRAY_IDX(attr_idx));
13321 }
13322 }
13323 else {
13324 aa_rank = arg_info_list[info_idx].ed.rank;
13325 pointer = arg_info_list[info_idx].ed.pointer;
13326 }
13327
13328 if (!AT_ELEMENTAL_INTRIN(spec_idx) &&
13329 !ATP_ELEMENTAL(spec_idx) &&
13330 aa_rank != da_rank) {
13331
13332 if (spec_count > 0) {
13333
13334
13335
13336 same = FALSE;
13337 break;
13338 }
13339
13340 if (pointer && ATD_POINTER(arg_attr)) {
13341 PRINTMSG(opnd_line, 1091, Error, opnd_column,
13342 AT_OBJ_NAME_PTR(arg_attr));
13343 same = FALSE;
13344 }
13345 else if (aa_rank == 0) {
13346
13347 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(arg_attr)) == Assumed_Shape){
13348 PRINTMSG(opnd_line, 434, Error, opnd_column,
13349 AT_OBJ_NAME_PTR(arg_attr));
13350 same = FALSE;
13351 }
13352 else if (info_idx != NULL_IDX &&
13353 arg_info_list[info_idx].ed.array_elt) {
13354
13355
13356
13357
13358
13359 }
13360 else {
13361 PRINTMSG(opnd_line, 435, Error, opnd_column,
13362 AT_OBJ_NAME_PTR(arg_attr));
13363 same = FALSE;
13364 }
13365 }
13366 else if (da_rank == 0) {
13367 same = FALSE;
13368 PRINTMSG(opnd_line, 436, Error, opnd_column,
13369 AT_OBJ_NAME_PTR(arg_attr));
13370 }
13371 else {
13372
13373 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(arg_attr)) == Assumed_Shape){
13374 PRINTMSG(opnd_line, 772, Error, opnd_column,
13375 AT_OBJ_NAME_PTR(arg_attr));
13376 break;
13377 }
13378 }
13379 }
13380 }
13381 }
13382
13383 if (info_idx == NULL_IDX) {
13384 a_type_idx = ATD_TYPE_IDX(attr_idx);
13385 a_linear_type = TYP_LINEAR(a_type_idx);
13386 a_type = TYP_TYPE(a_type_idx);
13387 }
13388 else {
13389 a_type_idx = arg_info_list[info_idx].ed.type_idx;
13390 a_linear_type = arg_info_list[info_idx].ed.linear_type;
13391 a_type = arg_info_list[info_idx].ed.type;
13392 }
13393
13394 #ifdef KEY
13395
13396
13397 if (ATP_PROC(spec_idx) == Intrin_Proc && ATD_INTRIN_DARG(arg_attr))
13398 #else
13399 if (ATP_PROC(spec_idx) == Intrin_Proc)
13400 #endif
13401 {
13402
13403 if (((1 << a_linear_type) & ATD_INTRIN_DARG_TYPE(arg_attr)) == 0) {
13404 same = FALSE;
13405
13406 if (spec_count == 0) {
13407 PRINTMSG(opnd_line, 334, Error, opnd_column);
13408 }
13409 break;
13410 }
13411 }
13412 else if (ATD_IGNORE_TKR(arg_attr)) {
13413
13414
13415
13416
13417 }
13418 else if (OPND_FLD(list_opnd) == IR_Tbl_Idx &&
13419 IR_OPR(OPND_IDX(list_opnd)) == Null_Intrinsic_Opr) {
13420
13421
13422
13423 }
13424 else {
13425 type_idx = ATD_TYPE_IDX(arg_attr);
13426
13427 if (a_linear_type == Short_Typeless_Const &&
13428 (TYP_TYPE(type_idx) == Integer ||
13429 TYP_TYPE(type_idx) == Real ||
13430 TYP_TYPE(type_idx) == Complex)) {
13431
13432
13433
13434 }
13435 else if (a_type == Typeless &&
13436 (TYP_TYPE(type_idx) == Integer ||
13437 TYP_TYPE(type_idx) == Real) &&
13438 num_host_wds[a_linear_type] ==
13439 num_host_wds[TYP_LINEAR(type_idx)]) {
13440
13441
13442
13443 }
13444 else if (a_linear_type == Short_Typeless_Const &&
13445 (CN_HOLLERITH_TYPE(OPND_IDX(list_opnd)) == H_Hollerith ||
13446 CN_HOLLERITH_TYPE(OPND_IDX(list_opnd)) == L_Hollerith) &&
13447 TYP_TYPE(type_idx) == Character) {
13448
13449
13450
13451 }
13452 else if (a_type != TYP_TYPE(type_idx)) {
13453 same = FALSE;
13454
13455 if (spec_count == 0) {
13456 type_word1[0] = '\0';
13457 type_word2[0] = '\0';
13458 strcat(type_word1,get_basic_type_str(type_idx));
13459 strcat(type_word2,get_basic_type_str(a_type_idx));
13460 PRINTMSG(opnd_line, 1108, Error, opnd_column,
13461 type_word2,
13462 type_word1);
13463 }
13464 }
13465 else if (TYP_TYPE(type_idx) == Structure &&
13466 !compare_derived_types(type_idx, a_type_idx)) {
13467 same = FALSE;
13468
13469 if (spec_count == 0) {
13470 type_word1[0] = '\0';
13471 type_word2[0] = '\0';
13472 strcat(type_word1,get_basic_type_str(type_idx));
13473 strcat(type_word2,get_basic_type_str(a_type_idx));
13474 PRINTMSG(opnd_line, 1108, Error, opnd_column,
13475 type_word2,
13476 type_word1);
13477 }
13478 }
13479 else if (TYP_TYPE(type_idx) == Character) {
13480
13481 if (info_idx != NULL_IDX && TYP_FLD(type_idx) == CN_Tbl_Idx) {
13482 COPY_OPND(opnd, list_opnd);
13483 exp_desc = arg_info_list[info_idx].ed;
13484 same &= validate_char_len(&opnd, &exp_desc);
13485 arg_info_list[info_idx].ed = exp_desc;
13486
13487 if (TYP_FLD(exp_desc.type_idx) == CN_Tbl_Idx &&
13488 fold_relationals(TYP_IDX(exp_desc.type_idx),
13489 TYP_IDX(type_idx),
13490 Lt_Opr)) {
13491
13492 if (OPND_FLD(list_opnd) == CN_Tbl_Idx) {
13493 PRINTMSG(opnd_line, 1305, Caution, opnd_column);
13494 PRINTMSG(opnd_line, 1306, Ansi, opnd_column);
13495 cast_to_type_idx(&opnd,
13496 &exp_desc,
13497 type_idx);
13498 arg_info_list[info_idx].ed = exp_desc;
13499 COPY_OPND(list_opnd, opnd);
13500 }
13501 }
13502 }
13503 }
13504 else if (TYP_TYPE(type_idx) != Structure &&
13505 a_linear_type != TYP_LINEAR(type_idx)) {
13506 same = FALSE;
13507
13508 if (spec_count == 0) {
13509 PRINTMSG(opnd_line, 1307, Error, opnd_column,
13510 storage_bit_kind_tbl[a_linear_type],
13511 storage_bit_kind_tbl[TYP_LINEAR(type_idx)]);
13512 }
13513 }
13514 }
13515 break;
13516
13517
13518 case Pgm_Unit :
13519
13520 if (!pgm_unit) {
13521 same = FALSE;
13522
13523 if (spec_count == 0) {
13524 PRINTMSG(opnd_line, 502, Error,
13525 opnd_column,
13526 AT_OBJ_NAME_PTR(arg_attr));
13527 }
13528 break;
13529 }
13530 #ifdef KEY
13531 else if (ATD_IGNORE_TKR(arg_attr)) {
13532
13533 }
13534 #endif
13535 else if (ATP_EXPL_ITRFC(attr_idx) && ATP_EXPL_ITRFC(arg_attr)) {
13536
13537
13538
13539
13540
13541 if (ATP_NUM_DARGS(attr_idx) == ATP_NUM_DARGS(arg_attr) &&
13542 ATP_PGM_UNIT(attr_idx) == ATP_PGM_UNIT(arg_attr)) {
13543
13544 if (ATP_PGM_UNIT(attr_idx) == Function) {
13545
13546 if (info_idx != NULL_IDX) {
13547
13548 same = compare_func_result(arg_attr,
13549 arg_info_list[info_idx].ed.type_idx,
13550 arg_info_list[info_idx].ed.type,
13551 arg_info_list[info_idx].ed.linear_type,
13552 arg_info_list[info_idx].ed.rank,
13553 spec_count,
13554 opnd_line,
13555 opnd_column);
13556 }
13557 else {
13558 a_type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
13559 aa_rank = (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)) == NULL_IDX)?
13560 0 : BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)));
13561
13562 same = compare_func_result(arg_attr,
13563 a_type_idx,
13564 TYP_TYPE(a_type_idx),
13565 TYP_LINEAR(a_type_idx),
13566 aa_rank,
13567 spec_count,
13568 opnd_line,
13569 opnd_column);
13570 }
13571
13572 if (!same) {
13573 break;
13574 }
13575 }
13576
13577
13578
13579 for (idx = (ATP_EXTRA_DARG(arg_attr) ? 1:0);
13580 idx < ATP_NUM_DARGS(arg_attr); idx++) {
13581
13582 COPY_OPND(opnd, list_opnd);
13583 OPND_FLD(opnd) = AT_Tbl_Idx;
13584 OPND_IDX(opnd) = SN_ATTR_IDX(ATP_FIRST_IDX(attr_idx)+idx);
13585
13586 if (!compare_darg_to_actual_arg(
13587 gen_idx,
13588 spec_idx,
13589 SN_ATTR_IDX(ATP_FIRST_IDX(arg_attr)+idx),
13590 opnd,
13591 NULL_IDX,
13592 spec_count)) {
13593
13594
13595
13596
13597 same = FALSE;
13598 break;
13599 }
13600 }
13601 }
13602 else {
13603
13604 if (spec_count == 0) {
13605 PRINTMSG(opnd_line, 1635, Error,
13606 opnd_column,
13607 AT_OBJ_NAME_PTR(attr_idx),
13608 AT_OBJ_NAME_PTR(arg_attr));
13609 }
13610 same = FALSE;
13611 }
13612 }
13613 else if (ATP_EXPL_ITRFC(arg_attr) && spec_count != 0) {
13614
13615
13616
13617
13618
13619
13620 same = FALSE;
13621 }
13622 else if (ATP_PGM_UNIT(attr_idx) == Function) {
13623
13624
13625
13626
13627 if (ATP_PGM_UNIT(arg_attr) == Function ||
13628 ATP_PGM_UNIT(arg_attr) == Pgm_Unknown) {
13629
13630 if (info_idx != NULL_IDX) {
13631 same = compare_func_result(arg_attr,
13632 arg_info_list[info_idx].ed.type_idx,
13633 arg_info_list[info_idx].ed.type,
13634 arg_info_list[info_idx].ed.linear_type,
13635 arg_info_list[info_idx].ed.rank,
13636 spec_count,
13637 opnd_line,
13638 opnd_column);
13639 }
13640 else {
13641 a_type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
13642 aa_rank = (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)) == NULL_IDX)?
13643 0 : BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)));
13644
13645 same = compare_func_result(arg_attr,
13646 a_type_idx,
13647 TYP_TYPE(a_type_idx),
13648 TYP_LINEAR(a_type_idx),
13649 aa_rank,
13650 spec_count,
13651 opnd_line,
13652 opnd_column);
13653 }
13654
13655 if (!same) {
13656
13657 if (spec_count == 0) {
13658
13659
13660
13661 }
13662 else {
13663 break;
13664 }
13665 }
13666 }
13667 else {
13668 same = FALSE;
13669
13670 if (spec_count == 0) {
13671 PRINTMSG(opnd_line, 503, Error, opnd_column,
13672 AT_OBJ_NAME_PTR(attr_idx),
13673 "FUNCTION",
13674 AT_OBJ_NAME_PTR(arg_attr),
13675 "SUBROUTINE");
13676 }
13677 break;
13678 }
13679 }
13680 else if (ATP_PGM_UNIT(attr_idx) == Subroutine) {
13681
13682
13683
13684 if (ATP_PGM_UNIT(arg_attr) != Subroutine &&
13685 ATP_PGM_UNIT(arg_attr) != Pgm_Unknown) {
13686 same = FALSE;
13687
13688 if (spec_count == 0) {
13689 PRINTMSG(opnd_line, 503, Error,
13690 opnd_column,
13691 AT_OBJ_NAME_PTR(attr_idx),
13692 "SUBROUTINE",
13693 AT_OBJ_NAME_PTR(arg_attr),
13694 "FUNCTION");
13695 }
13696 break;
13697 }
13698 }
13699 else if (ATP_PGM_UNIT(attr_idx) == Pgm_Unknown) {
13700
13701
13702
13703
13704 if (ATP_PGM_UNIT(arg_attr) != Subroutine &&
13705 ATP_PGM_UNIT(arg_attr) != Function &&
13706 ATP_PGM_UNIT(arg_attr) != Pgm_Unknown) {
13707
13708
13709
13710
13711 # ifdef _DEBUG
13712 print_at_all(arg_attr);
13713 # endif
13714 PRINTMSG(opnd_line, 972, Internal, opnd_column);
13715 }
13716 }
13717
13718
13719 break;
13720
13721 default :
13722 # ifdef _DEBUG
13723 print_at_all(arg_attr);
13724 # endif
13725 PRINTMSG(opnd_line, 972, Internal, opnd_column);
13726 break;
13727
13728 }
13729
13730 TRACE (Func_Exit, "compare_darg_to_actual_arg", NULL);
13731
13732 return(same);
13733
13734 }
13735
13736
13737
13738
13739
13740
13741
13742
13743
13744
13745
13746
13747
13748
13749
13750
13751
13752
13753 static boolean compare_func_result(int darg_attr,
13754 int a_type_idx,
13755 int a_type,
13756 int a_linear_type,
13757 int a_rank,
13758 int spec_count,
13759 int line,
13760 int column)
13761
13762 {
13763 boolean same = TRUE;
13764 int type_idx;
13765 char type_word1[40];
13766 char type_word2[40];
13767
13768
13769 TRACE (Func_Entry, "compare_func_result", NULL);
13770
13771 darg_attr = ATP_RSLT_IDX(darg_attr);
13772
13773 if (darg_attr == NULL_IDX) {
13774 type_idx = a_type_idx;
13775 }
13776 else {
13777 type_idx = ATD_TYPE_IDX(darg_attr);
13778 }
13779
13780 if (a_type != TYP_TYPE(type_idx)){
13781 same = FALSE;
13782
13783 if (spec_count == 0) {
13784 type_word1[0] = '\0';
13785 type_word2[0] = '\0';
13786 strcat(type_word1,get_basic_type_str(type_idx));
13787 strcat(type_word2,get_basic_type_str(a_type_idx));
13788 PRINTMSG(line, 1108, Error, column, type_word2, type_word1);
13789 }
13790 }
13791 else if (TYP_TYPE(type_idx) == Structure &&
13792 !compare_derived_types(a_type_idx, type_idx)) {
13793 same = FALSE;
13794
13795 if (spec_count == 0) {
13796 type_word1[0] = '\0';
13797 type_word2[0] = '\0';
13798 strcat(type_word1, get_basic_type_str(type_idx));
13799 strcat(type_word2, get_basic_type_str(a_type_idx));
13800 PRINTMSG(line, 1108, Error, column, type_word2, type_word1);
13801 }
13802 }
13803 else if (TYP_TYPE(type_idx) != Structure &&
13804 TYP_TYPE(type_idx) != Character &&
13805 a_linear_type != TYP_LINEAR(type_idx)) {
13806 same = FALSE;
13807
13808 if (spec_count == 0) {
13809 PRINTMSG(line, 1307, Error, column,
13810 storage_bit_kind_tbl[a_linear_type],
13811 storage_bit_kind_tbl[TYP_LINEAR(type_idx)]);
13812 }
13813 }
13814 else if (darg_attr != NULL_IDX && (a_rank != (ATD_ARRAY_IDX(darg_attr) ?
13815 BD_RANK(ATD_ARRAY_IDX(darg_attr)) : 0))) {
13816
13817 if (spec_count != 0) {
13818 same = FALSE;
13819 }
13820 }
13821
13822 TRACE (Func_Exit, "compare_func_result", NULL);
13823
13824 return(same);
13825
13826 }
13827
13828
13829
13830
13831
13832
13833
13834
13835
13836
13837
13838
13839
13840
13841
13842
13843
13844 static boolean check_arg_for_co_array(opnd_type *top_opnd)
13845
13846 {
13847 int col;
13848 int ir_idx;
13849 int line;
13850 int list_idx;
13851 boolean ok = TRUE;
13852 opnd_type opnd;
13853
13854 TRACE (Func_Entry, "check_arg_for_co_array", NULL);
13855
13856 if (OPND_FLD((*top_opnd)) == IR_Tbl_Idx) {
13857 ir_idx = OPND_IDX((*top_opnd));
13858
13859 switch(IR_OPR(ir_idx)) {
13860 case Struct_Opr:
13861 case Dv_Deref_Opr:
13862 COPY_OPND(opnd, IR_OPND_L(ir_idx));
13863 ok &= check_arg_for_co_array(&opnd);
13864 break;
13865
13866 case Subscript_Opr:
13867 case Whole_Subscript_Opr:
13868 case Section_Subscript_Opr:
13869 list_idx = IR_IDX_R(ir_idx);
13870 while (list_idx) {
13871 if (IL_PE_SUBSCRIPT(list_idx)) {
13872 find_opnd_line_and_column(&IL_OPND(list_idx), &line, &col);
13873 PRINTMSG(line, 1366, Error, col);
13874 ok = FALSE;
13875 break;
13876 }
13877 list_idx = IL_NEXT_LIST_IDX(list_idx);
13878 }
13879
13880
13881
13882
13883 case Substring_Opr:
13884 case Whole_Substring_Opr:
13885
13886 COPY_OPND(opnd, IR_OPND_L(ir_idx));
13887 ok &= check_arg_for_co_array(&opnd);
13888
13889 list_idx = IR_IDX_R(ir_idx);
13890 while (list_idx) {
13891 COPY_OPND(opnd, IL_OPND(list_idx));
13892 ok &= check_arg_for_co_array(&opnd);
13893 list_idx = IL_NEXT_LIST_IDX(list_idx);
13894 }
13895 break;
13896
13897 case Triplet_Opr:
13898 list_idx = IR_IDX_L(ir_idx);
13899 while (list_idx) {
13900 COPY_OPND(opnd, IL_OPND(list_idx));
13901 ok &= check_arg_for_co_array(&opnd);
13902 list_idx = IL_NEXT_LIST_IDX(list_idx);
13903 }
13904 break;
13905
13906 }
13907 }
13908
13909 TRACE (Func_Exit, "check_arg_for_co_array", NULL);
13910
13911 return(ok);
13912
13913 }
13914
13915
13916
13917
13918
13919
13920
13921
13922
13923
13924
13925
13926
13927
13928
13929
13930
13931 static void update_components(opnd_type *opnd)
13932
13933 {
13934 int attr_idx;
13935 int il_idx;
13936 int ir_idx;
13937 int sn_idx;
13938
13939
13940 TRACE (Func_Entry, "update_components", NULL);
13941
13942 switch (OPND_FLD((*opnd))) {
13943 case IR_Tbl_Idx:
13944
13945 ir_idx = OPND_IDX((*opnd));
13946
13947 if (IR_OPR(ir_idx) == Struct_Opr) {
13948
13949
13950
13951 if (IR_FLD_L(ir_idx) == AT_Tbl_Idx &&
13952 AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Derived_Type) {
13953
13954 if (ATD_DERIVED_TYPE_IDX(IR_IDX_R(ir_idx)) != IR_IDX_L(ir_idx)) {
13955
13956
13957
13958
13959 sn_idx = ATT_FIRST_CPNT_IDX(IR_IDX_L(ir_idx));
13960 attr_idx = srch_linked_sn(AT_OBJ_NAME_PTR(IR_IDX_R(ir_idx)),
13961 AT_NAME_LEN(IR_IDX_R(ir_idx)),
13962 &sn_idx);
13963
13964 # ifdef _DEBUG
13965 if (attr_idx == NULL_IDX) {
13966 PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal,
13967 IR_COL_NUM(ir_idx),
13968 "component to be found",
13969 "update_components");
13970 }
13971 # endif
13972 IR_IDX_R(ir_idx) = attr_idx;
13973 }
13974 }
13975 else {
13976
13977 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
13978
13979
13980
13981
13982 if (TYP_TYPE(IR_TYPE_IDX(IR_IDX_L(ir_idx))) == Structure &&
13983 ATD_DERIVED_TYPE_IDX(IR_IDX_R(ir_idx)) !=
13984 TYP_IDX(IR_TYPE_IDX(IR_IDX_L(ir_idx)))) {
13985
13986
13987
13988
13989 sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX(
13990 IR_TYPE_IDX(IR_IDX_L(ir_idx))));
13991 attr_idx = srch_linked_sn(AT_OBJ_NAME_PTR(IR_IDX_R(ir_idx)),
13992 AT_NAME_LEN(IR_IDX_R(ir_idx)),
13993 &sn_idx);
13994
13995 # ifdef _DEBUG
13996 if (attr_idx == NULL_IDX) {
13997 PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal,
13998 IR_COL_NUM(ir_idx),
13999 "component to be found",
14000 "update_components");
14001 }
14002 # endif
14003 IR_IDX_R(ir_idx) = attr_idx;
14004 }
14005 }
14006 update_components(&IR_OPND_L(ir_idx));
14007 }
14008 }
14009 else {
14010 update_components(&IR_OPND_L(ir_idx));
14011 update_components(&IR_OPND_R(ir_idx));
14012 }
14013
14014 break;
14015
14016 case IL_Tbl_Idx:
14017 il_idx = OPND_IDX((*opnd));
14018
14019 do {
14020 update_components(&IL_OPND(il_idx));
14021 il_idx = IL_NEXT_LIST_IDX(il_idx);
14022 }
14023 while (il_idx != NULL_IDX);
14024 break;
14025
14026 case NO_Tbl_Idx:
14027 case SH_Tbl_Idx:
14028 case AT_Tbl_Idx:
14029 case CN_Tbl_Idx:
14030 case SB_Tbl_Idx:
14031 break;
14032
14033 default:
14034 break;
14035 }
14036
14037 TRACE (Func_Exit, "update_components", NULL);
14038
14039 return;
14040
14041 }
