00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037 static char USMID[] = "\n@(#)5.0_pl/sources/s_call.c 5.15 10/19/99 17:14:30\n";
00038
00039 # include "defines.h"
00040
00041 # include "host.m"
00042 # include "host.h"
00043 # include "target.m"
00044 # include "target.h"
00045
00046 # include "globals.m"
00047 # include "tokens.m"
00048 # include "sytb.m"
00049 # include "s_globals.m"
00050 # include "debug.m"
00051 # include "s_call.m"
00052
00053 # include "globals.h"
00054 # include "tokens.h"
00055 # include "sytb.h"
00056 # include "s_globals.h"
00057 # include "s_call.h"
00058
00059 boolean variable_size_func_expr = FALSE;
00060
00061
00062
00063
00064
00065 static boolean compare_darg_to_actual_arg(int, int, int, opnd_type,
00066 int, int);
00067 static boolean compare_func_result(int,int,int,int,int,int,int,int);
00068 static int copy_and_replace_tmps (int);
00069 static int create_tmp_DV_asg (int, int);
00070 static int create_tmp_from_stmt_func (int);
00071 static void determine_num_elements (opnd_type *, expr_arg_type *,
00072 int, int);
00073 static int expand_user_bound (int);
00074 static void find_attrs_in_il(int);
00075 static void find_attrs_in_ir(int);
00076 static void find_attrs_used_in_bound(int);
00077 static dummy_arg_type get_dummy_arg_type (int);
00078 static void make_new_bd_entries (int, int *, int *);
00079 static void save_array_syntax_subscripts (int);
00080 static void set_at_actual_arg (int);
00081 static void process_variable_size_func (int, int, int,
00082 int, int *, int *);
00083 static void check_bd_typ_for_dargs(int, int, opnd_type *);
00084 static void search_expr_for_dargs(opnd_type *, opnd_type *);
00085 static int gen_arg_type_descriptor(int, boolean, int, int);
00086 static int gen_call_type_descriptor(int, int, boolean, int, int);
00087 static long_type get_arg_type(int, boolean);
00088 static int create_struct_argchck_tbl(int);
00089 static int determine_struct_tbl_size(int);
00090 static void fill_in_struct_argchck_const(int, int, int *);
00091 static void make_base_assumed_size(opnd_type *, opnd_type *);
00092 static void check_call_for_global_def(int, int, int);
00093 static void ntr_ref_in_global_tbl(int, int, int, int *, int);
00094
00095 void gen_dbg_write_stmt(opnd_type *, sh_position_type);
00096 static boolean check_elemental_conformance(int, expr_arg_type *);
00097 static void check_for_constructors(opnd_type *, expr_arg_type *);
00098 static void check_for_elementals(int);
00099 static void check_expr_for_elementals(opnd_type *);
00100 static boolean check_arg_for_co_array(opnd_type *);
00101 static void update_components(opnd_type *);
00102
00103
00104 # if defined(GENERATE_WHIRL)
00105 static void set_inline_state(int, int);
00106 # endif
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127 boolean call_list_semantics(opnd_type *result_opnd,
00128 expr_arg_type *res_exp_desc,
00129 boolean is_function)
00130
00131 {
00132
00133 int arg_attr;
00134 int alt_return_tmp;
00135 int arg_idx;
00136 int asg_idx;
00137 int attr_idx;
00138 int br_idx_idx;
00139 int col;
00140 expr_arg_type exp_desc;
00141 boolean found = FALSE;
00142 int gen_idx;
00143 boolean has_symbolic = FALSE;
00144 boolean host_associated = FALSE;
00145 int i;
00146 int idx;
00147 int info_idx;
00148 int ir_idx;
00149 int label_cnt = 0;
00150 int label_list_head = NULL_IDX;
00151 int label_list_tail = NULL_IDX;
00152 long_type length;
00153 int line;
00154 int list_cnt;
00155 int list_idx;
00156 int list_idx2;
00157 int loc_idx;
00158 int name_idx;
00159 int new_sn_idx;
00160 int num_registers;
00161 boolean locked_in;
00162 boolean reset_expr_mode;
00163 int loc_info_idx;
00164 int msg_num;
00165 int new_attr_idx;
00166 int num_args;
00167 boolean ok = TRUE;
00168 opnd_type opnd;
00169 int opnd_column;
00170 int opnd_line;
00171 int rslt_idx;
00172 opnd_type save_char_len;
00173 int save_curr_stmt_sh_idx;
00174 boolean save_defer_stmt_expansion;
00175 expr_mode_type save_expr_mode;
00176 boolean save_foldable;
00177 boolean save_in_call_list;
00178 boolean save_io_item_must_flatten;
00179 opnd_type save_result_opnd;
00180 int save_where_ir_idx;
00181 boolean save_will_fold_later;
00182 cif_usage_code_type save_xref_state;
00183 int save_rank;
00184 opnd_type save_shape[7];
00185 boolean save_shape_known;
00186 int sn_idx;
00187 int spec_sn_idx = NULL_IDX;
00188 int spec_count;
00189 int spec_idx;
00190 int type_idx;
00191
00192 # if defined(GENERATE_WHIRL)
00193 int false_list_idx = NULL_IDX;
00194 # endif
00195
00196
00197 TRACE (Func_Entry, "call_list_semantics", NULL);
00198
00199 stmt_expansion_control_start();
00200 save_defer_stmt_expansion = defer_stmt_expansion;
00201 defer_stmt_expansion = FALSE;
00202 save_result_opnd = null_opnd;
00203
00204 ir_idx = OPND_IDX((*result_opnd));
00205
00206
00207
00208 if (max_call_list_size >= arg_list_size) {
00209 enlarge_call_list_tables();
00210 }
00211
00212 arg_info_list_base = arg_info_list_top;
00213
00214 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx);
00215
00216 if (arg_info_list_top >= arg_info_list_size) {
00217 enlarge_info_list_table();
00218 }
00219
00220 loc_info_idx = arg_info_list_base;
00221
00222 attr_idx = IR_IDX_L(ir_idx);
00223 locked_in = AT_LOCKED_IN(attr_idx);
00224 AT_LOCKED_IN(attr_idx) = TRUE;
00225
00226 # if defined(GENERATE_WHIRL)
00227 IR_INLINE_STATE(ir_idx) = Not_Specified_Sgi;
00228 set_inline_state(ir_idx, attr_idx);
00229 # endif
00230
00231 if (AT_ATTR_LINK(attr_idx)) {
00232 host_associated = TRUE;
00233 }
00234
00235 while (AT_ATTR_LINK(attr_idx) &&
00236 ! AT_IGNORE_ATTR_LINK(attr_idx)) {
00237
00238 attr_idx = AT_ATTR_LINK(attr_idx);
00239 locked_in = locked_in || AT_LOCKED_IN(attr_idx);
00240 AT_LOCKED_IN(attr_idx) = TRUE;
00241
00242 # if defined(GENERATE_WHIRL)
00243 set_inline_state(ir_idx, attr_idx);
00244 # endif
00245
00246 }
00247
00248 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
00249 ATP_PROC(attr_idx) == Dummy_Proc &&
00250 ATP_DUMMY_PROC_LINK(attr_idx) != NULL_IDX) {
00251
00252 attr_idx = ATP_DUMMY_PROC_LINK(attr_idx);
00253
00254 # if defined(GENERATE_WHIRL)
00255 set_inline_state(ir_idx, attr_idx);
00256 # endif
00257
00258 }
00259
00260 IR_IDX_L(ir_idx) = attr_idx;
00261 spec_idx = attr_idx;
00262 gen_idx = attr_idx;
00263 line = IR_LINE_NUM_L(ir_idx);
00264 col = IR_COL_NUM_L(ir_idx);
00265
00266 if ((cif_flags & XREF_RECS) != 0 && xref_state != CIF_No_Usage_Rec) {
00267 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00268 }
00269
00270 if (cdir_switches.parallel_region &&
00271 AT_OBJ_CLASS(gen_idx) == Pgm_Unit &&
00272 ATP_PROC(gen_idx) == Dummy_Proc &&
00273 ! cdir_switches.autoscope &&
00274 ! ATP_TASK_SHARED(gen_idx)) {
00275
00276 PRINTMSG(line, 1041, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00277 ok = FALSE;
00278 }
00279
00280 if (expr_mode == Restricted_Imp_Do_Expr) {
00281 PRINTMSG(line, 658, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00282 ok = FALSE;
00283 goto DONE;
00284 }
00285
00286 save_where_ir_idx = where_ir_idx;
00287 save_io_item_must_flatten = io_item_must_flatten;
00288
00289 if (! AT_ELEMENTAL_INTRIN(gen_idx)) {
00290 where_ir_idx = NULL_IDX;
00291 }
00292
00293 if (AT_OBJ_CLASS(gen_idx) == Pgm_Unit) {
00294
00295 if (expr_mode == Initialization_Expr) {
00296 fnd_semantic_err(Obj_Use_Init_Expr,
00297 line,
00298 col,
00299 gen_idx,
00300 TRUE);
00301 ok = FALSE;
00302 goto EXIT;
00303 }
00304
00305 if (expr_mode == Specification_Expr) {
00306
00307 if (fnd_semantic_err(Obj_Use_Spec_Expr,
00308 line,
00309 col,
00310 gen_idx,
00311 TRUE)) {
00312 ok = FALSE;
00313 goto EXIT;
00314 }
00315
00316 if (ATD_IM_A_DOPE(ATP_RSLT_IDX(gen_idx)) ||
00317 ATD_ARRAY_IDX(ATP_RSLT_IDX(gen_idx)) != NULL_IDX) {
00318
00319 PRINTMSG(line, 240, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00320 ok = FALSE;
00321 }
00322 else {
00323
00324
00325
00326
00327 if (!ATP_PURE(gen_idx) ||
00328 (ATP_PROC(gen_idx) == Intern_Proc) ||
00329 ATP_RECURSIVE(gen_idx)) {
00330 PRINTMSG(line, 520, Ansi, col, AT_OBJ_NAME_PTR(gen_idx));
00331 }
00332 }
00333
00334 if (ATP_PROC(gen_idx) == Dummy_Proc && AT_ALT_DARG(gen_idx)) {
00335
00336
00337
00338
00339
00340 list_idx = SCP_TMP_LIST(curr_scp_idx);
00341
00342 while (list_idx != NULL_IDX && gen_idx != AL_ATTR_IDX(list_idx)) {
00343 list_idx = AL_NEXT_IDX(list_idx);
00344 }
00345
00346 if (list_idx == NULL_IDX) {
00347 NTR_ATTR_LIST_TBL(list_idx);
00348 AL_NEXT_IDX(list_idx) = SCP_TMP_LIST(curr_scp_idx);
00349 AL_ATTR_IDX(list_idx) = gen_idx;
00350 SCP_TMP_LIST(curr_scp_idx) = list_idx;
00351 }
00352 }
00353 }
00354
00355 spec_count = 0;
00356 found = TRUE;
00357
00358 if (is_function) {
00359
00360 if (ATP_PGM_UNIT(gen_idx) != Function &&
00361 ATP_PGM_UNIT(gen_idx) != Pgm_Unknown) {
00362
00363 switch (ATP_PGM_UNIT(gen_idx)) {
00364 case Subroutine :
00365 msg_num = 452;
00366 break;
00367 case Program :
00368 msg_num = 453;
00369 break;
00370 case Module :
00371 msg_num = 455;
00372 break;
00373 case Blockdata :
00374 msg_num = 454;
00375 break;
00376 }
00377 PRINTMSG(line, msg_num, Error, col,
00378 AT_OBJ_NAME_PTR(gen_idx));
00379 ok = FALSE;
00380 goto EXIT;
00381 }
00382 else if (ATP_PGM_UNIT(gen_idx) == Pgm_Unknown) {
00383
00384 if (ATP_SCP_IDX(gen_idx) == NULL_IDX &&
00385 ATP_RSLT_IDX(gen_idx) == NULL_IDX) {
00386 PRINTMSG(line, 970, Internal, col);
00387 }
00388
00389 ATP_PGM_UNIT(gen_idx) = Function;
00390
00391 if (ATP_RSLT_IDX(gen_idx) == NULL_IDX) {
00392
00393 CREATE_FUNC_RSLT(gen_idx, new_attr_idx);
00394
00395 AT_REFERENCED(new_attr_idx) = Referenced;
00396
00397 SET_IMPL_TYPE_IN_SCP(new_attr_idx, ATP_SCP_IDX(gen_idx));
00398 }
00399 }
00400 }
00401 else {
00402 if (ATP_PGM_UNIT(gen_idx) != Subroutine &&
00403 ATP_PGM_UNIT(gen_idx) != Pgm_Unknown) {
00404
00405 switch (ATP_PGM_UNIT(gen_idx)) {
00406 case Function :
00407 msg_num = 335;
00408 break;
00409 case Program :
00410 msg_num = 456;
00411 break;
00412 case Module :
00413 msg_num = 458;
00414 break;
00415 case Blockdata :
00416 msg_num = 457;
00417 break;
00418 }
00419 PRINTMSG(line, msg_num, Error, col,
00420 AT_OBJ_NAME_PTR(gen_idx));
00421 ok = FALSE;
00422 goto EXIT;
00423 }
00424 else if (ATP_PGM_UNIT(gen_idx) == Pgm_Unknown) {
00425 ATP_PGM_UNIT(gen_idx) = Subroutine;
00426 }
00427 }
00428 }
00429 else if (AT_OBJ_CLASS(gen_idx) == Interface) {
00430 spec_count = ATI_NUM_SPECIFICS(gen_idx);
00431
00432 if (spec_count == 0) {
00433 goto EXIT;
00434 }
00435
00436 if (is_function) {
00437
00438 if (ATI_INTERFACE_CLASS(gen_idx) != Generic_Unknown_Interface &&
00439 ATI_INTERFACE_CLASS(gen_idx) != Generic_Function_Interface) {
00440
00441 PRINTMSG(line, 398, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00442 ok = FALSE;
00443 found = TRUE;
00444 goto EXIT;
00445 }
00446 }
00447 else {
00448
00449 if (ATI_INTERFACE_CLASS(gen_idx) != Generic_Unknown_Interface &&
00450 ATI_INTERFACE_CLASS(gen_idx) != Generic_Subroutine_Interface) {
00451
00452 PRINTMSG(line, 397, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00453 ok = FALSE;
00454 found = TRUE;
00455 goto EXIT;
00456 }
00457 }
00458 }
00459 else {
00460
00461 spec_count = 0;
00462 found = TRUE;
00463
00464 AT_REFERENCED(gen_idx) = Not_Referenced;
00465
00466 if (fnd_semantic_err((is_function ? Obj_Use_Extern_Func :
00467 Obj_Use_Extern_Subr),
00468 line, col, gen_idx, TRUE)) {
00469 ok = FALSE;
00470 goto EXIT;
00471 }
00472 else if (is_function && AT_OBJ_CLASS(gen_idx) == Pgm_Unit &&
00473 ATP_PROC(gen_idx) != Dummy_Proc &&
00474 ATP_RSLT_IDX(gen_idx) != NULL_IDX &&
00475 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(gen_idx))) == Character &&
00476 TYP_CHAR_CLASS(ATD_TYPE_IDX(ATP_RSLT_IDX(gen_idx))) ==
00477 Assumed_Size_Char) {
00478 PRINTMSG(line, 939, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00479 ok = FALSE;
00480 goto EXIT;
00481 }
00482
00483 AT_REFERENCED(gen_idx) = Referenced;
00484
00485 if (locked_in) {
00486
00487
00488 if (is_function) {
00489 PRINTMSG(line, 511, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00490 }
00491 else {
00492 PRINTMSG(line, 568, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00493 }
00494 ok = FALSE;
00495 goto EXIT;
00496 }
00497
00498 if (AT_USE_ASSOCIATED(gen_idx)) {
00499 PRINTMSG(line, 898, Error, col, AT_OBJ_NAME_PTR(gen_idx));
00500 ok = FALSE;
00501 goto EXIT;
00502 }
00503 else {
00504 PRINTMSG(line, 971, Internal, col);
00505 }
00506 }
00507
00508 if (cdir_switches.no_internal_calls &&
00509 AT_OBJ_CLASS(gen_idx) == Pgm_Unit &&
00510 ATP_PROC(gen_idx) == Intern_Proc) {
00511 PRINTMSG(line, 821, Error, col);
00512 }
00513
00514
00515
00516
00517 list_idx = IR_IDX_R(ir_idx);
00518
00519 save_in_call_list = in_call_list;
00520
00521 reset_expr_mode = FALSE;
00522
00523
00524
00525 if ((strcmp(AT_OBJ_NAME_PTR(gen_idx), "LBOUND") == 0) ||
00526 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "UBOUND") == 0) ||
00527 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "SIZE") == 0) ||
00528 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "SHAPE") == 0) ||
00529 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "KIND") == 0) ||
00530 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "BIT_SIZE") == 0) ||
00531 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "DIGITS") == 0) ||
00532 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "PRECISION") == 0) ||
00533 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "EPSILON") == 0) ||
00534 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "HUGE") == 0) ||
00535 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "MAXEXPONENT") == 0) ||
00536 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "MINEXPONENT") == 0) ||
00537 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "RADIX") == 0) ||
00538 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "RANGE") == 0) ||
00539 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "LEN") == 0) ||
00540 (strcmp(AT_OBJ_NAME_PTR(gen_idx), "TINY") == 0)) {
00541 save_expr_mode = expr_mode;
00542 if (expr_mode == Initialization_Expr ||
00543 expr_mode == Specification_Expr) {
00544 need_pure_function = TRUE;
00545 }
00546 expr_mode = Regular_Expr;
00547 reset_expr_mode = TRUE;
00548 }
00549
00550 for (i = loc_info_idx + 1;
00551 i <= loc_info_idx + IR_LIST_CNT_R(ir_idx);
00552 i++) {
00553
00554 arg_info_list[i] = init_arg_info;
00555
00556 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
00557 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {
00558
00559 PRINTMSG(IR_LINE_NUM(IL_IDX(list_idx)), 197, Error,
00560 IR_COL_NUM(IL_IDX(list_idx)),", or )", ":");
00561 ok = FALSE;
00562 goto EXIT;
00563 }
00564
00565 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
00566 IR_OPR(IL_IDX(list_idx)) == Kwd_Opr) {
00567
00568 if (spec_count == 0 &&
00569 ! ATP_EXPL_ITRFC(gen_idx)) {
00570 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
00571 &opnd_line,
00572 &opnd_column);
00573 PRINTMSG(opnd_line, 333, Error, opnd_column);
00574 ok = FALSE;
00575 }
00576 arg_info_list[i].kwd = IR_IDX_L(IL_IDX(list_idx));
00577 #ifndef SOURCE_TO_SOURCE
00578 COPY_OPND(IL_OPND(list_idx),IR_OPND_R(IL_IDX(list_idx)));
00579 #endif
00580 }
00581 else {
00582 arg_info_list[i].kwd = NULL_IDX;
00583 }
00584
00585
00586 #ifdef SOURCE_TO_SOURCE
00587 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
00588 IR_OPR(IL_IDX(list_idx)) == Kwd_Opr) {
00589 COPY_OPND(opnd, IR_OPND_R(IL_IDX(list_idx)));
00590 }
00591 else {
00592 COPY_OPND(opnd, IL_OPND(list_idx));
00593 }
00594 #else
00595 COPY_OPND(opnd, IL_OPND(list_idx));
00596 #endif
00597
00598
00599 # ifdef COARRAY_FORTRAN
00600 if (cmd_line_flags.co_array_fortran) {
00601 ok &= check_arg_for_co_array(&opnd);
00602 }
00603 # endif
00604
00605 in_call_list = TRUE;
00606 exp_desc.rank = 0;
00607 save_xref_state = xref_state;
00608
00609 label_allowed = TRUE;
00610
00611 if (xref_state != CIF_No_Usage_Rec) {
00612 xref_state = CIF_Symbol_Reference;
00613 }
00614
00615 ok = expr_semantics(&opnd, &exp_desc) && ok;
00616
00617 label_allowed = FALSE;
00618
00619 has_symbolic |= exp_desc.has_symbolic;
00620
00621 find_opnd_line_and_column(&opnd, &opnd_line, &opnd_column);
00622 arg_info_list[i].line = opnd_line;
00623 arg_info_list[i].col = opnd_column;
00624
00625 #ifdef SOURCE_TO_SOURCE
00626 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
00627 IR_OPR(IL_IDX(list_idx)) == Kwd_Opr) {
00628 COPY_OPND(IR_OPND_R(IL_IDX(list_idx)),opnd);
00629 }
00630 else
00631 COPY_OPND(IL_OPND(list_idx), opnd);
00632 #else
00633 COPY_OPND(IL_OPND(list_idx), opnd);
00634 #endif
00635
00636 xref_state = save_xref_state;
00637
00638 arg_info_list[i].ed = exp_desc;
00639 arg_info_list[i].maybe_modified = TRUE;
00640
00641 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00642 IL_ARG_DESC_IDX(list_idx) = i;
00643
00644 if (AT_IS_INTRIN(gen_idx)) {
00645
00646 switch (expr_mode) {
00647 case Regular_Expr:
00648 case Stmt_Func_Expr:
00649 break;
00650
00651 case Initialization_Expr:
00652 if (exp_desc.type != Integer &&
00653 exp_desc.type != Character &&
00654 AT_ELEMENTAL_INTRIN(gen_idx)) {
00655
00656 if (strcmp(AT_OBJ_NAME_PTR(gen_idx), "NINT") == 0 ||
00657 strcmp(AT_OBJ_NAME_PTR(gen_idx), "INT") == 0) {
00658 PRINTMSG(arg_info_list[i].line,
00659 274,
00660 Ansi,
00661 arg_info_list[i].col);
00662 }
00663 # if defined(_USE_FOLD_DOT_f)
00664 else if (strcmp(AT_OBJ_NAME_PTR(gen_idx), "SQRT") == 0) {
00665
00666 }
00667 # endif
00668 else {
00669 PRINTMSG(arg_info_list[i].line,
00670 1456,
00671 Error,
00672 arg_info_list[i].col);
00673 ok = FALSE;
00674 }
00675 }
00676 break;
00677
00678 case Specification_Expr:
00679 default:
00680 if (exp_desc.type != Integer && exp_desc.type != Character) {
00681 PRINTMSG(arg_info_list[i].line, 274, Ansi, arg_info_list[i].col);
00682 }
00683 break;
00684 }
00685 }
00686
00687 if (IL_FLD(list_idx) == AT_Tbl_Idx &&
00688 AT_OBJ_CLASS(IL_IDX(list_idx)) == Pgm_Unit) {
00689
00690
00691
00692 if (ATP_DCL_EXTERNAL(IL_IDX(list_idx)) ||
00693 ATP_IN_INTERFACE_BLK(IL_IDX(list_idx)) ||
00694 AT_IS_INTRIN(IL_IDX(list_idx)) ||
00695 ATP_SCP_ALIVE(IL_IDX(list_idx)) ||
00696 #ifndef SOURCE_TO_SOURCE
00697 ATP_PROC(IL_IDX(list_idx)) == Module_Proc
00698 #else
00699 (ATP_PROC(IL_IDX(list_idx))== Intern_Proc) &&
00700 AT_USE_ASSOCIATED(IL_IDX(list_idx))
00701 #endif
00702 ) {
00703 arg_info_list[i].pgm_unit = TRUE;
00704
00705 if (ATP_PGM_UNIT(IL_IDX(list_idx)) == Pgm_Unknown) {
00706 type_idx = IM_TYPE_IDX(ATP_SCP_IDX(IL_IDX(list_idx)),
00707 IMPL_IDX(AT_OBJ_NAME(IL_IDX(list_idx))));
00708
00709
00710
00711 arg_info_list[i].ed.type = TYP_TYPE(type_idx);
00712 arg_info_list[i].ed.type_idx = type_idx;
00713 arg_info_list[i].ed.linear_type = TYP_LINEAR(type_idx);
00714 arg_info_list[i].ed.rank = 0;
00715 }
00716 }
00717 else {
00718
00719
00720
00721
00722 PRINTMSG(IL_LINE_NUM(list_idx), 379, Error,
00723 IL_COL_NUM(list_idx),
00724 AT_OBJ_NAME_PTR(IL_IDX(list_idx)));
00725 ok = FALSE;
00726 goto EXIT;
00727 }
00728 }
00729 else {
00730 arg_info_list[i].pgm_unit = FALSE;
00731 }
00732
00733 if (exp_desc.label) {
00734
00735 label_cnt++;
00736
00737 if (label_list_head == NULL_IDX) {
00738 NTR_IR_LIST_TBL(label_list_head);
00739 label_list_tail = label_list_head;
00740 }
00741 else {
00742 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(label_list_tail));
00743 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(label_list_tail)) =
00744 label_list_tail;
00745 label_list_tail = IL_NEXT_LIST_IDX(label_list_tail);
00746 }
00747
00748 COPY_OPND(IL_OPND(label_list_tail), IL_OPND(list_idx));
00749
00750 if (spec_count == 0 &&
00751 ! ATP_EXPL_ITRFC(gen_idx)) {
00752
00753 ATP_HAS_ALT_RETURN(gen_idx) = TRUE;
00754 }
00755 }
00756
00757 list_idx = IL_NEXT_LIST_IDX(list_idx);
00758 }
00759
00760 need_pure_function = FALSE;
00761
00762 if (reset_expr_mode) {
00763 expr_mode = save_expr_mode;
00764 }
00765
00766
00767
00768
00769
00770 if (! AT_IS_INTRIN(gen_idx)) {
00771 io_item_must_flatten = save_io_item_must_flatten;
00772 }
00773
00774 in_call_list = save_in_call_list;
00775
00776 if (!ok) {
00777 goto EXIT;
00778 }
00779
00780
00781 if (spec_count > 0 || ATP_EXPL_ITRFC(gen_idx)) {
00782
00783 do {
00784
00785 if (spec_count > 0) {
00786
00787 if (spec_sn_idx == NULL_IDX) {
00788 spec_sn_idx = ATI_FIRST_SPECIFIC_IDX(gen_idx);
00789 }
00790 else {
00791 spec_sn_idx = SN_SIBLING_LINK(spec_sn_idx);
00792 }
00793 spec_idx = SN_ATTR_IDX(spec_sn_idx);
00794 }
00795 else {
00796 spec_idx = gen_idx;
00797 }
00798
00799 num_args = ATP_NUM_DARGS(spec_idx);
00800
00801 if (ATP_EXTRA_DARG(spec_idx)) {
00802 num_args--;
00803 }
00804
00805 # ifdef _DEBUG
00806 if (num_args >= arg_list_size) {
00807 PRINTMSG(1,245,Internal,0);
00808 }
00809
00810 # endif
00811 for (arg_idx = 0; arg_idx <= num_args + 1; arg_idx++) {
00812 arg_list[arg_idx] = 0;
00813 }
00814
00815 list_idx = IR_IDX_R(ir_idx);
00816
00817 info_idx = loc_info_idx;
00818
00819 for (list_cnt = 1; list_cnt <= IR_LIST_CNT_R(ir_idx); list_cnt++) {
00820 info_idx++;
00821 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
00822 &opnd_line,
00823 &opnd_column);
00824
00825 if (arg_info_list[info_idx].kwd != NULL_IDX) {
00826 length = (long_type) CN_INT_TO_C(
00827 TYP_IDX(CN_TYPE_IDX(arg_info_list[info_idx].kwd)));
00828 arg_attr = srch_kwd_name(
00829 (char *)&CN_CONST(arg_info_list[info_idx].kwd),
00830 length,
00831 spec_idx,
00832 &sn_idx);
00833
00834 if (arg_attr) {
00835
00836 if (ATP_EXTRA_DARG(spec_idx)) {
00837 arg_idx = sn_idx - ATP_FIRST_IDX(spec_idx);
00838 }
00839 else {
00840 arg_idx = sn_idx - ATP_FIRST_IDX(spec_idx) + 1;
00841 }
00842
00843 if (arg_list[arg_idx]) {
00844
00845 if (spec_count == 0) {
00846
00847
00848
00849 PRINTMSG(opnd_line, 330, Error, opnd_column);
00850 ok = FALSE;
00851 list_idx = IL_NEXT_LIST_IDX(list_idx);
00852 continue;
00853 }
00854 else {
00855 goto CYCLE;
00856 }
00857 }
00858 }
00859 else {
00860
00861 if (spec_count == 0) {
00862
00863
00864
00865 PRINTMSG(opnd_line, 277, Error, opnd_column,
00866 (char *)&CN_CONST(arg_info_list[info_idx].kwd),
00867 AT_OBJ_NAME_PTR(spec_idx));
00868 ok = FALSE;
00869 list_idx = IL_NEXT_LIST_IDX(list_idx);
00870 continue;
00871 }
00872 else {
00873 goto CYCLE;
00874 }
00875 }
00876 }
00877 else {
00878
00879 if (ATP_EXTRA_DARG(spec_idx)) {
00880 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + list_cnt);
00881 }
00882 else {
00883 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + list_cnt-1);
00884 }
00885 arg_idx = list_cnt;
00886
00887
00888 if (arg_list[arg_idx]) {
00889
00890 if (spec_count == 0) {
00891
00892
00893
00894 PRINTMSG(opnd_line, 330, Error, opnd_column);
00895 ok = FALSE;
00896 list_idx = IL_NEXT_LIST_IDX(list_idx);
00897 continue;
00898 }
00899 else {
00900 goto CYCLE;
00901 }
00902 }
00903 else if (arg_idx > num_args) {
00904
00905 if (ATP_PROC(spec_idx) == Intrin_Proc) {
00906
00907 if ((ATP_INTRIN_ENUM(spec_idx) == Ranf_Intrinsic) ||
00908 (ATP_INTRIN_ENUM(spec_idx) == Date_Intrinsic) ||
00909 (ATP_INTRIN_ENUM(spec_idx) == Jdate_Intrinsic) ||
00910 (ATP_INTRIN_ENUM(spec_idx) == Rtc_Intrinsic) ||
00911 (ATP_INTRIN_ENUM(spec_idx) == Irtc_Intrinsic) ||
00912 (ATP_INTRIN_ENUM(spec_idx) == Clock_Intrinsic) ||
00913 (ATP_INTRIN_ENUM(spec_idx) == Numarg_Intrinsic)) {
00914 PRINTMSG(opnd_line, 739, Warning, opnd_column,
00915 AT_OBJ_NAME_PTR(gen_idx));
00916 break;
00917 }
00918 }
00919
00920 if (spec_count == 0) {
00921 PRINTMSG(opnd_line, 331, Error, opnd_column,
00922 list_cnt);
00923 ok = FALSE;
00924 list_idx = IL_NEXT_LIST_IDX(list_idx);
00925 continue;
00926 }
00927 else {
00928 goto CYCLE;
00929 }
00930 }
00931 }
00932
00933
00934
00935
00936
00937 arg_list[arg_idx] = list_idx;
00938
00939
00940
00941 if (AT_COMPILER_GEND(arg_attr) && AT_IS_DARG(arg_attr)) {
00942
00943
00944
00945 ATP_HAS_ALT_RETURN(spec_idx) = TRUE;
00946
00947 if (IL_FLD(list_idx) != AT_Tbl_Idx ||
00948 AT_OBJ_CLASS(IL_IDX(list_idx)) != Label) {
00949
00950 if (spec_count == 0) {
00951 PRINTMSG(opnd_line, 338, Error, opnd_column);
00952 ok = FALSE;
00953 }
00954 else {
00955 goto CYCLE;
00956 }
00957 }
00958
00959 list_idx = IL_NEXT_LIST_IDX(list_idx);
00960 continue;
00961 }
00962 else if (IL_FLD(list_idx) == AT_Tbl_Idx &&
00963 AT_OBJ_CLASS(IL_IDX(list_idx)) == Label) {
00964
00965 if (spec_count == 0) {
00966 PRINTMSG(opnd_line, 504, Error, opnd_column,
00967 AT_OBJ_NAME_PTR(IL_IDX(list_idx)),
00968 AT_OBJ_NAME_PTR(arg_attr));
00969 ok = FALSE;
00970 }
00971 else {
00972 goto CYCLE;
00973 }
00974 list_idx = IL_NEXT_LIST_IDX(list_idx);
00975 continue;
00976 }
00977
00978
00979
00980 if (!compare_darg_to_actual_arg(gen_idx,
00981 spec_idx,
00982 arg_attr,
00983 IL_OPND(list_idx),
00984 info_idx,
00985 spec_count) ) {
00986
00987 if (spec_count == 0) {
00988 ok = FALSE;
00989 }
00990 else {
00991 goto CYCLE;
00992 }
00993 }
00994 list_idx = IL_NEXT_LIST_IDX(list_idx);
00995 }
00996
00997 for (arg_idx = 1; arg_idx <= num_args; arg_idx++) {
00998
00999 if (arg_list[arg_idx] == NULL_IDX) {
01000
01001
01002
01003 if (ATP_EXTRA_DARG(spec_idx)) {
01004 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + arg_idx);
01005 }
01006 else {
01007 arg_attr = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + arg_idx - 1);
01008 }
01009
01010 if (!AT_OPTIONAL(arg_attr)) {
01011
01012 if (spec_count == 0) {
01013
01014
01015
01016 if (AT_COMPILER_GEND(arg_attr)) {
01017 PRINTMSG(line, 209, Error, col, arg_idx);
01018 }
01019 else {
01020 PRINTMSG(line, 332, Error, col,
01021 AT_OBJ_NAME_PTR(arg_attr));
01022 }
01023 ok = FALSE;
01024 goto EXIT;
01025 }
01026 else {
01027 goto CYCLE;
01028 }
01029 }
01030 }
01031 }
01032
01033
01034
01035
01036 for (arg_idx = 1; arg_idx <= num_args; arg_idx++) {
01037
01038 if (arg_list[arg_idx] == NULL_IDX) {
01039 NTR_IR_LIST_TBL(list_idx);
01040 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
01041 arg_list[arg_idx] = list_idx;
01042 }
01043
01044 if (arg_idx > 1){
01045 IL_NEXT_LIST_IDX(arg_list[arg_idx - 1]) = arg_list[arg_idx];
01046 }
01047 }
01048
01049 IL_NEXT_LIST_IDX(arg_list[num_args]) = NULL_IDX;
01050
01051 IR_LIST_CNT_R(ir_idx) = num_args;
01052 IR_IDX_R(ir_idx) = arg_list[1];
01053
01054
01055
01056 IR_IDX_L(ir_idx) = spec_idx;
01057
01058 found = TRUE;
01059 goto EXIT;
01060
01061 CYCLE:
01062
01063 spec_count--;
01064 }
01065 while (spec_count > 0);
01066
01067 }
01068 else {
01069
01070 spec_idx = gen_idx;
01071 }
01072
01073 EXIT:
01074
01075 if (found) {
01076
01077 if (ok) {
01078
01079
01080
01081
01082
01083 if ((cif_flags & MISC_RECS) != 0 && xref_state != CIF_No_Usage_Rec) {
01084 cif_call_site_rec(ir_idx, gen_idx);
01085 }
01086
01087 if (AT_OBJ_CLASS(spec_idx) == Pgm_Unit &&
01088 ATP_SCP_ALIVE(spec_idx)) {
01089
01090 if (ATP_PGM_UNIT(spec_idx) == Function &&
01091 !ATP_RSLT_NAME(spec_idx)) {
01092 PRINTMSG(line, 344, Ansi, col);
01093 }
01094 if (!ATP_RECURSIVE(spec_idx) && !AT_DCL_ERR(spec_idx) &&
01095 !on_off_flags.recursive) {
01096 PRINTMSG(line, 343, Error, col);
01097 ok = FALSE;
01098 }
01099 }
01100
01101 if (AT_NOT_VISIBLE(gen_idx)) {
01102 PRINTMSG(line, 486, Error, col,
01103 AT_OBJ_NAME_PTR(gen_idx),
01104 AT_OBJ_NAME_PTR(AT_MODULE_IDX((gen_idx))));
01105 ok = FALSE;
01106 goto DONE;
01107 }
01108 else if (AT_NOT_VISIBLE(spec_idx)) {
01109 PRINTMSG(line, 486, Error, col,
01110 AT_OBJ_NAME_PTR(spec_idx),
01111 AT_OBJ_NAME_PTR(AT_MODULE_IDX((spec_idx))));
01112 ok = FALSE;
01113 goto DONE;
01114 }
01115
01116 if (AT_DCL_ERR(spec_idx)) {
01117
01118
01119 ok = FALSE;
01120 goto DONE;
01121 }
01122
01123 if (ok && found && ATP_PURE(spec_idx) &&
01124 ATP_PROC(spec_idx) != Intrin_Proc) {
01125
01126
01127
01128 list_idx = IR_IDX_R(ir_idx);
01129
01130 if (ATP_EXTRA_DARG(spec_idx)) {
01131 arg_idx = ATP_FIRST_IDX(spec_idx) + 1;
01132 num_args = ATP_NUM_DARGS(spec_idx) - 1;
01133 }
01134 else {
01135 arg_idx = ATP_FIRST_IDX(spec_idx);
01136 num_args = ATP_NUM_DARGS(spec_idx);
01137 }
01138
01139 for (;num_args > 0; num_args--) {
01140
01141 if (OPND_FLD(IL_OPND(list_idx)) == AT_Tbl_Idx &&
01142 AT_OBJ_CLASS(OPND_IDX(IL_OPND(list_idx))) == Pgm_Unit &&
01143 !ATP_PURE(OPND_IDX(IL_OPND(list_idx))) == Pgm_Unit) {
01144 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx)].line,
01145 1642, Error,
01146 arg_info_list[IL_ARG_DESC_IDX(list_idx)].col,
01147 AT_OBJ_NAME_PTR(SN_ATTR_IDX(arg_idx)),
01148 AT_OBJ_NAME_PTR(OPND_IDX(IL_OPND(list_idx))));
01149 break;
01150 }
01151 arg_idx++;
01152 list_idx = IL_NEXT_LIST_IDX(list_idx);
01153 }
01154 }
01155
01156
01157 if (ATP_PROC(spec_idx) == Intrin_Proc) {
01158
01159 if (ATP_INTRIN_ENUM(spec_idx) != Unknown_Intrinsic) {
01160 #ifdef SOURCE_TO_SOURCE
01161 int tmp_cnt;
01162 int tmp_list_idx;
01163 opnd_type tmp_result_opnd = null_opnd ;
01164
01165 copy_subtree(result_opnd, &tmp_result_opnd);
01166
01167 tmp_list_idx = IR_IDX_R(OPND_IDX(tmp_result_opnd));
01168
01169 while (tmp_list_idx != NULL_IDX)
01170 {
01171 if (IL_FLD(tmp_list_idx) == IR_Tbl_Idx &&
01172 IR_OPR(IL_IDX(tmp_list_idx)) == Kwd_Opr) {
01173 COPY_OPND(IL_OPND(tmp_list_idx),IR_OPND_R(IL_IDX(tmp_list_idx)));
01174 }
01175 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx);
01176 }
01177 #endif
01178
01179 ATP_INTERFACE_IDX(spec_idx) = gen_idx;
01180
01181 #ifdef SOURCE_TO_SOURCE
01182 (*(void (*)())intrinsic_semantics[ATP_INTRIN_ENUM(spec_idx)])
01183 (&tmp_result_opnd,
01184 res_exp_desc,
01185 &spec_idx);
01186
01187 if (OPND_FLD(tmp_result_opnd) == CN_Tbl_Idx ||
01188 (ATP_INTRIN_ENUM(spec_idx)==Min0_Intrinsic) ||
01189 (ATP_INTRIN_ENUM(spec_idx)==Max0_Intrinsic) ||
01190 (ATP_INTRIN_ENUM(spec_idx)==Max_Intrinsic) ||
01191 (ATP_INTRIN_ENUM(spec_idx)==Max1_Intrinsic) ||
01192 (ATP_INTRIN_ENUM(spec_idx)==Min_Intrinsic) ||
01193 (ATP_INTRIN_ENUM(spec_idx)==Amax0_Intrinsic) ||
01194 (ATP_INTRIN_ENUM(spec_idx)==Amax1_Intrinsic) ||
01195 (ATP_INTRIN_ENUM(spec_idx)==Dmax1_Intrinsic) ||
01196 (ATP_INTRIN_ENUM(spec_idx)==Cmplx_Intrinsic) )
01197 {
01198
01199
01200 copy_subtree(&tmp_result_opnd, result_opnd);
01201 }
01202 #else
01203 (*(void (*)())intrinsic_semantics[ATP_INTRIN_ENUM(spec_idx)])
01204 (result_opnd,
01205 res_exp_desc,
01206 &spec_idx);
01207 #endif
01208
01209 if ((ATP_INTRIN_ENUM(spec_idx)!=Kind_Intrinsic) &&
01210 # if 0
01211 (ATP_INTRIN_ENUM(spec_idx)!=Min0_Intrinsic) &&
01212 (ATP_INTRIN_ENUM(spec_idx)!=Max0_Intrinsic) &&
01213 (ATP_INTRIN_ENUM(spec_idx)!=Max_Intrinsic) &&
01214 (ATP_INTRIN_ENUM(spec_idx)!=Max1_Intrinsic) &&
01215 (ATP_INTRIN_ENUM(spec_idx)!=Min_Intrinsic) &&
01216 (ATP_INTRIN_ENUM(spec_idx)!=Amax0_Intrinsic) &&
01217 (ATP_INTRIN_ENUM(spec_idx)!=Amax1_Intrinsic) &&
01218 (ATP_INTRIN_ENUM(spec_idx)!=Dmax1_Intrinsic) &&
01219 # endif
01220 (ATP_INTRIN_ENUM(spec_idx)!=Dble_Intrinsic) &&
01221 (ATP_INTRIN_ENUM(spec_idx)!=SIK_Intrinsic) &&
01222 (ATP_INTRIN_ENUM(spec_idx)!=SRK_Intrinsic)){
01223
01224 ATP_ELEMENTAL(spec_idx) = FALSE;
01225
01226 goto HERE;
01227 }
01228
01229 if (ATP_EXTERNAL_INTRIN(spec_idx)) {
01230 goto CONTINUE;
01231 }
01232 else {
01233
01234 if (res_exp_desc->rank &&
01235 OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
01236 IR_OPR(OPND_IDX((*result_opnd))) != Subscript_Opr &&
01237 IR_OPR(OPND_IDX((*result_opnd))) != Whole_Subscript_Opr&&
01238 IR_OPR(OPND_IDX((*result_opnd)))!=Section_Subscript_Opr&&
01239 IR_OPR(OPND_IDX((*result_opnd))) != Substring_Opr &&
01240 IR_OPR(OPND_IDX((*result_opnd))) != Whole_Substring_Opr&&
01241 IR_OPR(OPND_IDX((*result_opnd))) != Struct_Opr) {
01242 IR_ARRAY_SYNTAX(OPND_IDX((*result_opnd))) = TRUE;
01243 io_item_must_flatten = TRUE;
01244 }
01245 else if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx) {
01246 IR_ARRAY_SYNTAX(OPND_IDX((*result_opnd))) = FALSE;
01247 }
01248
01249
01250
01251
01252
01253
01254
01255
01256
01257
01258
01259
01260
01261
01262
01263
01264
01265
01266
01267
01268
01269
01270
01271
01272
01273 if (is_function &&
01274 (cif_flags & MISC_RECS) != 0 &&
01275 xref_state != CIF_No_Usage_Rec &&
01276 ! ATI_USER_SPECIFIED(gen_idx)) {
01277 cif_object_rec_for_func_result(spec_idx);
01278 ATI_CIF_SEEN_IN_CALL(gen_idx) = TRUE;
01279 }
01280
01281 goto DONE;
01282 }
01283 }
01284 else {
01285
01286 CONTINUE:
01287
01288
01289
01290
01291
01292
01293 if (is_function &&
01294 ! ATI_USER_SPECIFIED(gen_idx) &&
01295 (cif_flags & MISC_RECS) != 0 &&
01296 xref_state != CIF_No_Usage_Rec) {
01297 cif_object_rec_for_func_result(spec_idx);
01298 }
01299
01300
01301
01302 NTR_ATTR_TBL(new_attr_idx);
01303 COPY_ATTR_NTRY(new_attr_idx, spec_idx);
01304 AT_CIF_SYMBOL_ID(new_attr_idx) = 0;
01305 ADD_ATTR_TO_LOCAL_LIST(new_attr_idx);
01306 AT_REFERENCED(new_attr_idx) = Referenced;
01307 AT_DEF_IN_CHILD(new_attr_idx) = FALSE;
01308 AT_REF_IN_CHILD(new_attr_idx) = FALSE;
01309 AT_HOST_ASSOCIATED(new_attr_idx) = FALSE;
01310 ATP_INTERFACE_IDX(new_attr_idx) = gen_idx;
01311 spec_idx = new_attr_idx;
01312
01313 if (ATP_PGM_UNIT(spec_idx) == Function) {
01314
01315
01316
01317
01318 NTR_ATTR_TBL(new_attr_idx);
01319 COPY_ATTR_NTRY(new_attr_idx, ATP_RSLT_IDX(spec_idx));
01320 AT_CIF_SYMBOL_ID(new_attr_idx) = 0;
01321 AT_REFERENCED(new_attr_idx) = Referenced;
01322 AT_COMPILER_GEND(new_attr_idx) = TRUE;
01323 AT_DEF_IN_CHILD(new_attr_idx) = FALSE;
01324 AT_REF_IN_CHILD(new_attr_idx) = FALSE;
01325 AT_HOST_ASSOCIATED(new_attr_idx) = FALSE;
01326 ATD_STOR_BLK_IDX(new_attr_idx) = SCP_SB_STACK_IDX(
01327 curr_scp_idx);
01328 ATP_RSLT_IDX(spec_idx) = new_attr_idx;
01329 ATD_FUNC_IDX(new_attr_idx) = spec_idx;
01330 }
01331
01332 IR_IDX_L(ir_idx) = spec_idx;
01333 rslt_idx = ATP_RSLT_IDX(spec_idx);
01334
01335 if (rslt_idx != NULL_IDX &&
01336 FUNCTION_MUST_BE_SUBROUTINE(rslt_idx) &&
01337 FALSE) {
01338
01339 ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_DARG_IDX(curr_scp_idx);
01340
01341
01342
01343 if (!ATP_EXTRA_DARG(spec_idx)) {
01344 ATP_EXTRA_DARG(spec_idx) = TRUE;
01345
01346 sn_idx = ATP_FIRST_IDX(spec_idx);
01347
01348 NTR_SN_TBL(new_sn_idx);
01349 ATP_FIRST_IDX(spec_idx) = new_sn_idx;
01350 SN_NAME_LEN(new_sn_idx) = AT_NAME_LEN(rslt_idx);
01351 SN_NAME_IDX(new_sn_idx) = AT_NAME_IDX(rslt_idx);
01352 SN_ATTR_IDX(new_sn_idx) = rslt_idx;
01353
01354 for (i = 0; i < ATP_NUM_DARGS(spec_idx); i++) {
01355 NTR_SN_TBL(new_sn_idx);
01356 COPY_TBL_NTRY(sec_name_tbl, new_sn_idx, sn_idx);
01357 sn_idx++;
01358 }
01359
01360 ATP_NUM_DARGS(spec_idx) += 1;
01361 }
01362 }
01363 }
01364 }
01365 else if (spec_idx != gen_idx)
01366 if (spec_idx != gen_idx) {
01367
01368 if (ATP_SCP_IDX(spec_idx) != curr_scp_idx ||
01369 AT_NOT_VISIBLE(spec_idx)) {
01370
01371
01372
01373
01374
01375 new_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(spec_idx),
01376 AT_NAME_LEN(spec_idx),
01377 &name_idx);
01378
01379 if (new_attr_idx != spec_idx) {
01380
01381
01382
01383
01384
01385 ADD_ATTR_TO_LOCAL_LIST(spec_idx);
01386
01387 }
01388 }
01389
01390 if (host_associated) {
01391 host_associated_attr_semantics(spec_idx, FALSE);
01392 }
01393 AT_REFERENCED(spec_idx) = Referenced;
01394 }
01395
01396 HERE:
01397
01398 if (save_where_ir_idx != NULL_IDX && ATP_VFUNCTION(spec_idx)) {
01399 PRINTMSG(line, 897, Error, col,
01400 AT_OBJ_NAME_PTR(spec_idx));
01401 ok = FALSE;
01402 goto DONE;
01403 }
01404
01405 SCP_HAS_CALLS(curr_scp_idx) = TRUE;
01406
01407 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01408 num_args = IR_LIST_CNT_R(ir_idx);
01409
01410 if (is_function) {
01411 rslt_idx = ATP_RSLT_IDX(spec_idx);
01412 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(rslt_idx);
01413
01414 save_shape_known = res_exp_desc->shape_known;
01415
01416 if (save_shape_known) {
01417 save_rank = res_exp_desc->rank;
01418
01419 COPY_SHAPE(save_shape, (res_exp_desc->shape), save_rank);
01420 }
01421
01422 if (! AT_ELEMENTAL_INTRIN(spec_idx)||TRUE) {
01423 save_foldable = res_exp_desc->foldable;
01424 save_will_fold_later = res_exp_desc->will_fold_later;
01425 COPY_OPND(save_char_len, (res_exp_desc->char_len));
01426
01427 (*res_exp_desc) = init_exp_desc;
01428
01429 res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx);
01430 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx);
01431 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
01432 #if 0
01433 res_exp_desc->pointer = ATD_POINTER(rslt_idx);
01434 res_exp_desc->target = ATD_TARGET(rslt_idx);
01435 res_exp_desc->allocatable = ATD_ALLOCATABLE(rslt_idx);
01436 res_exp_desc->dope_vector = ATD_IM_A_DOPE(rslt_idx);
01437 res_exp_desc->dope_vector = FALSE;
01438
01439 res_exp_desc->will_fold_later = save_will_fold_later;
01440 res_exp_desc->foldable = save_foldable;
01441 res_exp_desc->dope_vector = FALSE;
01442 #endif
01443 res_exp_desc->will_fold_later = FALSE;
01444 res_exp_desc->foldable = save_foldable;
01445
01446 if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX) {
01447 res_exp_desc->assumed_shape =
01448 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Shape);
01449 res_exp_desc->assumed_size =
01450 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Size);
01451
01452 IR_RANK(ir_idx) = BD_RANK(ATD_ARRAY_IDX(rslt_idx));
01453 res_exp_desc->rank = IR_RANK(ir_idx);
01454 res_exp_desc->contig_array = TRUE;
01455 }
01456 else {
01457
01458 }
01459 }
01460
01461 res_exp_desc->tmp_reference = TRUE;
01462
01463 if (! no_func_expansion) {
01464
01465 if (AT_IS_INTRIN(spec_idx) &&
01466 res_exp_desc->will_fold_later&&
01467 FALSE) {
01468
01469 copy_subtree(result_opnd, &save_result_opnd);
01470
01471 list_idx = IR_IDX_R(ir_idx);
01472
01473 while (list_idx) {
01474 arg_info_list_base = arg_info_list_top;
01475 arg_info_list_top = arg_info_list_base + 1;
01476
01477 if (arg_info_list_top >= arg_info_list_size) {
01478 enlarge_info_list_table();
01479 }
01480
01481 arg_info_list[arg_info_list_top] =
01482 arg_info_list[IL_ARG_DESC_IDX(list_idx)];
01483
01484 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top;
01485
01486 list_idx = IL_NEXT_LIST_IDX(list_idx);
01487 }
01488 }
01489
01490 if (ATP_PROC(spec_idx) != Intrin_Proc)
01491 flatten_function_call(result_opnd);
01492
01493
01494
01495 if (ATP_ELEMENTAL(spec_idx) &&
01496 ATP_PROC(spec_idx) != Intrin_Proc) {
01497
01498 attr_idx = find_base_attr(result_opnd, &line, &col);
01499 res_exp_desc->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx));
01500 }
01501
01502
01503
01504
01505
01506
01507 if (ATP_PROC(spec_idx) == Intrin_Proc &&
01508 ! ATI_USER_SPECIFIED(gen_idx) &&
01509 (cif_flags & MISC_RECS) != 0 &&
01510 FALSE &&
01511 xref_state != CIF_No_Usage_Rec) {
01512 cif_object_rec_for_func_result(spec_idx);
01513 }
01514
01515 if (res_exp_desc->type == Character || res_exp_desc->rank) {
01516
01517 attr_idx = find_base_attr(result_opnd, &line, &col);
01518
01519 if (res_exp_desc->type == Character) {
01520 # if 0
01521 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
01522 res_exp_desc->type_idx = ATD_TYPE_IDX(attr_idx);
01523 # endif
01524 res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx) ;
01525
01526 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx);
01527 res_exp_desc->linear_type =
01528 TYP_LINEAR(res_exp_desc->type_idx);
01529
01530 if (ATP_PROC(spec_idx) == Intrin_Proc && FALSE) {
01531 COPY_OPND(res_exp_desc->char_len, save_char_len);
01532 }
01533 else {
01534 get_char_len(result_opnd, &(res_exp_desc->char_len));
01535 }
01536 }
01537
01538 if (res_exp_desc->rank) {
01539 get_shape_from_attr(res_exp_desc,
01540 attr_idx,
01541 res_exp_desc->rank,
01542 line,
01543 col);
01544 }
01545 }
01546 }
01547 else if (!AT_ELEMENTAL_INTRIN(spec_idx)||TRUE) {
01548 set_shape_for_deferred_funcs(res_exp_desc, ir_idx);
01549
01550 if (AT_IS_INTRIN(spec_idx) &&
01551 FALSE &&
01552 (ATP_INTRIN_ENUM(spec_idx) == Transfer_Intrinsic ||
01553 ATP_INTRIN_ENUM(spec_idx) == Trim_Intrinsic)) {
01554 COPY_OPND((res_exp_desc->char_len), save_char_len);
01555 }
01556 }
01557
01558 if (save_shape_known) {
01559 res_exp_desc->shape_known = save_shape_known;
01560 res_exp_desc->rank = save_rank;
01561 COPY_SHAPE((res_exp_desc->shape), save_shape, save_rank);
01562 }
01563 }
01564 else if (label_cnt != 0 || ATP_HAS_ALT_RETURN(spec_idx)) {
01565
01566 NTR_IR_TBL(br_idx_idx);
01567 IR_OPR(br_idx_idx) = Br_Index_Opr;
01568 IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE;
01569
01570 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE);
01571 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE;
01572 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx);
01573 AT_REFERENCED(alt_return_tmp) = Referenced;
01574 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE;
01575 AT_DEFINED(alt_return_tmp) = TRUE;
01576
01577 NTR_IR_TBL(asg_idx);
01578 IR_OPR(asg_idx) = Alt_Return_Opr;
01579 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
01580 IR_LINE_NUM(asg_idx) = line;
01581 IR_COL_NUM(asg_idx) = col;
01582 IR_LINE_NUM_L(asg_idx) = line;
01583 IR_COL_NUM_L(asg_idx) = col;
01584 IR_FLD_L(asg_idx) = AT_Tbl_Idx;
01585 IR_IDX_L(asg_idx) = alt_return_tmp;
01586
01587 COPY_OPND(IR_OPND_R(asg_idx), (*result_opnd));
01588
01589 if (label_cnt != 0) {
01590 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
01591
01592 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
01593 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
01594 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
01595
01596 IR_FLD_L(br_idx_idx) = AT_Tbl_Idx;
01597 IR_IDX_L(br_idx_idx) = alt_return_tmp;
01598 IR_LINE_NUM(br_idx_idx) = line;
01599 IR_COL_NUM(br_idx_idx) = col;
01600 IR_LINE_NUM_L(br_idx_idx) = line;
01601 IR_COL_NUM_L(br_idx_idx) = col;
01602 IR_FLD_R(br_idx_idx) = IL_Tbl_Idx;
01603 IR_IDX_R(br_idx_idx) = label_list_head;
01604 IR_LIST_CNT_R(br_idx_idx) = label_cnt;
01605
01606 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01607 OPND_IDX((*result_opnd)) = br_idx_idx;
01608
01609 list_idx2 = label_list_head;
01610 while (list_idx2) {
01611 AT_REFERENCED( IL_IDX(list_idx2)) = Referenced;
01612 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
01613 }
01614 }
01615 else {
01616 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01617 OPND_IDX((*result_opnd)) = asg_idx;
01618 }
01619 }
01620
01621 if (! no_func_expansion) {
01622
01623 if (! is_function) {
01624
01625 COPY_OPND(opnd, IR_OPND_R(ir_idx));
01626 ok = final_arg_work(&opnd, spec_idx, num_args, NULL) && ok;
01627 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01628 }
01629
01630 if (ATP_PROC(spec_idx) != Dummy_Proc &&
01631
01632 ! ATP_VFUNCTION(spec_idx) &&
01633 (cmd_line_flags.runtime_argument ||
01634 cmd_line_flags.runtime_arg_call)) {
01635
01636 # if defined(GENERATE_WHIRL)
01637 list_idx = IR_IDX_R(ir_idx);
01638 list_idx2 = NULL_IDX;
01639
01640 idx = 0;
01641
01642 while (list_idx) {
01643 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
01644 IR_OPR(IL_IDX(list_idx)) == False_Parm_Opr) {
01645
01646 false_list_idx = list_idx;
01647
01648 IL_NEXT_LIST_IDX(list_idx2) = NULL_IDX;
01649 break;
01650 }
01651
01652 list_idx2 = list_idx;
01653 list_idx = IL_NEXT_LIST_IDX(list_idx);
01654 idx++;
01655 }
01656
01657 IR_LIST_CNT_R(ir_idx) = idx;
01658 # endif
01659 ATP_ARGCHCK_CALL(spec_idx) = TRUE;
01660
01661 NTR_IR_TBL(loc_idx);
01662 IR_OPR(loc_idx) = Aloc_Opr;
01663 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
01664 IR_LINE_NUM(loc_idx) = line;
01665 IR_COL_NUM(loc_idx) = col;
01666 IR_FLD_L(loc_idx) = AT_Tbl_Idx;
01667
01668 OPND_FLD(opnd) = IR_Tbl_Idx;
01669 OPND_IDX(opnd) = ir_idx;
01670 idx = create_argchck_descriptor(&opnd);
01671 IR_IDX_L(loc_idx) = idx;
01672 IR_LINE_NUM_L(loc_idx) = line;
01673 IR_COL_NUM_L(loc_idx) = col;
01674
01675 NTR_IR_LIST_TBL(list_idx2);
01676 IL_ARG_DESC_VARIANT(list_idx2) = TRUE;
01677 IL_FLD(list_idx2) = IR_Tbl_Idx;
01678 IL_IDX(list_idx2) = loc_idx;
01679
01680 if (IR_LIST_CNT_R(ir_idx) == 0) {
01681 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
01682 IR_IDX_R(ir_idx) = list_idx2;
01683 IR_LIST_CNT_R(ir_idx) = 1;
01684 }
01685 else {
01686 list_idx = IR_IDX_R(ir_idx);
01687 while (IL_NEXT_LIST_IDX(list_idx)) {
01688 list_idx = IL_NEXT_LIST_IDX(list_idx);
01689 }
01690
01691 IL_NEXT_LIST_IDX(list_idx) = list_idx2;
01692 (IR_LIST_CNT_R(ir_idx))++;
01693 }
01694
01695 # if defined(GENERATE_WHIRL)
01696 if (false_list_idx) {
01697 IL_NEXT_LIST_IDX(list_idx2) = false_list_idx;
01698 list_idx = false_list_idx;
01699 while (list_idx) {
01700 (IR_LIST_CNT_R(ir_idx))++;
01701 list_idx = IL_NEXT_LIST_IDX(list_idx);
01702 }
01703 }
01704 # endif
01705 }
01706 }
01707
01708 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01709
01710 if (AT_OBJ_CLASS(gen_idx) == Interface &&
01711 ATP_PROC(spec_idx) != Intrin_Proc) {
01712
01713 PRINTMSG(line, 399, Comment, col, AT_OBJ_NAME_PTR(gen_idx),
01714 AT_OBJ_NAME_PTR(spec_idx));
01715 }
01716 }
01717 }
01718 else if (ok) {
01719
01720 if (AT_IS_INTRIN(gen_idx)) {
01721 PRINTMSG(line,
01722 700,
01723 Error,
01724 col,
01725 AT_OBJ_NAME_PTR(gen_idx));
01726 }
01727 else {
01728 PRINTMSG(line,
01729 389,
01730 Error,
01731 col,
01732 AT_OBJ_NAME_PTR(gen_idx));
01733 }
01734 ok = FALSE;
01735 }
01736
01737 DONE:
01738
01739 if (ok && found && (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01740 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) {
01741
01742 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))) {
01743
01744 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
01745 PRINTMSG(IR_LINE_NUM_L(ir_idx), 1274, Error, IR_COL_NUM_L(ir_idx),
01746 AT_OBJ_NAME_PTR(spec_idx),
01747 "pure or elemental",
01748 "pure");
01749
01750 }
01751 }
01752 else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
01753
01754 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
01755 PRINTMSG(IR_LINE_NUM_L(ir_idx), 1274, Error, IR_COL_NUM_L(ir_idx),
01756 AT_OBJ_NAME_PTR(spec_idx),
01757 "pure or elemental",
01758 "elemental");
01759
01760 }
01761 }
01762
01763
01764
01765
01766 list_idx = IR_IDX_R(ir_idx);
01767
01768 if (ATP_EXTRA_DARG(spec_idx)) {
01769 arg_idx = ATP_FIRST_IDX(spec_idx) + 1;
01770 num_args = ATP_NUM_DARGS(spec_idx) - 1;
01771 }
01772 else {
01773 arg_idx = ATP_FIRST_IDX(spec_idx);
01774 num_args = ATP_NUM_DARGS(spec_idx);
01775 }
01776 for (;num_args > 0; num_args--) {
01777
01778 if (AT_OBJ_CLASS(SN_ATTR_IDX(arg_idx)) == Data_Obj &&
01779 (ATD_POINTER(SN_ATTR_IDX(arg_idx)) ||
01780 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Inout ||
01781 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Out)) {
01782 COPY_OPND(opnd, IL_OPND(list_idx));
01783
01784 if (! check_for_legal_define(&opnd)) {
01785 ok = FALSE;
01786 }
01787 }
01788 arg_idx++;
01789 list_idx = IL_NEXT_LIST_IDX(list_idx);
01790 }
01791 }
01792
01793 if (ok && found && ATP_VFUNCTION(spec_idx)) {
01794 num_registers = 0;
01795 list_idx = IR_IDX_R(ir_idx);
01796
01797 while (list_idx) {
01798
01799 if (IL_ARG_DESC_IDX(list_idx) == NULL_IDX) {
01800 list_idx = IL_NEXT_LIST_IDX(list_idx);
01801 continue;
01802 }
01803
01804 if (arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type == Character ||
01805 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type == Structure) {
01806
01807 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx)].line,
01808 910, Error,
01809 arg_info_list[IL_ARG_DESC_IDX(list_idx)].col);
01810 ok = FALSE;
01811 break;
01812 }
01813 else {
01814 num_registers += TARGET_BITS_TO_WORDS(storage_bit_size_tbl[
01815 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.linear_type]);
01816 }
01817
01818 if (num_registers > 7) {
01819 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx)].line,
01820 909, Error,
01821 arg_info_list[IL_ARG_DESC_IDX(list_idx)].col);
01822 ok = FALSE;
01823 break;
01824 }
01825
01826 list_idx = IL_NEXT_LIST_IDX(list_idx);
01827 }
01828 }
01829
01830 if (ok && found && (ATP_PROC(spec_idx) == Intrin_Proc)) {
01831
01832 if (expr_mode == Specification_Expr) {
01833
01834 if (!AT_ELEMENTAL_INTRIN(spec_idx)) {
01835
01836 switch (ATP_INTRIN_ENUM(spec_idx)) {
01837
01838 # if defined(COARRAY_FORTRAN)
01839 case Num_Images_Intrinsic:
01840 case Log2_Images_Intrinsic:
01841 case Rem_Images_Intrinsic:
01842
01843 if (!cmd_line_flags.co_array_fortran) {
01844 PRINTMSG(line, 870, Error, col, AT_OBJ_NAME_PTR(gen_idx));
01845 ok = FALSE;
01846 break;
01847 }
01848 else if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01849 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
01850 PRINTMSG(line, 1580, Error, col,
01851 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)),
01852 AT_OBJ_NAME_PTR(gen_idx));
01853 ok = FALSE;
01854 break;
01855 }
01856
01857
01858 # endif
01859
01860 case SIK_Intrinsic:
01861 case SRK_Intrinsic:
01862 case Lbound_Intrinsic:
01863 case Ubound_Intrinsic:
01864 case Size_Intrinsic:
01865 case Bit_Size_Intrinsic:
01866 case Len_Intrinsic:
01867 case Kind_Intrinsic:
01868 case Digits_Intrinsic:
01869 case Huge_Intrinsic:
01870 case Maxexponent_Intrinsic:
01871 case Minexponent_Intrinsic:
01872 case Precision_Intrinsic:
01873 case Radix_Intrinsic:
01874 case Range_Intrinsic:
01875 case Transfer_Intrinsic:
01876 case Merge_Intrinsic:
01877
01878
01879 if ((TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Integer &&
01880 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Character) ||
01881 res_exp_desc->rank > 1) {
01882 PRINTMSG(line, 1070, Error, col, AT_OBJ_NAME_PTR(gen_idx));
01883 ok = FALSE;
01884 }
01885 break;
01886
01887 default:
01888 PRINTMSG(line, 870, Error, col, AT_OBJ_NAME_PTR(gen_idx));
01889 ok = FALSE;
01890 break;
01891 }
01892 }
01893 else {
01894 if ((TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Integer &&
01895 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Character &&
01896 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Real &&
01897 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) != Typeless) ||
01898 res_exp_desc->rank > 1) {
01899 PRINTMSG(line, 1070, Error, col, AT_OBJ_NAME_PTR(gen_idx));
01900 ok = FALSE;
01901 }
01902 else {
01903 if (TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) == Real ||
01904 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(spec_idx))) == Typeless) {
01905 PRINTMSG(line, 1392, Ansi, col);
01906 }
01907 }
01908 }
01909 }
01910 else if (expr_mode == Initialization_Expr) {
01911
01912 if (!AT_ELEMENTAL_INTRIN(spec_idx) &&
01913 (ATP_INTRIN_ENUM(spec_idx) != SIK_Intrinsic) &&
01914 (ATP_INTRIN_ENUM(spec_idx) != SRK_Intrinsic) &&
01915 (ATP_INTRIN_ENUM(spec_idx) != Repeat_Intrinsic) &&
01916 (ATP_INTRIN_ENUM(spec_idx) != Reshape_Intrinsic) &&
01917 (ATP_INTRIN_ENUM(spec_idx) != Lbound_Intrinsic) &&
01918 (ATP_INTRIN_ENUM(spec_idx) != Ubound_Intrinsic) &&
01919 (ATP_INTRIN_ENUM(spec_idx) != Size_Intrinsic) &&
01920 (ATP_INTRIN_ENUM(spec_idx) != Shape_Intrinsic) &&
01921 (ATP_INTRIN_ENUM(spec_idx) != Transfer_Intrinsic) &&
01922 (ATP_INTRIN_ENUM(spec_idx) != Null_Intrinsic) &&
01923 (ATP_INTRIN_ENUM(spec_idx) != Trim_Intrinsic)) {
01924 PRINTMSG(line, 329, Error, col, AT_OBJ_NAME_PTR(gen_idx));
01925 ok = FALSE;
01926 }
01927 }
01928 }
01929
01930 if (ok &&
01931 ATP_PROC(spec_idx) != Intrin_Proc) {
01932
01933 if (! ATP_PURE(spec_idx)) {
01934 if (within_forall_mask_expr) {
01935 PRINTMSG(line, 1611, Error, col, AT_OBJ_NAME_PTR(spec_idx),
01936 "forall scalar-mask-expr");
01937 ok = FALSE;
01938 }
01939 else if (within_forall_construct) {
01940 PRINTMSG(line, 1611, Error, col, AT_OBJ_NAME_PTR(spec_idx),
01941 "forall-body-construct");
01942 ok = FALSE;
01943 }
01944 }
01945 }
01946
01947 res_exp_desc->has_symbolic = has_symbolic;
01948
01949 defer_stmt_expansion = save_defer_stmt_expansion;
01950 stmt_expansion_control_end(result_opnd);
01951
01952 if (OPND_FLD(save_result_opnd) != NO_Tbl_Idx &&
01953 OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
01954 IR_OPR(OPND_IDX((*result_opnd))) == Stmt_Expansion_Opr) {
01955
01956 list_idx = IR_IDX_R(OPND_IDX((*result_opnd)));
01957
01958 while (IL_NEXT_LIST_IDX(list_idx)) {
01959 list_idx = IL_NEXT_LIST_IDX(list_idx);
01960 }
01961
01962 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01963 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01964 list_idx = IL_NEXT_LIST_IDX(list_idx);
01965
01966 COPY_OPND(IL_OPND(list_idx), save_result_opnd);
01967
01968 IR_LIST_CNT_R(OPND_IDX((*result_opnd))) += 1;
01969 }
01970
01971 if (save_where_ir_idx != NULL_IDX &&
01972 where_ir_idx == NULL_IDX) {
01973
01974 where_ir_idx = save_where_ir_idx;
01975
01976 if (ATP_ELEMENTAL(spec_idx)) {
01977 check_for_elementals(find_left_attr(result_opnd));
01978 }
01979 }
01980 else {
01981 where_ir_idx = save_where_ir_idx;
01982 }
01983
01984 TRACE (Func_Exit, "call_list_semantics", NULL);
01985
01986 return(ok);
01987
01988 }
01989
01990
01991
01992
01993
01994
01995
01996
01997
01998
01999
02000
02001
02002
02003
02004
02005
02006 static void check_for_elementals(int attr_idx)
02007
02008 {
02009 int asg_idx;
02010 int call_idx;
02011 int col;
02012 int line;
02013 int list_idx;
02014 opnd_type opnd;
02015 int tmp_idx;
02016
02017 TRACE (Func_Entry, "check_for_elementals", NULL);
02018
02019 line = AT_DEF_LINE(attr_idx);
02020 col = AT_DEF_COLUMN(attr_idx);
02021
02022 # ifdef _DEBUG
02023 if (ATD_FLD(attr_idx) != IR_Tbl_Idx) {
02024 PRINTMSG(line, 626, Internal, col,
02025 "ATD_FLD(attr_idx) == IR_Tbl_Idx", "check_for_elementals");
02026 }
02027 # endif
02028
02029
02030 asg_idx = ATD_TMP_IDX(attr_idx);
02031
02032 # ifdef _DEBUG
02033 if (IR_FLD_R(asg_idx) != IR_Tbl_Idx ||
02034 IR_OPR(IR_IDX_R(asg_idx)) != Call_Opr ||
02035 ! ATP_ELEMENTAL(IR_IDX_L(IR_IDX_R(asg_idx)))) {
02036
02037 PRINTMSG(line, 626, Internal, col,
02038 "elemental function", "check_for_elementals");
02039 }
02040 # endif
02041
02042 call_idx = IR_IDX_R(asg_idx);
02043
02044 change_asg_to_where(asg_idx);
02045
02046
02047
02048
02049
02050 list_idx = IR_IDX_R(call_idx);
02051
02052 while (list_idx) {
02053
02054 tmp_idx = find_left_attr(&IL_OPND(list_idx));
02055 line = AT_DEF_LINE(tmp_idx);
02056 col = AT_DEF_COLUMN(tmp_idx);
02057
02058 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj &&
02059 ATD_CLASS(tmp_idx) == Compiler_Tmp &&
02060 ATD_FLD(tmp_idx) == IR_Tbl_Idx &&
02061 ATD_ARRAY_IDX(tmp_idx) != NULL_IDX &&
02062 (ATD_ELEMENTAL_CALL_TMP(tmp_idx) ||
02063 ATD_ASG_TMP(tmp_idx))) {
02064
02065 asg_idx = ATD_TMP_IDX(tmp_idx);
02066
02067 # ifdef _DEBUG
02068 if (IR_OPR(asg_idx) != Asg_Opr) {
02069 PRINTMSG(line, 626, Internal, col,
02070 "Asg_Opr", "check_for_elementals");
02071 }
02072 # endif
02073
02074 if (ATD_ELEMENTAL_CALL_TMP(tmp_idx)) {
02075 check_for_elementals(tmp_idx);
02076 }
02077 else if (ATD_ASG_TMP(tmp_idx)) {
02078 COPY_OPND(opnd, IR_OPND_R(asg_idx));
02079 check_expr_for_elementals(&opnd);
02080
02081 change_asg_to_where(asg_idx);
02082 }
02083 }
02084
02085 list_idx = IL_NEXT_LIST_IDX(list_idx);
02086 }
02087
02088 TRACE (Func_Exit, "check_for_elementals", NULL);
02089
02090 return;
02091
02092 }
02093
02094
02095
02096
02097
02098
02099
02100
02101
02102
02103
02104
02105
02106
02107
02108
02109
02110 static void check_expr_for_elementals(opnd_type *top_opnd)
02111
02112 {
02113 int attr_idx;
02114 int ir_idx;
02115 int list_idx;
02116 opnd_type opnd;
02117
02118 TRACE (Func_Entry, "check_expr_for_elementals", NULL);
02119
02120 switch (OPND_FLD((*top_opnd))) {
02121 case AT_Tbl_Idx:
02122 attr_idx = OPND_IDX((*top_opnd));
02123
02124 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
02125 ATD_CLASS(attr_idx) == Compiler_Tmp &&
02126 ATD_ELEMENTAL_CALL_TMP(attr_idx)) {
02127
02128 check_for_elementals(attr_idx);
02129 }
02130 break;
02131
02132 case IR_Tbl_Idx:
02133 ir_idx = OPND_IDX((*top_opnd));
02134 COPY_OPND(opnd, IR_OPND_L(ir_idx));
02135 check_expr_for_elementals(&opnd);
02136 COPY_OPND(opnd, IR_OPND_R(ir_idx));
02137 check_expr_for_elementals(&opnd);
02138 break;
02139
02140 case IL_Tbl_Idx:
02141 list_idx = OPND_IDX((*top_opnd));
02142 while (list_idx) {
02143 COPY_OPND(opnd, IL_OPND(list_idx));
02144 check_expr_for_elementals(&opnd);
02145 list_idx = IL_NEXT_LIST_IDX(list_idx);
02146 }
02147 break;
02148
02149 case CN_Tbl_Idx:
02150 case NO_Tbl_Idx:
02151 case SH_Tbl_Idx:
02152 break;
02153 }
02154
02155 TRACE (Func_Exit, "check_expr_for_elementals", NULL);
02156
02157 return;
02158
02159 }
02160
02161
02162
02163
02164
02165
02166
02167
02168
02169
02170
02171
02172
02173
02174
02175
02176
02177 void change_asg_to_where(int asg_idx)
02178
02179 {
02180 int list_idx;
02181
02182 TRACE (Func_Entry, "change_asg_to_where", NULL);
02183
02184 if (IR_OPR(asg_idx) == Call_Opr) {
02185
02186
02187 NTR_IR_LIST_TBL(list_idx);
02188 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(asg_idx));
02189 IR_FLD_L(asg_idx) = IL_Tbl_Idx;
02190 IR_IDX_L(asg_idx) = list_idx;
02191 IR_LIST_CNT_L(asg_idx) = 4;
02192
02193
02194
02195 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02196 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02197 list_idx = IL_NEXT_LIST_IDX(list_idx);
02198
02199 COPY_OPND(IL_OPND(list_idx),
02200 IL_OPND(IR_IDX_R(asg_idx)));
02201
02202
02203
02204 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02205 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02206 list_idx = IL_NEXT_LIST_IDX(list_idx);
02207
02208 IL_FLD(list_idx) = IR_Tbl_Idx;
02209 IL_IDX(list_idx) = where_ir_idx;
02210
02211
02212
02213 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02214 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02215 list_idx = IL_NEXT_LIST_IDX(list_idx);
02216
02217 COPY_OPND(IL_OPND(list_idx),
02218 IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(asg_idx))));
02219 }
02220 else {
02221
02222
02223 NTR_IR_LIST_TBL(list_idx);
02224 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(asg_idx));
02225 IR_FLD_L(asg_idx) = IL_Tbl_Idx;
02226 IR_IDX_L(asg_idx) = list_idx;
02227 IR_LIST_CNT_L(asg_idx) = 3;
02228
02229
02230
02231 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02232 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02233 list_idx = IL_NEXT_LIST_IDX(list_idx);
02234
02235 IL_FLD(list_idx) = IR_Tbl_Idx;
02236 IL_IDX(list_idx) = where_ir_idx;
02237
02238
02239
02240 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02241 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02242 list_idx = IL_NEXT_LIST_IDX(list_idx);
02243
02244 COPY_OPND(IL_OPND(list_idx), IR_OPND_R(asg_idx));
02245 }
02246
02247 IR_OPR(asg_idx) = Where_Opr;
02248 IR_OPND_R(asg_idx) = null_opnd;
02249
02250 TRACE (Func_Exit, "change_asg_to_where", NULL);
02251
02252 return;
02253
02254 }
02255
02256
02257
02258
02259
02260
02261
02262
02263
02264
02265
02266
02267
02268
02269
02270
02271
02272
02273
02274
02275
02276 boolean final_arg_work(opnd_type *list_opnd,
02277 int spec_idx,
02278 int num_args,
02279 expr_arg_type *elemental_exp_desc)
02280
02281 {
02282 act_arg_type a_type;
02283 int addr_tmp_idx;
02284 int asg_idx;
02285 int association;
02286 int attr_idx;
02287 opnd_type base_opnd;
02288 long64 char_len;
02289 char *char_ptr1;
02290 char *char_ptr2;
02291 int col;
02292 dummy_arg_type d_type;
02293 int debug_count;
02294 int dummy;
02295 int dummy_idx;
02296 opnd_type dv_opnd;
02297 expr_arg_type exp_desc;
02298 boolean explicit;
02299 int false_list_idx = NULL_IDX;
02300 int false_parm_idx;
02301 int fcd_idx;
02302 int i;
02303 int info_idx;
02304 int intent;
02305 boolean io_call = FALSE;
02306 int ir_idx;
02307 long k;
02308 opnd_type len_opnd;
02309 int line;
02310 int list_idx;
02311 int list_idx2;
02312 opnd_type l_opnd;
02313 int mult_idx;
02314 boolean ok = TRUE;
02315 int old_cn_idx;
02316 opnd_type opnd;
02317 int opnd_column;
02318 int opnd_line;
02319 int present_idx;
02320 opnd_type r_opnd;
02321 int save_defer_stmt_expansion;
02322 expr_mode_type save_expr_mode;
02323 cif_usage_code_type save_xref_state;
02324 long_type the_constant;
02325 int tmp_idx;
02326 int tmp_dv_idx;
02327 int tmp_loc_idx;
02328 int unused1;
02329 int unused2;
02330 int zero_constant_idx;
02331 int false_start_sh_idx;
02332 int false_end_sh_idx;
02333 int true_start_sh_idx;
02334 int true_end_sh_idx;
02335 int true_start_sh_idx2;
02336 int true_end_sh_idx2;
02337 opnd_type cond_opnd;
02338
02339
02340 TRACE (Func_Entry, "final_arg_work", NULL);
02341
02342 exp_desc = init_exp_desc;
02343
02344 save_expr_mode = expr_mode;
02345
02346 expr_mode = Regular_Expr;
02347
02348 explicit = ATP_EXPL_ITRFC(spec_idx);
02349 dummy = NULL_IDX;
02350
02351 zero_constant_idx = (SA_INTEGER_DEFAULT_TYPE == CG_INTEGER_DEFAULT_TYPE) ?
02352 CN_INTEGER_ZERO_IDX :
02353 C_INT_TO_CN(SA_INTEGER_DEFAULT_TYPE, 0);
02354
02355 if (ATP_ELEMENTAL(spec_idx)) {
02356 list_idx = OPND_IDX((*list_opnd));
02357
02358 if (ATP_EXTRA_DARG(spec_idx)) {
02359 list_idx = IL_NEXT_LIST_IDX(list_idx);
02360 }
02361 ok = check_elemental_conformance(list_idx, &exp_desc);
02362 explicit = FALSE;
02363
02364 if (elemental_exp_desc != NULL) {
02365 elemental_exp_desc->rank = exp_desc.rank;
02366 COPY_SHAPE(elemental_exp_desc->shape, exp_desc.shape, exp_desc.rank);
02367 }
02368 }
02369
02370 # ifdef _DEBUG
02371 if (explicit && FALSE) {
02372
02373
02374
02375
02376
02377
02378 debug_count = 0;
02379 list_idx = OPND_IDX((*list_opnd));
02380
02381 while (list_idx != NULL_IDX) {
02382 if (! IL_INTRIN_PLACE_HOLDER(list_idx)) {
02383 debug_count++;
02384 }
02385 list_idx = IL_NEXT_LIST_IDX(list_idx);
02386 }
02387
02388 if (debug_count != ATP_NUM_DARGS(spec_idx)) {
02389 PRINTMSG(stmt_start_line, 1119, Internal, stmt_start_col,
02390 AT_OBJ_NAME_PTR(spec_idx));
02391 }
02392 }
02393 # endif
02394
02395
02396 if (spec_idx == glb_tbl_idx[Buffer_In_Attr_Idx] ||
02397 spec_idx == glb_tbl_idx[Buffer_Out_Attr_Idx] ||
02398 spec_idx == glb_tbl_idx[Close_Attr_Idx] ||
02399 spec_idx == glb_tbl_idx[Backspace_Attr_Idx] ||
02400 spec_idx == glb_tbl_idx[Rewind_Attr_Idx] ||
02401 spec_idx == glb_tbl_idx[Endfile_Attr_Idx] ||
02402 spec_idx == glb_tbl_idx[Inquire_Attr_Idx] ||
02403 spec_idx == glb_tbl_idx[Open_Attr_Idx]) {
02404
02405 io_call = TRUE;
02406 }
02407
02408 list_idx = OPND_IDX((*list_opnd));
02409 # if 0
02410
02411
02412 if (!ATP_EXPL_ITRFC(spec_idx) &&
02413 !io_call &&
02414 !AT_COMPILER_GEND(spec_idx)) {
02415
02416
02417
02418
02419 check_call_for_global_def(list_idx, spec_idx, num_args);
02420 }
02421 # endif
02422
02423 if (ATP_EXTRA_DARG(spec_idx)) {
02424 list_idx = IL_NEXT_LIST_IDX(list_idx);
02425 }
02426
02427 dummy_idx = 1;
02428
02429 for (i = 1; i <= num_args; i++) {
02430
02431 stmt_expansion_control_start();
02432 save_defer_stmt_expansion = defer_stmt_expansion;
02433 defer_stmt_expansion = FALSE;
02434
02435 if (IL_FLD(list_idx) == NO_Tbl_Idx &&
02436 ATP_PROC(spec_idx) == Intrin_Proc &&
02437 IL_INTRIN_PLACE_HOLDER(list_idx)) {
02438
02439
02440
02441 IL_FLD(list_idx) = CN_Tbl_Idx;
02442 IL_IDX(list_idx) = zero_constant_idx;
02443 IL_LINE_NUM(list_idx) = stmt_start_line;
02444 IL_COL_NUM(list_idx) = stmt_start_col;
02445
02446
02447
02448
02449 goto EXIT;
02450 }
02451
02452
02453
02454
02455
02456 if (explicit) {
02457 if (ATP_EXTRA_DARG(spec_idx)) {
02458 dummy = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + dummy_idx);
02459 }
02460 else {
02461 dummy = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + dummy_idx - 1);
02462 }
02463 }
02464
02465 if (IL_FLD(list_idx) == NO_Tbl_Idx) {
02466 # if 0
02467
02468
02469
02470 # if defined(GENERATE_WHIRL)
02471 if (explicit &&
02472 ! io_call &&
02473 (AT_OBJ_CLASS(dummy) == Data_Obj &&
02474 ! ATD_IM_A_DOPE(dummy) &&
02475 (ATP_PROC(spec_idx) == Intrin_Proc ?
02476 (((1 << Character_1) & ATD_INTRIN_DARG_TYPE(dummy)) != 0) :
02477 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character)))
02478 # else
02479 if (explicit &&
02480 ! io_call &&
02481 ((AT_OBJ_CLASS(dummy) == Data_Obj &&
02482 ! ATD_IM_A_DOPE(dummy) &&
02483 (ATP_PROC(spec_idx) == Intrin_Proc ?
02484 (((1 << Character_1) & ATD_INTRIN_DARG_TYPE(dummy)) != 0) :
02485 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character)) ||
02486 (AT_OBJ_CLASS(dummy) == Pgm_Unit &&
02487 ATP_PGM_UNIT(dummy) == Function &&
02488 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(dummy))) == Character)))
02489 # endif
02490 {
02491
02492
02493
02494 NTR_IR_TBL(fcd_idx);
02495 IR_OPR(fcd_idx) = Fcd_Opr;
02496 IR_TYPE_IDX(fcd_idx) = CRI_Ch_Ptr_8;
02497 IR_LINE_NUM(fcd_idx) = stmt_start_line;
02498 IR_COL_NUM(fcd_idx) = stmt_start_col;
02499
02500 NTR_IR_LIST_TBL(list_idx2);
02501 IR_FLD_L(fcd_idx) = IL_Tbl_Idx;
02502 IR_IDX_L(fcd_idx) = list_idx2;
02503 IR_LIST_CNT_L(fcd_idx) = 2;
02504
02505
02506 IL_FLD(list_idx2) = CN_Tbl_Idx;
02507 IL_IDX(list_idx2) = zero_constant_idx;
02508 IL_LINE_NUM(list_idx2) = stmt_start_line;
02509 IL_COL_NUM(list_idx2) = stmt_start_col;
02510
02511 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
02512 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
02513 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
02514
02515 IL_FLD(list_idx2) = CN_Tbl_Idx;
02516 IL_IDX(list_idx2) = zero_constant_idx;
02517 IL_LINE_NUM(list_idx2) = stmt_start_line;
02518 IL_COL_NUM(list_idx2) = stmt_start_col;
02519
02520 IL_FLD(list_idx) = IR_Tbl_Idx;
02521 IL_IDX(list_idx) = fcd_idx;
02522
02523 }
02524 else {
02525 #if defined(GENERATE_WHIRL)
02526 NTR_IR_TBL(fcd_idx);
02527 IR_OPR(fcd_idx) = Aloc_Opr;
02528 IR_TYPE_IDX(fcd_idx) = CRI_Ptr_8;
02529 IR_LINE_NUM(fcd_idx) = stmt_start_line;
02530 IR_COL_NUM(fcd_idx) = stmt_start_col;
02531
02532 IR_FLD_L(fcd_idx) = CN_Tbl_Idx;
02533 IR_IDX_L(fcd_idx) = zero_constant_idx;
02534 IR_LINE_NUM_L(fcd_idx) = stmt_start_line;
02535 IR_COL_NUM_L(fcd_idx) = stmt_start_col;
02536
02537 IL_FLD(list_idx) = IR_Tbl_Idx;
02538 IL_IDX(list_idx) = fcd_idx;
02539 #else
02540 IL_FLD(list_idx) = CN_Tbl_Idx;
02541 IL_IDX(list_idx) = zero_constant_idx;
02542 IL_LINE_NUM(list_idx) = stmt_start_line;
02543 IL_COL_NUM(list_idx) = stmt_start_col;
02544 #endif
02545 }
02546
02547 # endif
02548 dummy_idx++;
02549 goto EXIT;
02550 }
02551
02552
02553 info_idx = ir_list_tbl[list_idx].il.link.prev_idx;
02554
02555 #if 0
02556 # ifdef _DEBUG
02557 if (info_idx == NULL_IDX) {
02558 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
02559 "valid info_idx", "final_arg_work");
02560 }
02561 # endif
02562 #endif
02563 COPY_OPND(opnd, IL_OPND(list_idx));
02564 check_for_constructors(&opnd,
02565 (info_idx != NULL_IDX ? &(arg_info_list[info_idx].ed):
02566 NULL));
02567 COPY_OPND(IL_OPND(list_idx), opnd);
02568
02569 if (OPND_FLD(opnd) == AT_Tbl_Idx ||
02570 (OPND_FLD(opnd) == IR_Tbl_Idx &&
02571 (IR_OPR(OPND_IDX(opnd)) == Subscript_Opr ||
02572 IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr ||
02573 IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr ||
02574 IR_OPR(OPND_IDX(opnd)) == Substring_Opr ||
02575 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr ||
02576 IR_OPR(OPND_IDX(opnd)) == Struct_Opr ||
02577 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr))) {
02578
02579 attr_idx = find_left_attr(&opnd);
02580
02581 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
02582 ATD_CLASS(attr_idx) == Compiler_Tmp) {
02583 arg_info_list[info_idx].ed.tmp_reference = TRUE;
02584 arg_info_list[info_idx].ed.reference = FALSE;
02585 }
02586 else if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02587 arg_info_list[info_idx].ed.reference = TRUE;
02588 arg_info_list[info_idx].ed.tmp_reference = FALSE;
02589 }
02590 }
02591
02592 if (arg_info_list[info_idx].ed.label) {
02593
02594 if (stmt_type == Call_Stmt) {
02595
02596
02597 IL_FLD(list_idx) = CN_Tbl_Idx;
02598 IL_IDX(list_idx) = zero_constant_idx;
02599 IL_LINE_NUM(list_idx) = stmt_start_line;
02600 IL_COL_NUM(list_idx) = stmt_start_col;
02601 }
02602 else {
02603
02604
02605 IL_FLD(list_idx) = CN_Tbl_Idx;
02606 IL_IDX(list_idx) = CN_INTEGER_NEG_ONE_IDX;
02607 IL_LINE_NUM(list_idx) = stmt_start_line;
02608 IL_COL_NUM(list_idx) = stmt_start_col;
02609 }
02610
02611 dummy_idx++;
02612 goto EXIT;
02613 }
02614
02615 if (arg_info_list[info_idx].pgm_unit) {
02616 set_at_actual_arg(list_idx);
02617
02618 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02619 &opnd_line,
02620 &opnd_column);
02621
02622 if (IL_FLD(list_idx) == AT_Tbl_Idx &&
02623 !AT_IS_INTRIN(IL_IDX(list_idx)) &&
02624 AT_OBJ_CLASS(IL_IDX(list_idx)) == Pgm_Unit &&
02625 ATP_ELEMENTAL(IL_IDX(list_idx))) {
02626 PRINTMSG(opnd_line, 1639, Error,
02627 opnd_column,
02628 AT_OBJ_NAME_PTR(IL_IDX(list_idx)));
02629
02630 ok = FALSE;
02631 }
02632
02633
02634 # if defined(GENERATE_WHIRL)
02635 NTR_IR_TBL(ir_idx);
02636 IR_OPR(ir_idx) = Aloc_Opr;
02637 IR_TYPE_IDX(ir_idx) = CRI_Parcel_Ptr_8;
02638 IR_LINE_NUM(ir_idx) = opnd_line;
02639 IR_COL_NUM(ir_idx) = opnd_column;
02640 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
02641 IL_FLD(list_idx) = IR_Tbl_Idx;
02642 IL_IDX(list_idx) = ir_idx;
02643 # else
02644 if (arg_info_list[info_idx].ed.type == Character) {
02645
02646 NTR_IR_TBL(fcd_idx);
02647 IR_OPR(fcd_idx) = Fcd_Opr;
02648 IR_TYPE_IDX(fcd_idx) = CRI_Ch_Ptr_8;
02649 IR_LINE_NUM(fcd_idx) = opnd_line;
02650 IR_COL_NUM(fcd_idx) = opnd_column;
02651
02652 NTR_IR_LIST_TBL(list_idx2);
02653 IR_FLD_L(fcd_idx) = IL_Tbl_Idx;
02654 IR_IDX_L(fcd_idx) = list_idx2;
02655 IR_LIST_CNT_L(fcd_idx) = 2;
02656
02657
02658 NTR_IR_TBL(ir_idx);
02659 IR_OPR(ir_idx) = Aloc_Opr;
02660 IR_TYPE_IDX(ir_idx) = CRI_Parcel_Ptr_8;
02661 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
02662 IR_LINE_NUM(ir_idx) = opnd_line;
02663 IR_COL_NUM(ir_idx) = opnd_column;
02664 IL_FLD(list_idx2) = IR_Tbl_Idx;
02665 IL_IDX(list_idx2) = ir_idx;
02666
02667 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
02668 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
02669 list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
02670
02671 IL_FLD(list_idx2) = TYP_FLD(arg_info_list[info_idx].ed.type_idx);
02672 IL_IDX(list_idx2) = TYP_IDX(arg_info_list[info_idx].ed.type_idx);
02673 IL_LINE_NUM(list_idx2) = opnd_line;
02674 IL_COL_NUM(list_idx2) = opnd_column;
02675
02676 IL_FLD(list_idx) = IR_Tbl_Idx;
02677 IL_IDX(list_idx) = fcd_idx;
02678 }
02679 else {
02680 NTR_IR_TBL(ir_idx);
02681 IR_OPR(ir_idx) = Aloc_Opr;
02682 IR_TYPE_IDX(ir_idx) = CRI_Parcel_Ptr_8;
02683 IR_LINE_NUM(ir_idx) = opnd_line;
02684 IR_COL_NUM(ir_idx) = opnd_column;
02685 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
02686 IL_FLD(list_idx) = IR_Tbl_Idx;
02687 IL_IDX(list_idx) = ir_idx;
02688 }
02689 # endif
02690
02691 dummy_idx++;
02692 goto EXIT;
02693 }
02694
02695 if (explicit) {
02696
02697
02698 if (ATD_POINTER(dummy) &&
02699 ! arg_info_list[info_idx].ed.pointer) {
02700
02701
02702
02703 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02704 &opnd_line,
02705 &opnd_column);
02706 PRINTMSG(opnd_line, 256, Error,
02707 opnd_column,
02708 AT_OBJ_NAME_PTR(dummy));
02709
02710 ok = FALSE;
02711 }
02712
02713
02714 # if 0
02715
02716
02717
02718
02719 if (ATD_TARGET(dummy) &&
02720 ((! arg_info_list[info_idx].ed.target &&
02721 ! arg_info_list[info_idx].ed.pointer) ||
02722 arg_info_list[info_idx].ed.vector_subscript)) {
02723 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02724 &opnd_line,
02725 &opnd_column);
02726
02727 PRINTMSG(opnd_line, 622, Error,
02728 opnd_column,
02729 AT_OBJ_NAME_PTR(dummy));
02730
02731 ok = FALSE;
02732 }
02733 # endif
02734
02735 if (arg_info_list[info_idx].ed.assumed_size &&
02736 ATD_ARRAY_IDX(dummy) &&
02737 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Assumed_Shape) {
02738
02739
02740
02741 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02742 &opnd_line,
02743 &opnd_column);
02744
02745 PRINTMSG(opnd_line, 258, Error, opnd_column);
02746
02747 ok = FALSE;
02748 }
02749
02750
02751
02752
02753 if (ATD_INTENT(dummy) == Intent_Out ||
02754 ATD_INTENT(dummy) == Intent_Inout) {
02755
02756 if (arg_info_list[info_idx].ed.vector_subscript ||
02757 ! arg_info_list[info_idx].ed.reference) {
02758 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02759 &opnd_line,
02760 &opnd_column);
02761
02762 PRINTMSG(opnd_line, 786, Error, opnd_column);
02763 ok = FALSE;
02764 }
02765 else {
02766 #ifdef SOURCE_TO_SOURCE
02767 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
02768 IR_OPR(IL_IDX(list_idx)) == Kwd_Opr) {
02769 COPY_OPND(opnd, IR_OPND_R(IL_IDX(list_idx)));
02770 } else {
02771 COPY_OPND(opnd, IL_OPND(list_idx));
02772 }
02773 #else
02774 COPY_OPND(opnd, IL_OPND(list_idx));
02775 #endif
02776 attr_idx = find_left_attr(&opnd);
02777
02778 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
02779 ATD_CLASS(attr_idx) == Dummy_Argument &&
02780 ATD_INTENT(attr_idx) == Intent_In) {
02781
02782 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02783 &opnd_line,
02784 &opnd_column);
02785 PRINTMSG(opnd_line, 786, Error, opnd_column);
02786
02787 ok = FALSE;
02788 }
02789 }
02790 }
02791
02792 if (arg_info_list[info_idx].ed.type == Character &&
02793 ATP_PROC(spec_idx) != Intrin_Proc &&
02794 AT_OBJ_CLASS(dummy) == Data_Obj &&
02795 ATD_ARRAY_IDX(dummy) == NULL_IDX &&
02796 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character) {
02797
02798 if (TYP_FLD(arg_info_list[info_idx].ed.type_idx) == CN_Tbl_Idx &&
02799 TYP_FLD(ATD_TYPE_IDX(dummy)) == CN_Tbl_Idx &&
02800 fold_relationals(TYP_IDX(arg_info_list[info_idx].ed.type_idx),
02801 TYP_IDX(ATD_TYPE_IDX(dummy)),
02802 Lt_Opr)) {
02803
02804 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02805 &opnd_line,
02806 &opnd_column);
02807
02808 PRINTMSG(opnd_line, 1205, Error, opnd_column,
02809 AT_OBJ_NAME_PTR(dummy));
02810 ok = FALSE;
02811 }
02812 }
02813
02814
02815
02816 if (TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character &&
02817 TYP_FLD(ATD_TYPE_IDX(dummy)) == CN_Tbl_Idx &&
02818 ATD_ARRAY_IDX(dummy) != NULL_IDX &&
02819 BD_LEN_FLD(ATD_ARRAY_IDX(dummy)) == CN_Tbl_Idx &&
02820 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Explicit_Shape &&
02821 arg_info_list[info_idx].ed.rank != 0) {
02822
02823 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02824 &opnd_line,
02825 &opnd_column);
02826
02827 COPY_OPND(opnd, IL_OPND(list_idx));
02828 exp_desc = arg_info_list[info_idx].ed;
02829 ok &= validate_char_len(&opnd, &exp_desc);
02830 arg_info_list[info_idx].ed = exp_desc;
02831
02832 OPND_FLD(len_opnd) = TYP_FLD(exp_desc.type_idx);
02833 OPND_IDX(len_opnd) = TYP_IDX(exp_desc.type_idx);
02834
02835 for (k = 0; k < arg_info_list[info_idx].ed.rank; k++) {
02836 NTR_IR_TBL(mult_idx);
02837 IR_OPR(mult_idx) = Mult_Opr;
02838 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
02839 IR_LINE_NUM(mult_idx) = opnd_line;
02840 IR_COL_NUM(mult_idx) = opnd_column;
02841
02842 COPY_OPND(IR_OPND_L(mult_idx), len_opnd);
02843
02844 COPY_OPND(IR_OPND_R(mult_idx),
02845 arg_info_list[info_idx].ed.shape[k]);
02846
02847 OPND_FLD(len_opnd) = IR_Tbl_Idx;
02848 OPND_IDX(len_opnd) = mult_idx;
02849 }
02850
02851 NTR_IR_TBL(mult_idx);
02852 IR_OPR(mult_idx) = Mult_Opr;
02853 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
02854 IR_LINE_NUM(mult_idx) = opnd_line;
02855 IR_COL_NUM(mult_idx) = opnd_column;
02856
02857 IR_FLD_L(mult_idx) = BD_LEN_FLD(ATD_ARRAY_IDX(dummy));
02858 IR_IDX_L(mult_idx) = BD_LEN_IDX(ATD_ARRAY_IDX(dummy));
02859 IR_LINE_NUM_L(mult_idx) = opnd_line;
02860 IR_COL_NUM_L(mult_idx) = opnd_column;
02861
02862 IR_FLD_R(mult_idx) = TYP_FLD(ATD_TYPE_IDX(dummy));
02863 IR_IDX_R(mult_idx) = TYP_IDX(ATD_TYPE_IDX(dummy));
02864 IR_LINE_NUM_R(mult_idx) = opnd_line;
02865 IR_COL_NUM_R(mult_idx) = opnd_column;
02866
02867 NTR_IR_TBL(ir_idx);
02868 IR_OPR(ir_idx) = Gt_Opr;
02869 IR_TYPE_IDX(ir_idx) = CG_LOGICAL_DEFAULT_TYPE;
02870 IR_LINE_NUM(ir_idx) = opnd_line;
02871 IR_COL_NUM(ir_idx) = opnd_column;
02872
02873 IR_FLD_L(ir_idx) = IR_Tbl_Idx;
02874 IR_IDX_L(ir_idx) = mult_idx;
02875 IR_LINE_NUM_L(ir_idx) = opnd_line;
02876 IR_COL_NUM_L(ir_idx) = opnd_column;
02877
02878 COPY_OPND(IR_OPND_R(ir_idx), len_opnd);
02879
02880 OPND_FLD(len_opnd) = IR_Tbl_Idx;
02881 OPND_IDX(len_opnd) = ir_idx;
02882
02883 save_xref_state = xref_state;
02884 xref_state = CIF_No_Usage_Rec;
02885 save_expr_mode = expr_mode;
02886 expr_mode = Regular_Expr;
02887
02888 exp_desc.rank = 0;
02889 ok = expr_semantics(&len_opnd, &exp_desc);
02890 xref_state = save_xref_state;
02891 expr_mode = save_expr_mode;
02892
02893 if (OPND_FLD(len_opnd) == CN_Tbl_Idx &&
02894 THIS_IS_TRUE((&CN_CONST(OPND_IDX(len_opnd))),
02895 exp_desc.type_idx)) {
02896
02897 PRINTMSG(opnd_line, 1500, Error, opnd_column);
02898 ok = FALSE;
02899 }
02900 }
02901 else if (ATD_ARRAY_IDX(dummy) != NULL_IDX &&
02902 BD_LEN_FLD(ATD_ARRAY_IDX(dummy)) == CN_Tbl_Idx &&
02903 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy)) == Explicit_Shape &&
02904 arg_info_list[info_idx].ed.rank != 0) {
02905
02906 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
02907 &opnd_line,
02908 &opnd_column);
02909
02910 COPY_OPND(len_opnd, arg_info_list[info_idx].ed.shape[0]);
02911
02912 for (k = 1; k < arg_info_list[info_idx].ed.rank; k++) {
02913 NTR_IR_TBL(mult_idx);
02914 IR_OPR(mult_idx) = Mult_Opr;
02915 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
02916 IR_LINE_NUM(mult_idx) = opnd_line;
02917 IR_COL_NUM(mult_idx) = opnd_column;
02918
02919 COPY_OPND(IR_OPND_L(mult_idx), len_opnd);
02920
02921 COPY_OPND(IR_OPND_R(mult_idx),
02922 arg_info_list[info_idx].ed.shape[k]);
02923
02924 OPND_FLD(len_opnd) = IR_Tbl_Idx;
02925 OPND_IDX(len_opnd) = mult_idx;
02926 }
02927
02928 save_xref_state = xref_state;
02929 xref_state = CIF_No_Usage_Rec;
02930 save_expr_mode = expr_mode;
02931 expr_mode = Regular_Expr;
02932
02933 exp_desc.rank = 0;
02934 ok = expr_semantics(&len_opnd, &exp_desc);
02935 xref_state = save_xref_state;
02936 expr_mode = save_expr_mode;
02937
02938 if (OPND_FLD(len_opnd) == CN_Tbl_Idx &&
02939 fold_relationals(BD_LEN_IDX(ATD_ARRAY_IDX(dummy)),
02940 OPND_IDX(len_opnd),
02941 Gt_Opr)) {
02942 PRINTMSG(opnd_line, 1500, Error, opnd_column);
02943 ok = FALSE;
02944 }
02945 }
02946 }
02947
02948 if (explicit &&
02949 arg_info_list[info_idx].ed.linear_type == Short_Typeless_Const &&
02950 (TYP_TYPE(ATD_TYPE_IDX(dummy)) == Integer ||
02951 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Real ||
02952 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Complex)) {
02953
02954 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
02955 ATD_TYPE_IDX(dummy),
02956 arg_info_list[info_idx].line,
02957 arg_info_list[info_idx].col);
02958
02959 arg_info_list[info_idx].ed.type_idx = ATD_TYPE_IDX(dummy);
02960 arg_info_list[info_idx].ed.type = TYP_TYPE(ATD_TYPE_IDX(dummy));
02961 arg_info_list[info_idx].ed.linear_type =
02962 TYP_LINEAR(ATD_TYPE_IDX(dummy));
02963 }
02964 else if (explicit &&
02965 arg_info_list[info_idx].ed.linear_type ==
02966 Short_Typeless_Const &&
02967 (CN_HOLLERITH_TYPE(IL_IDX(list_idx)) == H_Hollerith ||
02968 CN_HOLLERITH_TYPE(IL_IDX(list_idx)) == L_Hollerith) &&
02969 TYP_TYPE(ATD_TYPE_IDX(dummy)) == Character) {
02970
02971 old_cn_idx = IL_IDX(list_idx);
02972
02973 char_len = strlen((char *)&CN_CONST(IL_IDX(list_idx)));
02974
02975 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
02976
02977 TYP_TYPE(TYP_WORK_IDX) = Character;
02978 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
02979 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
02980 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx;
02981 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(NULL_IDX,
02982 char_len);
02983 arg_info_list[info_idx].ed.type_idx = ntr_type_tbl();
02984 arg_info_list[info_idx].ed.type = Character;
02985 arg_info_list[info_idx].ed.linear_type = Short_Char_Const;
02986 arg_info_list[info_idx].ed.char_len.fld =
02987 TYP_FLD(arg_info_list[info_idx].ed.type_idx);
02988 arg_info_list[info_idx].ed.char_len.idx =
02989 TYP_IDX(arg_info_list[info_idx].ed.type_idx);
02990
02991
02992
02993
02994 IL_IDX(list_idx) = ntr_const_tbl(arg_info_list[info_idx].ed.type_idx,
02995 TRUE,
02996 NULL);
02997
02998 for (k = 0; k < TARGET_BYTES_TO_WORDS(char_len); k++) {
02999 CP_CONSTANT(CN_POOL_IDX(IL_IDX(list_idx)) + k) =
03000 CP_CONSTANT(CN_POOL_IDX(old_cn_idx) + k);
03001 }
03002 }
03003 else if (! explicit &&
03004 arg_info_list[info_idx].ed.linear_type == Short_Typeless_Const &&
03005 CN_HOLLERITH_TYPE(IL_IDX(list_idx)) == Not_Hollerith) {
03006
03007 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx),
03008 INTEGER_DEFAULT_TYPE,
03009 arg_info_list[info_idx].line,
03010 arg_info_list[info_idx].col);
03011
03012 arg_info_list[info_idx].ed.type_idx = INTEGER_DEFAULT_TYPE;
03013 arg_info_list[info_idx].ed.type = TYP_TYPE(INTEGER_DEFAULT_TYPE);
03014 arg_info_list[info_idx].ed.linear_type =
03015 TYP_LINEAR(INTEGER_DEFAULT_TYPE);
03016 }
03017
03018
03019 if (arg_info_list[info_idx].ed.reference &&
03020 ! arg_info_list[info_idx].ed.vector_subscript &&
03021 arg_info_list[info_idx].maybe_modified) {
03022
03023 set_at_actual_arg(list_idx);
03024 }
03025
03026
03027 d_type = get_dummy_arg_type(dummy);
03028
03029 if (dummy != NULL_IDX &&
03030 AT_OBJ_CLASS(dummy) == Data_Obj &&
03031 ATD_IGNORE_TKR(dummy)) {
03032
03033 d_type = Unknown_Dummy;
03034 }
03035
03036 # if 0
03037
03038 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
03039 IR_OPR(IL_IDX(list_idx)) == Null_Intrinsic_Opr) {
03040
03041 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03042 &opnd_line,
03043 &opnd_column);
03044
03045 if (dummy != NULL_IDX &&
03046 AT_OBJ_CLASS(dummy) == Data_Obj) {
03047 tmp_dv_idx = gen_compiler_tmp(opnd_line,
03048 opnd_column,
03049 Priv,
03050 TRUE);
03051 ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(dummy);
03052 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03053 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE;
03054 ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(dummy);
03055 ATD_POINTER(tmp_dv_idx) = TRUE;
03056 ATD_IM_A_DOPE(tmp_dv_idx) = TRUE;
03057
03058 gen_opnd(&dv_opnd,
03059 tmp_dv_idx,
03060 AT_Tbl_Idx,
03061 opnd_line,
03062 opnd_column);
03063 gen_dv_whole_def_init(&dv_opnd,
03064 tmp_dv_idx,
03065 Before);
03066
03067 if (ATD_ARRAY_IDX(dummy) == NULL_IDX) {
03068 arg_info_list[info_idx].ed.rank = 0;
03069 }
03070 else {
03071 arg_info_list[info_idx].ed.rank = BD_RANK(ATD_ARRAY_IDX(dummy));
03072 }
03073 arg_info_list[info_idx].ed.type_idx = ATD_TYPE_IDX(dummy);
03074 arg_info_list[info_idx].ed.type = TYP_TYPE(ATD_TYPE_IDX(dummy));
03075 arg_info_list[info_idx].ed.linear_type =
03076 TYP_LINEAR(ATD_TYPE_IDX(dummy));
03077 arg_info_list[info_idx].ed.pointer = TRUE;
03078 arg_info_list[info_idx].ed.tmp_reference = TRUE;
03079
03080 gen_opnd(&dv_opnd,
03081 gen_ir(AT_Tbl_Idx,
03082 tmp_dv_idx,
03083 Dv_Deref_Opr,
03084 arg_info_list[info_idx].ed.type_idx,
03085 opnd_line,
03086 opnd_column,
03087 NO_Tbl_Idx,
03088 NULL_IDX),
03089 IR_Tbl_Idx,
03090 opnd_line,
03091 opnd_column);
03092
03093 if (arg_info_list[info_idx].ed.rank > 0) {
03094 ok = gen_whole_subscript(&dv_opnd, &arg_info_list[info_idx].ed);
03095 }
03096
03097 IL_IDX(list_idx) = OPND_IDX(dv_opnd);
03098 IL_FLD(list_idx) = OPND_FLD(dv_opnd);
03099 }
03100 else {
03101 tmp_dv_idx = gen_compiler_tmp(opnd_line,
03102 opnd_column,
03103 Priv,
03104 TRUE);
03105 ATD_TYPE_IDX(tmp_dv_idx) = TYPELESS_DEFAULT_TYPE;
03106 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
03107 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE;
03108 ATD_ARRAY_IDX(tmp_dv_idx) = NULL_IDX;
03109 ATD_POINTER(tmp_dv_idx) = TRUE;
03110 ATD_IM_A_DOPE(tmp_dv_idx) = TRUE;
03111
03112 gen_opnd(&dv_opnd,
03113 tmp_dv_idx,
03114 AT_Tbl_Idx,
03115 opnd_line,
03116 opnd_column);
03117 gen_dv_whole_def_init(&dv_opnd,
03118 tmp_dv_idx,
03119 Before);
03120
03121 arg_info_list[info_idx].ed.rank = 0;
03122 arg_info_list[info_idx].ed.type_idx = TYPELESS_DEFAULT_TYPE;
03123 arg_info_list[info_idx].ed.linear_type =
03124 TYP_LINEAR(TYPELESS_DEFAULT_TYPE);
03125 arg_info_list[info_idx].ed.pointer = TRUE;
03126 arg_info_list[info_idx].ed.tmp_reference = TRUE;
03127
03128 gen_opnd(&dv_opnd,
03129 gen_ir(AT_Tbl_Idx,
03130 tmp_dv_idx,
03131 Dv_Deref_Opr,
03132 arg_info_list[info_idx].ed.type_idx,
03133 opnd_line,
03134 opnd_column,
03135 NO_Tbl_Idx,
03136 NULL_IDX),
03137 IR_Tbl_Idx,
03138 opnd_line,
03139 opnd_column);
03140
03141 if (arg_info_list[info_idx].ed.rank > 0) {
03142 ok = gen_whole_subscript(&dv_opnd, &arg_info_list[info_idx].ed);
03143 }
03144
03145 IL_IDX(list_idx) = OPND_IDX(dv_opnd);
03146 IL_FLD(list_idx) = OPND_FLD(dv_opnd);
03147 }
03148 }
03149
03150 # endif
03151
03152 a_type = get_act_arg_type(&arg_info_list[info_idx].ed);
03153
03154 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
03155 &line,
03156 &col);
03157
03158 #if 0
03159
03160
03161
03162 if (! AT_IS_INTRIN(spec_idx) &&
03163 dummy != NULL_IDX &&
03164 AT_OBJ_CLASS(dummy) == Data_Obj &&
03165 IR_OPR(dummy) != Call_Opr ) {
03166
03167
03168
03169 if (ATD_AUXILIARY(dummy)) {
03170
03171 if (arg_assoc_tbl[a_type][d_type] != PASS_ADDRESS) {
03172 PRINTMSG(line, 627, Warning, col,
03173 AT_OBJ_NAME_PTR(dummy));
03174 }
03175 else {
03176
03177 COPY_OPND(opnd, IL_OPND(list_idx));
03178 attr_idx = find_left_attr(&opnd);
03179
03180 if (! ATD_AUXILIARY(attr_idx)) {
03181 PRINTMSG(line, 627, Warning, col,
03182 AT_OBJ_NAME_PTR(dummy));
03183 }
03184 }
03185 }
03186 else if (arg_assoc_tbl[a_type][d_type] == PASS_ADDRESS) {
03187 COPY_OPND(opnd, IL_OPND(list_idx));
03188 attr_idx = find_left_attr(&opnd);
03189
03190 if (ATD_AUXILIARY(attr_idx)) {
03191 PRINTMSG(line, 620, Warning, col,
03192 AT_OBJ_NAME_PTR(dummy));
03193 }
03194 }
03195 }
03196
03197 # endif
03198 association = arg_assoc_tbl[a_type][d_type];
03199
03200 if (association == PASS_ADDRESS_FROM_DV &&
03201 # ifdef _TRANSFORM_CHAR_SEQUENCE
03202 (arg_info_list[info_idx].ed.type == Character ||
03203 (arg_info_list[info_idx].ed.type == Structure &&
03204 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx)))))
03205 # else
03206 arg_info_list[info_idx].ed.type == Character)
03207 # endif
03208 {
03209
03210 association = PASS_ADDRESS;
03211 }
03212 else if (association == PASS_ADDRESS &&
03213 IL_FLD(list_idx) == AT_Tbl_Idx &&
03214 AT_OBJ_CLASS(IL_IDX(list_idx)) == Data_Obj &&
03215 ATD_LIVE_DO_VAR(IL_IDX(list_idx))) {
03216
03217
03218 association = COPY_IN;
03219 }
03220
03221 if (arg_info_list[info_idx].ed.rank > 0 &&
03222 ATP_ELEMENTAL(spec_idx)) {
03223
03224 if (association == PASS_ADDRESS_FROM_DV ||
03225 association == CHECK_CONTIG_FLAG ||
03226 association == COPY_IN_COPY_OUT ||
03227 association == PASS_SECTION_ADDRESS) {
03228
03229 association = PASS_ADDRESS;
03230 }
03231 }
03232
03233 # if defined(GENERATE_WHIRL)
03234 if (association == CHECK_CONTIG_FLAG &&
03235 arg_info_list[info_idx].ed.type == Character) {
03236
03237 association = COPY_IN_COPY_OUT;
03238 }
03239 # endif
03240
03241 # if defined(COARRAY_FORTRAN)
03242 if (dummy != NULL_IDX &&
03243 AT_OBJ_CLASS(dummy) == Data_Obj &&
03244 ATD_PE_ARRAY_IDX(dummy) != NULL_IDX) {
03245
03246 if (arg_info_list[info_idx].ed.reference) {
03247 attr_idx = find_left_attr(&IL_OPND(list_idx));
03248
03249 if (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
03250 ATD_PE_ARRAY_IDX(attr_idx) == NULL_IDX) {
03251
03252 PRINTMSG(line, 1584, Error, col);
03253 }
03254 }
03255 else {
03256 PRINTMSG(line, 1584, Error, col);
03257 }
03258 }
03259 # endif
03260
03261 arg_info_list[info_idx].association = association;
03262 switch (association) {
03263 case ERROR_ASSOC :
03264 break;
03265
03266 case PASS_ADDRESS :
03267
03268 # if 0
03269 # if defined(GENERATE_WHIRL)
03270 ATD_NOT_PT_UNIQUE_MEM(
03271 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
03272 # endif
03273
03274 if (! ATP_VFUNCTION(spec_idx) &&
03275 ! arg_info_list[info_idx].ed.percent_val_arg) {
03276
03277
03278
03279 if (arg_info_list[info_idx].ed.rank != 0 &&
03280 ! ATP_ELEMENTAL(spec_idx)) {
03281
03282 # ifndef _FRONTEND_INLINER
03283 if (IL_FLD(list_idx) == IR_Tbl_Idx) {
03284
03285 ir_idx = IL_IDX(list_idx);
03286
03287 if (IR_OPR(ir_idx) == Whole_Subscript_Opr) {
03288 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(ir_idx));
03289 }
03290 }
03291 # endif
03292
03293 if ((IL_FLD(list_idx) == AT_Tbl_Idx &&
03294 BD_ARRAY_CLASS(ATD_ARRAY_IDX(IL_IDX(list_idx))) ==
03295 Assumed_Size) ||
03296 (arg_info_list[info_idx].ed.type == Character &&
03297 IR_FLD_L(IL_IDX(list_idx)) == AT_Tbl_Idx &&
03298 BD_ARRAY_CLASS(ATD_ARRAY_IDX(IR_IDX_L(
03299 IL_IDX(list_idx)))) == Assumed_Size)) {
03300
03301 if (arg_info_list[info_idx].ed.type == Character) {
03302 COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx)));
03303 make_base_assumed_size(&opnd, &base_opnd);
03304 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), base_opnd);
03305 }
03306 else {
03307 COPY_OPND(opnd, IL_OPND(list_idx));
03308 make_base_assumed_size(&opnd, &base_opnd);
03309 COPY_OPND(IL_OPND(list_idx), base_opnd);
03310 }
03311
03312 if (a_type == Whole_Sequence ||
03313 a_type == Whole_Allocatable) {
03314
03315 if (OPND_FLD(base_opnd) == IR_Tbl_Idx &&
03316 IR_OPR(OPND_IDX(base_opnd)) == Subscript_Opr) {
03317 IR_WHOLE_ARRAY(OPND_IDX(base_opnd)) = TRUE;
03318 }
03319 }
03320 }
03321 else {
03322
03323 if (a_type == Whole_Sequence ||
03324 a_type == Whole_Allocatable) {
03325
03326 COPY_OPND(opnd, IL_OPND(list_idx));
03327
03328 while (OPND_FLD(opnd) == IR_Tbl_Idx) {
03329
03330 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
03331 IR_WHOLE_ARRAY(OPND_IDX(opnd)) = TRUE;
03332 break;
03333 }
03334
03335 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
03336 }
03337 }
03338
03339 COPY_OPND(opnd, IL_OPND(list_idx));
03340 unused1 = NULL_IDX;
03341 unused2 = NULL_IDX;
03342 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2);
03343 COPY_OPND(IL_OPND(list_idx), base_opnd);
03344 }
03345 }
03346
03347 NTR_IR_TBL(ir_idx);
03348 IR_OPR(ir_idx) = Aloc_Opr;
03349 IR_TYPE_IDX(ir_idx) = (arg_info_list[info_idx].ed.type ==
03350 Character)
03351 ? CRI_Ch_Ptr_8 : CRI_Ptr_8;
03352 IR_LINE_NUM(ir_idx) = line;
03353 IR_COL_NUM(ir_idx) = col;
03354
03355 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx));
03356 IL_FLD(list_idx) = IR_Tbl_Idx;
03357 IL_IDX(list_idx) = ir_idx;
03358
03359 # ifdef _TRANSFORM_CHAR_SEQUENCE
03360 if (arg_info_list[info_idx].ed.type == Structure &&
03361 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
03362
03363 COPY_OPND(opnd, IR_OPND_L(ir_idx));
03364 transform_char_sequence_ref(&opnd,
03365 arg_info_list[info_idx].ed.type_idx);
03366 COPY_OPND(IR_OPND_L(ir_idx), opnd);
03367
03368 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
03369 }
03370 # endif
03371 }
03372 # endif
03373
03374 break;
03375
03376 case PASS_SECTION_ADDRESS :
03377
03378 # if defined(GENERATE_WHIRL)
03379 ATD_NOT_PT_UNIQUE_MEM(
03380 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
03381 # endif
03382 # if 0
03383
03384
03385
03386
03387
03388
03389 COPY_OPND(opnd, IL_OPND(list_idx));
03390 unused1 = NULL_IDX;
03391 unused2 = NULL_IDX;
03392 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2);
03393 COPY_OPND(opnd, base_opnd);
03394
03395 NTR_IR_TBL(ir_idx);
03396 IR_OPR(ir_idx) = Aloc_Opr;
03397 IR_TYPE_IDX(ir_idx) = (arg_info_list[info_idx].ed.type ==
03398 Character)
03399 ? CRI_Ch_Ptr_8 : CRI_Ptr_8;
03400 IR_LINE_NUM(ir_idx) = line;
03401 IR_COL_NUM(ir_idx) = col;
03402
03403 COPY_OPND(IR_OPND_L(ir_idx), opnd);
03404 IL_FLD(list_idx) = IR_Tbl_Idx;
03405 IL_IDX(list_idx) = ir_idx;
03406
03407 # ifdef _TRANSFORM_CHAR_SEQUENCE
03408 if (arg_info_list[info_idx].ed.type == Structure &&
03409 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) {
03410
03411 COPY_OPND(opnd, IR_OPND_L(ir_idx));
03412 transform_char_sequence_ref(&opnd,
03413 arg_info_list[info_idx].ed.type_idx);
03414 COPY_OPND(IR_OPND_L(ir_idx), opnd);
03415
03416 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8;
03417 }
03418 # endif
03419
03420 # endif
03421
03422 break;
03423
03424
03425
03426 case PASS_ADDRESS_FROM_DV :
03427
03428 # if defined(GENERATE_WHIRL)
03429 ATD_NOT_PT_UNIQUE_MEM(
03430 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
03431 # endif
03432
03433
03434 if (! ATP_VFUNCTION(spec_idx) &&
03435 ! arg_info_list[info_idx].ed.percent_val_arg) {
03436
03437 NTR_IR_TBL(ir_idx);
03438 IR_OPR(ir_idx) = Dv_Access_Base_Addr;
03439 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE;
03440 IR_LINE_NUM(ir_idx) = line;
03441 IR_COL_NUM(ir_idx) = col;
03442
03443 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
03444 IR_OPR(IL_IDX(list_idx)) == Whole_Substring_Opr) {
03445 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
03446 }
03447
03448 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
03449 IR_OPR(IL_IDX(list_idx)) == Whole_Subscript_Opr) {
03450 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
03451 }
03452 # if 0
03453
03454 if (IL_FLD(list_idx) != IR_Tbl_Idx ||
03455 IR_OPR(IL_IDX(list_idx)) != Dv_Deref_Opr) {
03456
03457 PRINTMSG(line, 861, Internal, col,
03458 "final_arg_work");
03459 }
03460 #endif
03461
03462 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IL_IDX(list_idx)));
03463
03464 if (cmd_line_flags.runtime_ptr_chk) {
03465 COPY_OPND(opnd, IR_OPND_L(ir_idx));
03466 gen_runtime_ptr_chk(&opnd);
03467 }
03468
03469 IL_FLD(list_idx) = IR_Tbl_Idx;
03470 IL_IDX(list_idx) = ir_idx;
03471 }
03472
03473 arg_info_list[info_idx].ed.dope_vector = FALSE;
03474 arg_info_list[info_idx].ed.pointer = FALSE;
03475
03476 break;
03477
03478 case PASS_DV :
03479
03480 # if 0
03481 # if defined(GENERATE_WHIRL)
03482 ATD_NOT_PT_UNIQUE_MEM(
03483 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
03484 # endif
03485
03486 NTR_IR_TBL(ir_idx);
03487 IR_OPR(ir_idx) = Aloc_Opr;
03488 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8;
03489 IR_LINE_NUM(ir_idx) = line;
03490 IR_COL_NUM(ir_idx) = col;
03491
03492 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
03493 IR_OPR(IL_IDX(list_idx)) == Whole_Substring_Opr) {
03494 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
03495 }
03496
03497 if (IL_FLD(list_idx) == IR_Tbl_Idx &&
03498 IR_OPR(IL_IDX(list_idx)) == Whole_Subscript_Opr) {
03499 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx)));
03500 }
03501
03502 # if 0
03503
03504 if (IL_FLD(list_idx) != IR_Tbl_Idx ||
03505 IR_OPR(IL_IDX(list_idx)) != Dv_Deref_Opr) {
03506
03507 PRINTMSG(line, 861, Internal, col,
03508 "final_arg_work");
03509 }
03510 # endif
03511
03512 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(IL_IDX(list_idx)));
03513
03514 IL_FLD(list_idx) = IR_Tbl_Idx;
03515 IL_IDX(list_idx) = ir_idx;
03516 # endif
03517
03518 break;
03519
03520 case PASS_DV_COPY :
03521
03522 # if 0
03523 if (AT_OPTIONAL(dummy) &&
03524 arg_info_list[info_idx].ed.optional_darg) {
03525
03526
03527
03528 COPY_OPND(opnd, IL_OPND(list_idx));
03529 present_idx = gen_ir(AT_Tbl_Idx, find_left_attr(&opnd),
03530 Present_Opr, LOGICAL_DEFAULT_TYPE, line, col,
03531 NO_Tbl_Idx, NULL_IDX);
03532
03533 gen_opnd(&cond_opnd,
03534 present_idx,
03535 IR_Tbl_Idx,
03536 line,
03537 col);
03538
03539
03540 true_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03541 true_end_sh_idx = curr_stmt_sh_idx;
03542
03543
03544
03545 tmp_dv_idx = create_tmp_DV_asg(list_idx, info_idx);
03546
03547 # if defined(GENERATE_WHIRL)
03548 ATD_NOT_PT_UNIQUE_MEM(tmp_dv_idx) = TRUE;
03549 ATD_NOT_PT_UNIQUE_MEM(
03550 (find_left_attr(&IL_OPND(list_idx)))) = TRUE;
03551 # endif
03552
03553
03554
03555 GEN_COMPILER_TMP_ASG(asg_idx,
03556 tmp_loc_idx,
03557 TRUE,
03558 line,
03559 col,
03560 SA_INTEGER_DEFAULT_TYPE,
03561 Priv);
03562
03563 ir_idx = gen_ir(AT_Tbl_Idx, tmp_dv_idx,
03564 Loc_Opr, CRI_Ptr_8, line, col,
03565 NO_Tbl_Idx, NULL_IDX);
03566
03567 IR_FLD_R(asg_idx) = IR_Tbl_Idx;
03568 IR_IDX_R(asg_idx) = ir_idx;
03569 IR_LINE_NUM_R(asg_idx) = line;
03570 IR_COL_NUM_R(asg_idx) = col;
03571
03572 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03573
03574 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
03575 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03576
03577 true_start_sh_idx = SH_NEXT_IDX(true_start_sh_idx);
03578 true_end_sh_idx = SH_PREV_IDX(true_end_sh_idx);
03579
03580
03581
03582 asg_idx = gen_ir(AT_Tbl_Idx, tmp_loc_idx,
03583 Asg_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
03584 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
03585
03586 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03587
03588 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
03589 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03590
03591 false_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03592 false_end_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03593
03594 gen_if_stmt(&cond_opnd,
03595 true_start_sh_idx,
03596 true_end_sh_idx,
03597 false_start_sh_idx,
03598 false_end_sh_idx,
03599 line,
03600 col);
03601
03602
03603
03604 IL_FLD(list_idx) = AT_Tbl_Idx;
03605 IL_IDX(list_idx) = tmp_loc_idx;
03606 IL_LINE_NUM(list_idx) = line;
03607 IL_COL_NUM(list_idx) = col;
03608 }
03609 else {
03610
03611 tmp_dv_idx = create_tmp_DV_asg(list_idx, info_idx);
03612
03613 # if defined(GENERATE_WHIRL)
03614