|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 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" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 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 |* function prototypes of static functions declared in this file *| 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 |* Description: *| 00112 |* Process function and subroutine calls, both generic and specific. *| 00113 |* *| 00114 |* Input parameters: *| 00115 |* result_opnd - opnd pointing to call opr. *| 00116 |* is_function - call is a function call. *| 00117 |* *| 00118 |* Output parameters: *| 00119 |* result_opnd - output tree (usually a tmp reference) *| 00120 |* res_exp_desc - expression descriptor that descibes the call. *| 00121 |* *| 00122 |* Returns: *| 00123 |* TRUE if everything ok. *| 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 /* do memory management stuff to make sure the tables are big enough */ 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 /* Issue ANSI - Cray allows external function calls here. */ 00325 /* F95 allows some of the functions here now. Check */ 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 /* This darg is not at all entry points. Add to a list for */ 00337 /* this specification expression. This only happens if there */ 00338 /* are alternate entry points and bounds expressions. */ 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 /* error .. should be function but isn't */ 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 /* error .. should be Subroutine but isn't */ 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 /* error .. can't have this call */ 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 /* process all the arguments thru expr_semantics */ 00515 /* hang on to type etc. Catch errors. */ 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 /* so we don't issue errors that should not be issued */ 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 /* error for call list */ 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 /*keep Kwd_Opr--FMZ*/ 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 /*FMZ August 2005*/ 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 /*FMZ August*/ 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)) { /* All args must be integer */ 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 /* intentionally blank - will fold certain other intrinsics */ 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 } /* End switch */ 00685 } 00686 00687 if (IL_FLD(list_idx) == AT_Tbl_Idx && 00688 AT_OBJ_CLASS(IL_IDX(list_idx)) == Pgm_Unit) { 00689 00690 /* check for external requirement */ 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 /* set up what the implicit type would be if function */ 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 /* error .. procedure must be EXTERNAL, in an interface block */ 00720 /* or be a module procedure to be used as an actual argument. */ 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 /* the io_item_must_flatten flag should not be passed back for*/ 00767 /* actual arguments. Restore the flag to it's previous value. */ 00768 /* oh, unless this is an intrinsic. */ 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 /* error .. already have this argument */ 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 /* error .. not an argument to this interface */ 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 { /* put in same place */ 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 /* error .. already have this argument */ 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; /* arguments are not allowed */ 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 /* if everything was alright, (otherwise I wouldn't be here) */ 00935 /* put argument in proper location and hang on to info idx */ 00936 00937 arg_list[arg_idx] = list_idx; 00938 00939 /* check for label/alternate return match */ 00940 00941 if (AT_COMPILER_GEND(arg_attr) && AT_IS_DARG(arg_attr)) { 00942 00943 /* Set flag on the attr of the subroutine being called */ 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) { /* error .. expected a label */ 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) { /* error .. actual is label */ 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 /* check type and rank */ 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) { /* Comparing darg and actual arg */ 00988 ok = FALSE; /* An error was issued. */ 00989 } 00990 else { /* Looking for a specific. */ 00991 goto CYCLE; /* This one does not match. */ 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 /* check to see if it's optional */ 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 /* error .. no argument for this dummy arg */ 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 /* if I'm here, then I've found the right one */ 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 /* change call attr to right one */ 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 /* don't have explicit interface */ 01070 spec_idx = gen_idx; 01071 } 01072 01073 EXIT: 01074 01075 if (found) { 01076 01077 if (ok) { 01078 01079 /* Keep the CIF Call Site record first. */ 01080 /* See the explanation in s_utils.c at the call to cif_call_site_rec */ 01081 /* for the reasoning behind checking xref_state. */ 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 /* don't do any further processing on this bad boy */ 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 /* Check to make sure all actual args that are procedures are PURE*/ 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 /* if intrinsic is a constant, change the result_opnd to 01199 be the new one, otherwise keep the old form */ 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 /* Now that the types for the function result, etc. have */ 01250 /* been resolved, if the procedure is a function, the */ 01251 /* Object record that represents the function result can */ 01252 /* now be output. */ 01253 /* An intrinsic procedure that is NOT specified as the */ 01254 /* generic name on an interface block is "special" and is */ 01255 /* the only case where cif_call_site_rec outputs the Entry */ 01256 /* record immediately. In all other cases the CIF symbol id*/ 01257 /* is just set and the Entry Point and Object (for result) */ 01258 /* records are output with all other records as we go */ 01259 /* through the Attrs in cif_send_sytb. */ 01260 /* Found with SPR 94823, The reason such an intrinsic is */ 01261 /* "special" is that some intrinsic functions have result */ 01262 /* types that vary from invocation to invocation. Since */ 01263 /* there is only one result Attr entry for all invocations, */ 01264 /* the Object record must be output right now to get the */ 01265 /* result type correct. Tools such as cflist are especially*/ 01266 /* anxious to have the result type for each invocation. */ 01267 /* All other functions (particularly user functions) can, */ 01268 /* of course, only have one result type so these result */ 01269 /* Object records can be output later as a part of */ 01270 /* processing the Entry Point definition record for the */ 01271 /* function. */ 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 /* Now that the types for the function result, etc. have been */ 01289 /* resolved, if the procedure is a function, the Object */ 01290 /* record that represents the function result can now be */ 01291 /* output. */ 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 /* put the specific attr in the local scope */ 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 /* Create the result attr. It's in the local scope */ 01316 /* thru the function name. */ 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) && /* March */ 01337 FALSE) { 01338 01339 ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_DARG_IDX(curr_scp_idx); 01340 01341 /* Insert the function result as the zero'th darg */ 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 /* Not visible is checked, because a not visible procedure */ 01372 /* may be referenced via its interface name, even though */ 01373 /* it cannot be referenced via its own name. */ 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 /* This attr is not in this scope. It is either host */ 01382 /* associated here, via the interface block, or it is */ 01383 /* USE_ASSOCIATED, but is not in the local symbol table. */ 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; /* March */ 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; /* March */ 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 /* April IR_RANK(ir_idx) = 0; */ 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 /* flatten_function_call cannot work on intrinsic function * 01493 * need think about how to change it ---fzhao Jan */ 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 /* Now that the types for the function result, etc. have been */ 01503 /* resolved, if the procedure is a function, the Object */ 01504 /* record that represents the function result can now be */ 01505 /* output. */ 01506 01507 if (ATP_PROC(spec_idx) == Intrin_Proc && 01508 ! ATI_USER_SPECIFIED(gen_idx) && 01509 (cif_flags & MISC_RECS) != 0 && 01510 FALSE && /* April */ 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) { /* April */ 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) { /* April&& !AT_ELEMENTAL_INTRIN(spec_idx)) { */ 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) { /* April */ 01548 set_shape_for_deferred_funcs(res_exp_desc, ir_idx); 01549 01550 if (AT_IS_INTRIN(spec_idx) && 01551 FALSE && /* April */ 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 /* do the alternate return thing */ 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 /* this was done for functions under flatten_func_call */ 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 /* April ATP_PROC(spec_idx) != Intrin_Proc && */ 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 /* Check to make sure that actual arguments are definable if */ 01764 /* the dummy arg has INTENT(out), INTENT(inout) or POINTER. */ 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 /* Intentional fall through */ 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: /* Intrinsic not allowed in specification expression. */ 01888 PRINTMSG(line, 870, Error, col, AT_OBJ_NAME_PTR(gen_idx)); 01889 ok = FALSE; 01890 break; 01891 } 01892 } 01893 else { /* elemental */ 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 } /* call_list_semantics */ 01989 01990 /******************************************************************************\ 01991 |* *| 01992 |* Description: *| 01993 |* <description> *| 01994 |* *| 01995 |* Input parameters: *| 01996 |* NONE *| 01997 |* *| 01998 |* Output parameters: *| 01999 |* NONE *| 02000 |* *| 02001 |* Returns: *| 02002 |* NOTHING *| 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 /* this had better be the function call. */ 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 /* check the arguments for array temps. */ 02047 /* they are either array expressions to be masked, */ 02048 /* or they are call temps. */ 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 } /* check_for_elementals */ 02093 02094 /******************************************************************************\ 02095 |* *| 02096 |* Description: *| 02097 |* <description> *| 02098 |* *| 02099 |* Input parameters: *| 02100 |* NONE *| 02101 |* *| 02102 |* Output parameters: *| 02103 |* NONE *| 02104 |* *| 02105 |* Returns: *| 02106 |* NOTHING *| 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 } /* check_expr_for_elementals */ 02160 02161 /******************************************************************************\ 02162 |* *| 02163 |* Description: *| 02164 |* <description> *| 02165 |* *| 02166 |* Input parameters: *| 02167 |* NONE *| 02168 |* *| 02169 |* Output parameters: *| 02170 |* NONE *| 02171 |* *| 02172 |* Returns: *| 02173 |* NOTHING *| 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 /* list 1 = routine attr */ 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 /* list 2 = lhs (first arg) */ 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 /* list 3 = mask */ 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 /* list 4 = rhs (second arg) */ 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 /* list 1 = lhs */ 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 /* list 2 = mask */ 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 /* list 3 = rhs */ 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 } /* change_asg_to_where */ 02255 02256 /******************************************************************************\ 02257 |* *| 02258 |* Description: *| 02259 |* Do all the call site processing for the call list. This includes *| 02260 |* copy in/copy out for array arguments, copy in for expressions and *| 02261 |* passing the correct actual arg(target, address, dope vector). *| 02262 |* *| 02263 |* Input parameters: *| 02264 |* start_list - first list text in call list. *| 02265 |* spec_idx - attr idx for callee. *| 02266 |* num_args - num args. *| 02267 |* *| 02268 |* Output parameters: *| 02269 |* NONE *| 02270 |* *| 02271 |* Returns: *| 02272 |* NOTHING *| 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; /* this is the main loop index */ 02303 int info_idx; 02304 int intent; 02305 boolean io_call = FALSE; 02306 int ir_idx; 02307 long k; /* available for small loop index */ 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) { /*need change here 02372 *since we put result in darg_list 02373 *will think about it later 02374 * fzhao July 02375 */ 02376 /* check that number of args matches number of dargs */ 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 /*don't know why we need "check_call_for_global_def" 02410 will think about it later---fzhao Oct */ 02411 02412 if (!ATP_EXPL_ITRFC(spec_idx) && /* Global semantics */ 02413 !io_call && 02414 !AT_COMPILER_GEND(spec_idx)) { 02415 02416 /* Make sure this is not defined in this program unit and that */ 02417 /* it is not an intrinsic. Also get rid of stuff like _END */ 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 /* replace with zero */ 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 /* don't advance to the next dummy argument */ 02447 /* this is for intrinsic processing */ 02448 02449 goto EXIT; 02450 } 02451 02452 /* if the arg is intrinsic function call then keep it, 02453 * do not do anything,go to EXIT ---fzhao Jan 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 /* replace with zero */ 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 /* create a zero fcd */ 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 /* info_idx = IL_ARG_DESC_IDX(list_idx); */ 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 /* change label ref to zero constant */ 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 /* this is io alternate return */ 02604 /* they expect a -1 address, not address of -1 */ 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 /* place checks here that need to be done after generic resolution */ 02697 02698 if (ATD_POINTER(dummy) && 02699 ! arg_info_list[info_idx].ed.pointer) { 02700 02701 /* pointer dummy requires pointer actual */ 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 /* This section is for the target dummy arg constraint. */ 02716 /* I'm going to save it just in case the interp changes.*/ 02717 /* BHJ DOPE VECTOR TARGET */ 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 /* assumed size array to an assumed shape dummy array */ 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 /* if INTENT(out) or INTENT(inout), actual must be */ 02751 /* defineable. */ 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 /*FMZ August 2005*/ 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 /* check for array/character size overlap */ 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 /* Set up the new const table entry. Pass ntr_const_tbl */ 02992 /* a null pointer so the caller can move the constant. */ 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 /* this code cause trouble when the arguments are function call 03160 * will think about how to keep the semantics later fzhao Jan 03161 */ 03162 if (! AT_IS_INTRIN(spec_idx) && 03163 dummy != NULL_IDX && 03164 AT_OBJ_CLASS(dummy) == Data_Obj && /*fzhao Jan*/ 03165 IR_OPR(dummy) != Call_Opr ) { 03166 03167 /* check for auxiliary match */ 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 /* you cannot modify a live do loop lcv, so make it a copy in */ 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 /* JBL - this is for array element change */ 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 /*we need keep arrsection for whirl2f dumpout correct 03383 *actual arguments,otherwise it will dumpout the firset 03384 *element of the array section 03385 *-z 03386 */ 03387 /* these are always arrays, no need for %val() or vfunction chks */ 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 /* IL_FLD could be NO_Tbl_Idx for deferred_Shape array referenced */ 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 /* March */ 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 /* IL_FLD could be NO_Tbl_Idx for deferred_shape array referenced */ 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 /* March */ 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 /* generate if stmt for present(arg) */ 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 /* save the bounding stmts. these are moved in later. */ 03540 true_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 03541 true_end_sh_idx = curr_stmt_sh_idx; 03542 03543 /* put work here */ 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 /* gen loc tmp = loc(tmp_dv_idx) */ 03554 03555 GEN_COMPILER_TMP_ASG(asg_idx, 03556 tmp_loc_idx, 03557 TRUE, /* Semantics done */ 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 /* gen the loc tmp = 0 stmt. */ 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 /* put loc tmp into arg */ 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 ATD_NOT_PT_UNIQUE_MEM(tmp_dv_idx) = TRUE; 03615 ATD_NOT_PT_UNIQUE_MEM( 03616 (find_left_attr(&IL_OPND(list_idx)))) = TRUE; 03617 # endif 03618 03619 03620 NTR_IR_TBL(ir_idx); 03621 IR_OPR(ir_idx) = Aloc_Opr; 03622 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 03623 IR_LINE_NUM(ir_idx) = line; 03624 IR_COL_NUM(ir_idx) = col; 03625 IL_FLD(list_idx) = IR_Tbl_Idx; 03626 IL_IDX(list_idx) = ir_idx; 03627 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 03628 IR_IDX_L(ir_idx) = tmp_dv_idx; 03629 IR_LINE_NUM_L(ir_idx) = line; 03630 IR_COL_NUM_L(ir_idx) = col; 03631 } 03632 # endif 03633 break; 03634 03635 case COPY_IN : 03636 03637 if (IL_FLD(list_idx) == CN_Tbl_Idx && 03638 ! io_call && 03639 # ifdef _TARGET_OS_MAX 03640 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Integer_1 && 03641 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Integer_2 && 03642 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Integer_4 && 03643 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Logical_1 && 03644 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Logical_2 && 03645 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Logical_4 && 03646 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Real_4 && 03647 TYP_LINEAR(CN_TYPE_IDX(IL_IDX(list_idx))) != Complex_4 && 03648 03649 # endif 03650 /*I don't think we need Const_Tmp_Loc_Opr for Integer,Real and Logical 03651 * type,and if use this operator,it's difficult to declare "LOGICAL" 03652 * arguments 03653 * fzhao 03654 * 03655 * TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Integer || 03656 * TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Logical || 03657 * TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Real || 03658 */ 03659 03660 # if defined(GENERATE_WHIRL) 03661 03662 ((TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Character && 03663 ! on_off_flags.pad_char_literals) || 03664 # endif 03665 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Complex)) { 03666 03667 /* just use Const_Tmp_Loc_Opr */ 03668 /* if %val(), just leave the constant as is */ 03669 03670 if (! ATP_VFUNCTION(spec_idx) && 03671 ! arg_info_list[info_idx].ed.percent_val_arg) { 03672 NTR_IR_TBL(ir_idx); 03673 IR_OPR(ir_idx) = Const_Tmp_Loc_Opr; 03674 IR_TYPE_IDX(ir_idx) = CN_TYPE_IDX(IL_IDX(list_idx)); 03675 IR_LINE_NUM(ir_idx) = line; 03676 IR_COL_NUM(ir_idx) = col; 03677 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx)); 03678 IL_FLD(list_idx) = IR_Tbl_Idx; 03679 IL_IDX(list_idx) = ir_idx; 03680 } 03681 03682 break; 03683 } 03684 03685 if (IL_FLD(list_idx) == CN_Tbl_Idx && 03686 arg_info_list[info_idx].ed.type == Character && 03687 dummy == NULL_IDX && 03688 compare_cn_and_value(TYP_IDX(arg_info_list[info_idx].ed.type_idx), 03689 # if defined(GENERATE_WHIRL) 03690 storage_bit_size_tbl[INTEGER_DEFAULT_TYPE]/8, 03691 # else 03692 TARGET_CHARS_PER_WORD, 03693 # endif 03694 Lt_Opr)) { 03695 03696 exp_desc = arg_info_list[info_idx].ed; 03697 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 03698 03699 TYP_TYPE(TYP_WORK_IDX) = Character; 03700 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 03701 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 03702 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 03703 03704 # if defined(GENERATE_WHIRL) 03705 the_constant = storage_bit_size_tbl[INTEGER_DEFAULT_TYPE]/8; 03706 # else 03707 the_constant = TARGET_CHARS_PER_WORD; 03708 # endif 03709 TYP_IDX(TYP_WORK_IDX)= C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 03710 the_constant); 03711 03712 exp_desc.type_idx = ntr_type_tbl(); 03713 exp_desc.char_len.fld = CN_Tbl_Idx; 03714 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx); 03715 03716 OPND_FLD(opnd) = CN_Tbl_Idx; 03717 OPND_IDX(opnd) = ntr_const_tbl(exp_desc.type_idx, 03718 TRUE, 03719 NULL); 03720 03721 OPND_LINE_NUM(opnd) = line; 03722 OPND_COL_NUM(opnd) = col; 03723 03724 char_ptr1 = (char *)&CN_CONST(IL_IDX(list_idx)); 03725 char_ptr2 = (char *)&CN_CONST(OPND_IDX(opnd)); 03726 03727 for (k = 0; 03728 k<CN_INT_TO_C(TYP_IDX(arg_info_list[info_idx].ed.type_idx)); 03729 k++) { 03730 char_ptr2[k] = char_ptr1[k]; 03731 } 03732 03733 for ( ; k < CN_INT_TO_C(TYP_IDX(exp_desc.type_idx)); k++) { 03734 char_ptr2[k] = ' '; 03735 } 03736 03737 tmp_idx = create_tmp_asg(&opnd, 03738 &exp_desc, 03739 &l_opnd, 03740 Intent_In, 03741 TRUE, 03742 FALSE); 03743 03744 NTR_IR_TBL(ir_idx); 03745 IR_OPR(ir_idx) = Aloc_Opr; 03746 IR_LINE_NUM(ir_idx) = line; 03747 IR_COL_NUM(ir_idx) = col; 03748 03749 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 03750 03751 IL_FLD(list_idx) = IR_Tbl_Idx; 03752 IL_IDX(list_idx) = ir_idx; 03753 03754 NTR_IR_TBL(unused1); 03755 IR_OPR(unused1) = Substring_Opr; 03756 IR_TYPE_IDX(unused1) = arg_info_list[info_idx].ed.type_idx; 03757 IR_FLD_L(unused1) = AT_Tbl_Idx; 03758 IR_IDX_L(unused1) = tmp_idx; 03759 IR_LINE_NUM_L(unused1) = line; 03760 IR_COL_NUM_L(unused1) = col; 03761 IR_LINE_NUM(unused1) = line; 03762 IR_COL_NUM(unused1) = col; 03763 03764 NTR_IR_LIST_TBL(list_idx2); 03765 IR_FLD_R(unused1) = IL_Tbl_Idx; 03766 IR_IDX_R(unused1) = list_idx2; 03767 IR_LIST_CNT_R(unused1) = 3; 03768 03769 IL_FLD(list_idx2) = CN_Tbl_Idx; 03770 IL_IDX(list_idx2) = CN_INTEGER_ONE_IDX; 03771 IL_LINE_NUM(list_idx2) = line; 03772 IL_COL_NUM(list_idx2) = col; 03773 03774 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2)); 03775 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2; 03776 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 03777 03778 IL_FLD(list_idx2) = CN_Tbl_Idx; 03779 IL_IDX(list_idx2) = TYP_IDX(arg_info_list[info_idx].ed.type_idx); 03780 IL_LINE_NUM(list_idx2) = line; 03781 IL_COL_NUM(list_idx2) = col; 03782 03783 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2)); 03784 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2; 03785 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 03786 03787 IL_FLD(list_idx2) = CN_Tbl_Idx; 03788 IL_IDX(list_idx2) = TYP_IDX(arg_info_list[info_idx].ed.type_idx); 03789 IL_LINE_NUM(list_idx2) = line; 03790 IL_COL_NUM(list_idx2) = col; 03791 03792 03793 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 03794 IR_IDX_L(ir_idx) = unused1; 03795 } 03796 else { 03797 # if 0 03798 03799 if (! io_call && 03800 arg_info_list[info_idx].ed.rank != 0) { 03801 03802 /* Caution about a COPY IN situation!! */ 03803 03804 PRINTMSG(line, 1438, Caution, col, "copy in"); 03805 } 03806 03807 COPY_OPND(opnd, IL_OPND(list_idx)); 03808 tmp_idx = create_tmp_asg(&opnd, 03809 (expr_arg_type *)&(arg_info_list[info_idx].ed), 03810 &l_opnd, 03811 Intent_In, 03812 TRUE, 03813 FALSE); 03814 03815 03816 if (ATP_VFUNCTION(spec_idx) || 03817 arg_info_list[info_idx].ed.percent_val_arg || 03818 ATP_ELEMENTAL(spec_idx)) { 03819 03820 COPY_OPND(IL_OPND(list_idx), l_opnd); 03821 03822 if (ATP_ELEMENTAL(spec_idx)) { 03823 NTR_IR_TBL(ir_idx); 03824 IR_OPR(ir_idx) = Aloc_Opr; 03825 IR_LINE_NUM(ir_idx) = line; 03826 IR_COL_NUM(ir_idx) = col; 03827 03828 if (arg_info_list[info_idx].ed.type == Character) { 03829 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 03830 } 03831 else { 03832 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 03833 } 03834 03835 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx)); 03836 IL_FLD(list_idx) = IR_Tbl_Idx; 03837 IL_IDX(list_idx) = ir_idx; 03838 } 03839 } 03840 else { 03841 NTR_IR_TBL(ir_idx); 03842 IR_OPR(ir_idx) = Aloc_Opr; 03843 IR_LINE_NUM(ir_idx) = line; 03844 IR_COL_NUM(ir_idx) = col; 03845 03846 if (arg_info_list[info_idx].ed.type == Character) { 03847 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 03848 } 03849 else { 03850 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 03851 } 03852 03853 IL_FLD(list_idx) = IR_Tbl_Idx; 03854 IL_IDX(list_idx) = ir_idx; 03855 03856 /* JBL - this is for array element change */ 03857 03858 # ifndef _FRONTEND_INLINER 03859 if (OPND_FLD(l_opnd) == IR_Tbl_Idx && 03860 ! ATP_ELEMENTAL(spec_idx)) { 03861 03862 if (IR_OPR(OPND_IDX(l_opnd)) == Whole_Subscript_Opr) { 03863 COPY_OPND(l_opnd, IR_OPND_L(OPND_IDX(l_opnd))); 03864 } 03865 } 03866 # endif 03867 if (arg_info_list[info_idx].ed.rank != 0) { 03868 unused1 = NULL_IDX; 03869 unused2 = NULL_IDX; 03870 make_base_subtree(&l_opnd,&base_opnd,&unused1,&unused2); 03871 COPY_OPND(l_opnd, base_opnd); 03872 } 03873 03874 03875 COPY_OPND(IR_OPND_L(ir_idx), l_opnd); 03876 03877 # ifdef _TRANSFORM_CHAR_SEQUENCE 03878 if (arg_info_list[info_idx].ed.type == Structure && 03879 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) { 03880 03881 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 03882 transform_char_sequence_ref(&opnd, 03883 arg_info_list[info_idx].ed.type_idx); 03884 COPY_OPND(IR_OPND_L(ir_idx), opnd); 03885 03886 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 03887 } 03888 # endif 03889 } 03890 # endif 03891 } 03892 break; 03893 03894 case COPY_IN_COPY_OUT : 03895 03896 # if 0 /*Oct*/ 03897 if (arg_info_list[info_idx].ed.section) { 03898 save_array_syntax_subscripts(list_idx); 03899 } 03900 # endif 03901 03902 intent = Intent_Inout; 03903 03904 if (dummy != NULL_IDX && 03905 ATD_INTENT(dummy) == Intent_Out) { 03906 03907 intent = Intent_Out; 03908 03909 if (! io_call && 03910 arg_info_list[info_idx].ed.rank != 0) { 03911 /* Caution about a COPY OUT situation!! */ 03912 03913 PRINTMSG(line, 1438, Caution, col, "copy out"); 03914 } 03915 } 03916 else if (! io_call && 03917 arg_info_list[info_idx].ed.rank != 0 && 03918 (dummy == NULL_IDX || 03919 ATD_INTENT(dummy) != Intent_In)) { 03920 /* Caution about a COPY IN/OUT situation!! */ 03921 03922 PRINTMSG(line, 1438, Caution, col, "copy in and copy out"); 03923 } 03924 else if (! io_call && 03925 arg_info_list[info_idx].ed.rank != 0) { 03926 /* Caution about a COPY IN situation!! */ 03927 03928 intent = Intent_In; 03929 03930 PRINTMSG(line, 1438, Caution, col, "copy in"); 03931 } 03932 # if 0 /*Oct*/ 03933 COPY_OPND(opnd, IL_OPND(list_idx)); 03934 tmp_idx = create_tmp_asg(&opnd, 03935 (expr_arg_type *)&(arg_info_list[info_idx].ed), 03936 &l_opnd, 03937 intent, 03938 TRUE, 03939 FALSE); 03940 03941 if (ATP_VFUNCTION(spec_idx) || 03942 arg_info_list[info_idx].ed.percent_val_arg) { 03943 03944 COPY_OPND(IL_OPND(list_idx), l_opnd); 03945 } 03946 else { 03947 NTR_IR_TBL(ir_idx); 03948 IR_OPR(ir_idx) = Aloc_Opr; 03949 IR_LINE_NUM(ir_idx) = line; 03950 IR_COL_NUM(ir_idx) = col; 03951 03952 if (arg_info_list[info_idx].ed.type == Character) { 03953 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 03954 } 03955 else { 03956 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 03957 } 03958 03959 IL_FLD(list_idx) = IR_Tbl_Idx; 03960 IL_IDX(list_idx) = ir_idx; 03961 03962 /* JBL - this is for array element change */ 03963 03964 # ifndef _FRONTEND_INLINER 03965 if (OPND_FLD(l_opnd) == IR_Tbl_Idx && 03966 ! ATP_ELEMENTAL(spec_idx)) { 03967 03968 if (IR_OPR(OPND_IDX(l_opnd)) == Whole_Subscript_Opr) { 03969 COPY_OPND(l_opnd, IR_OPND_L(OPND_IDX(l_opnd))); 03970 } 03971 } 03972 # endif 03973 if (arg_info_list[info_idx].ed.rank != 0) { 03974 unused1 = NULL_IDX; 03975 unused2 = NULL_IDX; 03976 make_base_subtree(&l_opnd, &base_opnd, &unused1, &unused2); 03977 COPY_OPND(l_opnd, base_opnd); 03978 } 03979 03980 COPY_OPND(IR_OPND_L(ir_idx), l_opnd); 03981 03982 # ifdef _TRANSFORM_CHAR_SEQUENCE 03983 if (arg_info_list[info_idx].ed.type == Structure && 03984 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) { 03985 03986 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 03987 transform_char_sequence_ref(&opnd, 03988 arg_info_list[info_idx].ed.type_idx); 03989 COPY_OPND(IR_OPND_L(ir_idx), opnd); 03990 03991 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 03992 } 03993 # endif 03994 } 03995 03996 # endif /*Oct*/ 03997 03998 break; 03999 04000 case MAKE_DV : 04001 04002 #if 0 04003 04004 if (AT_OPTIONAL(dummy) && 04005 arg_info_list[info_idx].ed.optional_darg) { 04006 04007 /* generate if stmt for present(arg) */ 04008 04009 COPY_OPND(opnd, IL_OPND(list_idx)); 04010 present_idx = gen_ir(AT_Tbl_Idx, find_left_attr(&opnd), 04011 Present_Opr, LOGICAL_DEFAULT_TYPE, line, col, 04012 NO_Tbl_Idx, NULL_IDX); 04013 04014 gen_opnd(&cond_opnd, 04015 present_idx, 04016 IR_Tbl_Idx, 04017 line, 04018 col); 04019 04020 /* save the bounding stmts. these are moved in later. */ 04021 true_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04022 true_end_sh_idx = curr_stmt_sh_idx; 04023 04024 /* put work here */ 04025 04026 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 04027 04028 # if defined(GENERATE_WHIRL) 04029 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE; 04030 ATD_NOT_PT_UNIQUE_MEM( 04031 (find_left_attr(&IL_OPND(list_idx)))) = TRUE; 04032 # endif 04033 04034 ATD_TYPE_IDX(tmp_idx) = arg_info_list[info_idx].ed.type_idx; 04035 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 04036 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 04037 04038 if (arg_info_list[info_idx].ed.rank) { 04039 04040 /* Positions 1-7 are deferred shape entries in bd table. */ 04041 04042 ATD_ARRAY_IDX(tmp_idx) = arg_info_list[info_idx].ed.rank; 04043 } 04044 /* March ATD_IM_A_DOPE(tmp_idx) = TRUE; */ 04045 04046 COPY_OPND(r_opnd, IL_OPND(list_idx)); 04047 exp_desc = arg_info_list[info_idx].ed; 04048 OPND_FLD(l_opnd) = AT_Tbl_Idx; 04049 OPND_IDX(l_opnd) = tmp_idx; 04050 OPND_LINE_NUM(l_opnd) = line; 04051 OPND_COL_NUM(l_opnd) = col; 04052 04053 gen_dv_whole_def(&l_opnd, &r_opnd, &exp_desc); 04054 04055 04056 /* gen loc tmp = loc(tmp_idx) */ 04057 04058 GEN_COMPILER_TMP_ASG(asg_idx, 04059 tmp_loc_idx, 04060 TRUE, /* Semantics done */ 04061 line, 04062 col, 04063 SA_INTEGER_DEFAULT_TYPE, 04064 Priv); 04065 04066 ir_idx = gen_ir(AT_Tbl_Idx, tmp_idx, 04067 Loc_Opr, CRI_Ptr_8, line, col, 04068 NO_Tbl_Idx, NULL_IDX); 04069 04070 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 04071 IR_IDX_R(asg_idx) = ir_idx; 04072 IR_LINE_NUM_R(asg_idx) = line; 04073 IR_COL_NUM_R(asg_idx) = col; 04074 04075 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 04076 04077 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 04078 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 04079 04080 true_start_sh_idx = SH_NEXT_IDX(true_start_sh_idx); 04081 true_end_sh_idx = SH_PREV_IDX(true_end_sh_idx); 04082 04083 /* gen the loc tmp = 0 stmt. */ 04084 04085 asg_idx = gen_ir(AT_Tbl_Idx, tmp_loc_idx, 04086 Asg_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, 04087 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 04088 04089 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 04090 04091 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 04092 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 04093 04094 false_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04095 false_end_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04096 04097 gen_if_stmt(&cond_opnd, 04098 true_start_sh_idx, 04099 true_end_sh_idx, 04100 false_start_sh_idx, 04101 false_end_sh_idx, 04102 line, 04103 col); 04104 04105 /* put loc tmp into arg */ 04106 04107 IL_FLD(list_idx) = AT_Tbl_Idx; 04108 IL_IDX(list_idx) = tmp_loc_idx; 04109 IL_LINE_NUM(list_idx) = line; 04110 IL_COL_NUM(list_idx) = col; 04111 } 04112 else { 04113 04114 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 04115 04116 # if defined(GENERATE_WHIRL) 04117 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE; 04118 ATD_NOT_PT_UNIQUE_MEM( 04119 (find_left_attr(&IL_OPND(list_idx)))) = TRUE; 04120 # endif 04121 04122 ATD_TYPE_IDX(tmp_idx) = arg_info_list[info_idx].ed.type_idx; 04123 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 04124 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 04125 04126 if (arg_info_list[info_idx].ed.rank) { 04127 04128 /* Positions 1-7 are deferred shape entries in bd table. */ 04129 04130 ATD_ARRAY_IDX(tmp_idx) = arg_info_list[info_idx].ed.rank; 04131 } 04132 /* MArch ATD_IM_A_DOPE(tmp_idx) = TRUE; */ 04133 04134 COPY_OPND(r_opnd, IL_OPND(list_idx)); 04135 exp_desc = arg_info_list[info_idx].ed; 04136 OPND_FLD(l_opnd) = AT_Tbl_Idx; 04137 OPND_IDX(l_opnd) = tmp_idx; 04138 OPND_LINE_NUM(l_opnd) = line; 04139 OPND_COL_NUM(l_opnd) = col; 04140 04141 gen_dv_whole_def(&l_opnd, &r_opnd, &exp_desc); 04142 04143 NTR_IR_TBL(ir_idx); 04144 IR_OPR(ir_idx) = Aloc_Opr; 04145 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 04146 IR_LINE_NUM(ir_idx) = line; 04147 IR_COL_NUM(ir_idx) = col; 04148 IL_FLD(list_idx) = IR_Tbl_Idx; 04149 IL_IDX(list_idx) = ir_idx; 04150 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 04151 IR_IDX_L(ir_idx) = tmp_idx; 04152 IR_LINE_NUM_L(ir_idx) = line; 04153 IR_COL_NUM_L(ir_idx) = col; 04154 } 04155 04156 arg_info_list[info_idx].ed.dope_vector = TRUE; 04157 # endif 04158 04159 break; 04160 04161 case COPY_IN_MAKE_DV : 04162 04163 /* tmp_idx is the copy in tmp */ 04164 # if 0 04165 COPY_OPND(opnd, IL_OPND(list_idx)); 04166 tmp_idx = create_tmp_asg(&opnd, 04167 (expr_arg_type *)&(arg_info_list[info_idx].ed), 04168 &l_opnd, 04169 Intent_In, 04170 TRUE, 04171 FALSE); 04172 # endif 04173 04174 if (! io_call && 04175 arg_info_list[info_idx].ed.rank != 0) { 04176 04177 /* Caution about a COPY IN situation!! */ 04178 04179 PRINTMSG(line, 1438, Caution, col, "copy in"); 04180 } 04181 # if 0 04182 /* tmp_dv_idx is the dope vector tmp */ 04183 04184 tmp_dv_idx = gen_compiler_tmp(line, col, Priv, TRUE); 04185 04186 # if defined(GENERATE_WHIRL) 04187 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE; 04188 04189 if (ATD_AUTOMATIC(tmp_idx) && 04190 ATD_AUTO_BASE_IDX(tmp_idx) != NULL_IDX) { 04191 ATD_NOT_PT_UNIQUE_MEM(ATD_AUTO_BASE_IDX(tmp_idx)) = TRUE; 04192 } 04193 04194 ATD_NOT_PT_UNIQUE_MEM(tmp_dv_idx) = TRUE; 04195 # endif 04196 04197 ATD_TYPE_IDX(tmp_dv_idx) = arg_info_list[info_idx].ed.type_idx; 04198 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 04199 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE; 04200 04201 if (arg_info_list[info_idx].ed.rank) { 04202 04203 /* Positions 1-7 are deferred shape entries in the bd table. */ 04204 04205 ATD_ARRAY_IDX(tmp_dv_idx) = arg_info_list[info_idx].ed.rank; 04206 } 04207 ATD_IM_A_DOPE(tmp_dv_idx) = TRUE; 04208 04209 OPND_FLD(r_opnd) = AT_Tbl_Idx; 04210 OPND_IDX(r_opnd) = tmp_idx; 04211 OPND_LINE_NUM(r_opnd) = line; 04212 OPND_COL_NUM(r_opnd) = col; 04213 04214 exp_desc = arg_info_list[info_idx].ed; 04215 04216 if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character) { 04217 ok = gen_whole_substring(&r_opnd, exp_desc.rank) && ok; 04218 } 04219 04220 OPND_FLD(l_opnd) = AT_Tbl_Idx; 04221 OPND_IDX(l_opnd) = tmp_dv_idx; 04222 OPND_LINE_NUM(l_opnd) = line; 04223 OPND_COL_NUM(l_opnd) = col; 04224 04225 gen_dv_whole_def(&l_opnd, &r_opnd, &exp_desc); 04226 04227 NTR_IR_TBL(ir_idx); 04228 IR_OPR(ir_idx) = Aloc_Opr; 04229 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 04230 IR_LINE_NUM(ir_idx) = line; 04231 IR_COL_NUM(ir_idx) = col; 04232 IL_FLD(list_idx) = IR_Tbl_Idx; 04233 IL_IDX(list_idx) = ir_idx; 04234 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 04235 IR_IDX_L(ir_idx) = tmp_dv_idx; 04236 IR_LINE_NUM_L(ir_idx) = line; 04237 IR_COL_NUM_L(ir_idx) = col; 04238 04239 arg_info_list[info_idx].ed.dope_vector = TRUE; 04240 # endif 04241 04242 break; 04243 04244 case CHECK_CONTIG_FLAG : 04245 04246 # if 0 /* we don't need change the representation about pointer argument 04247 in source lever---fzhao*/ 04248 if (! io_call && 04249 arg_info_list[info_idx].ed.rank != 0) { 04250 /* Caution about a potential COPY IN situation!! */ 04251 04252 PRINTMSG(line, 1438, Caution, col, "possible copy in and out"); 04253 } 04254 if (arg_info_list[info_idx].ed.section) { 04255 save_array_syntax_subscripts(list_idx); 04256 } 04257 04258 /* generate address temp */ 04259 04260 # if defined(GENERATE_WHIRL) 04261 NTR_IR_LIST_TBL(false_list_idx); 04262 NTR_IR_TBL(false_parm_idx); 04263 IR_OPR(false_parm_idx) = False_Parm_Opr; 04264 IR_TYPE_IDX(false_parm_idx) = CRI_Ptr_8; 04265 IR_LINE_NUM(false_parm_idx) = line; 04266 IR_COL_NUM(false_parm_idx) = col; 04267 COPY_OPND(IR_OPND_L(false_parm_idx), IL_OPND(list_idx)); 04268 IL_FLD(false_list_idx) = IR_Tbl_Idx; 04269 IL_IDX(false_list_idx) = false_parm_idx; 04270 # endif 04271 addr_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 04272 04273 # ifdef _TRANSFORM_CHAR_SEQUENCE 04274 if (arg_info_list[info_idx].ed.type == Character || 04275 (arg_info_list[info_idx].ed.type == Structure && 04276 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx)))) 04277 # else 04278 if (arg_info_list[info_idx].ed.type == Character) 04279 # endif 04280 { 04281 ATD_TYPE_IDX(addr_tmp_idx) = CRI_Ch_Ptr_8; 04282 } 04283 else { 04284 ATD_TYPE_IDX(addr_tmp_idx) = SA_INTEGER_DEFAULT_TYPE; 04285 } 04286 ATD_STOR_BLK_IDX(addr_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 04287 AT_SEMANTICS_DONE(addr_tmp_idx) = TRUE; 04288 04289 # if defined(GENERATE_WHIRL) 04290 ATD_NOT_PT_UNIQUE_MEM(addr_tmp_idx) = TRUE; 04291 ATD_NOT_PT_UNIQUE_MEM(find_left_attr(&IL_OPND(list_idx))) = TRUE; 04292 # endif 04293 04294 /* find the dope vector opnd */ 04295 04296 COPY_OPND(dv_opnd, IL_OPND(list_idx)); 04297 04298 while (OPND_FLD(dv_opnd) == IR_Tbl_Idx && 04299 IR_OPR(OPND_IDX(dv_opnd)) != Dv_Deref_Opr) { 04300 COPY_OPND(dv_opnd, IR_OPND_L(OPND_IDX(dv_opnd))); 04301 } 04302 04303 COPY_OPND(dv_opnd, IR_OPND_L(OPND_IDX(dv_opnd))); 04304 04305 /* save the original dope vector in ATD_TMP_IDX */ 04306 04307 ATD_FLD(addr_tmp_idx) = OPND_FLD(dv_opnd); 04308 ATD_TMP_IDX(addr_tmp_idx) = OPND_IDX(dv_opnd); 04309 04310 /* generate if (contig) Before */ 04311 04312 ir_idx = gen_ir(OPND_FLD(dv_opnd), OPND_IDX(dv_opnd), 04313 Dv_Access_A_Contig, CG_INTEGER_DEFAULT_TYPE, line, col, 04314 NO_Tbl_Idx, NULL_IDX); 04315 04316 present_idx = gen_ir(IR_Tbl_Idx, ir_idx, 04317 Eq_Opr, LOGICAL_DEFAULT_TYPE, line, col, 04318 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 04319 04320 gen_opnd(&cond_opnd, 04321 present_idx, 04322 IR_Tbl_Idx, 04323 line, 04324 col); 04325 04326 04327 contig_test_ir_idx = present_idx; 04328 04329 OPND_FLD(opnd) = CN_Tbl_Idx; 04330 OPND_IDX(opnd) = CN_INTEGER_ZERO_IDX; 04331 OPND_LINE_NUM(opnd) = line; 04332 OPND_COL_NUM(opnd) = col; 04333 04334 gen_internal_call_stmt("DUMP", &opnd, Before); 04335 04336 /* set address temp = address from dope vector or */ 04337 /* loc (base subtree). Before */ 04338 04339 NTR_IR_TBL(asg_idx); 04340 IR_OPR(asg_idx) = Asg_Opr; 04341 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(addr_tmp_idx); 04342 IR_LINE_NUM(asg_idx) = line; 04343 IR_COL_NUM(asg_idx) = col; 04344 IR_LINE_NUM_L(asg_idx) = line; 04345 IR_COL_NUM_L(asg_idx) = col; 04346 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 04347 IR_IDX_L(asg_idx) = addr_tmp_idx; 04348 04349 COPY_OPND(opnd, IL_OPND(list_idx)); 04350 unused1 = NULL_IDX; 04351 unused2 = NULL_IDX; 04352 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2); 04353 04354 NTR_IR_TBL(ir_idx); 04355 IR_OPR(ir_idx) = Loc_Opr; 04356 IR_TYPE_IDX(ir_idx) = (arg_info_list[info_idx].ed.type == 04357 Character) 04358 ? CRI_Ch_Ptr_8 : CRI_Ptr_8; 04359 IR_LINE_NUM(ir_idx) = line; 04360 IR_COL_NUM(ir_idx) = col; 04361 04362 COPY_OPND(IR_OPND_L(ir_idx), base_opnd); 04363 04364 # ifdef _TRANSFORM_CHAR_SEQUENCE 04365 if (arg_info_list[info_idx].ed.type == Structure && 04366 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) { 04367 04368 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 04369 transform_char_sequence_ref(&opnd, 04370 arg_info_list[info_idx].ed.type_idx); 04371 COPY_OPND(IR_OPND_L(ir_idx), opnd); 04372 04373 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 04374 } 04375 # endif 04376 04377 NTR_IR_TBL(ir_idx); 04378 IR_OPR(ir_idx) = Dv_Access_Base_Addr; 04379 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 04380 IR_LINE_NUM(ir_idx) = line; 04381 IR_COL_NUM(ir_idx) = col; 04382 04383 COPY_OPND(IR_OPND_L(ir_idx), dv_opnd); 04384 04385 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 04386 IR_IDX_R(asg_idx) = ir_idx; 04387 04388 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 04389 04390 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 04391 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 04392 04393 true_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04394 true_end_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04395 04396 /* capture bounding stmts after curr_stmt_sh_idx */ 04397 true_start_sh_idx2 = curr_stmt_sh_idx; 04398 true_end_sh_idx2 = SH_NEXT_IDX(curr_stmt_sh_idx); 04399 04400 OPND_FLD(opnd) = CN_Tbl_Idx; 04401 OPND_IDX(opnd) = CN_INTEGER_ONE_IDX; 04402 OPND_LINE_NUM(opnd) = line; 04403 OPND_COL_NUM(opnd) = col; 04404 04405 gen_internal_call_stmt("DUMP", &opnd, Before); 04406 04407 /* capture bounding stmts before curr_stmt_sh_idx */ 04408 false_start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04409 false_end_sh_idx = curr_stmt_sh_idx; 04410 04411 /* do copy in Before */ 04412 04413 intent = Intent_In; 04414 04415 if (dummy != NULL_IDX && 04416 ATD_INTENT(dummy) == Intent_Out) { 04417 intent = Intent_Out; 04418 } 04419 else if (a_type != Array_Tmp_Ptr && 04420 (dummy == NULL_IDX || 04421 ATD_INTENT(dummy) != Intent_In)) { 04422 intent = Intent_Inout; 04423 } 04424 04425 COPY_OPND(opnd, IL_OPND(list_idx)); 04426 exp_desc = arg_info_list[info_idx].ed; 04427 tmp_idx = create_tmp_asg(&opnd, 04428 &exp_desc, 04429 &r_opnd, 04430 intent, 04431 TRUE, 04432 FALSE); 04433 # if defined(GENERATE_WHIRL) 04434 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE; 04435 04436 if (ATD_AUTOMATIC(tmp_idx) && 04437 ATD_AUTO_BASE_IDX(tmp_idx) != NULL_IDX) { 04438 04439 ATD_NOT_PT_UNIQUE_MEM(ATD_AUTO_BASE_IDX(tmp_idx)) = TRUE; 04440 } 04441 # endif 04442 04443 contig_test_ir_idx = NULL_IDX; 04444 04445 /* set address temp = loc(copy in temp) Before */ 04446 04447 NTR_IR_TBL(asg_idx); 04448 IR_OPR(asg_idx) = Asg_Opr; 04449 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(addr_tmp_idx); 04450 IR_LINE_NUM(asg_idx) = line; 04451 IR_COL_NUM(asg_idx) = col; 04452 IR_LINE_NUM_L(asg_idx) = line; 04453 IR_COL_NUM_L(asg_idx) = col; 04454 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 04455 IR_IDX_L(asg_idx) = addr_tmp_idx; 04456 04457 NTR_IR_TBL(ir_idx); 04458 IR_OPR(ir_idx) = Loc_Opr; 04459 IR_LINE_NUM(ir_idx) = line; 04460 IR_COL_NUM(ir_idx) = col; 04461 04462 if (arg_info_list[info_idx].ed.type == Character) { 04463 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 04464 } 04465 else { 04466 IR_TYPE_IDX(ir_idx) = CRI_Ptr_8; 04467 } 04468 04469 OPND_FLD(l_opnd) = AT_Tbl_Idx; 04470 OPND_IDX(l_opnd) = tmp_idx; 04471 OPND_LINE_NUM(l_opnd) = line; 04472 OPND_COL_NUM(l_opnd) = col; 04473 04474 if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character) { 04475 ok = gen_whole_substring(&l_opnd, 04476 arg_info_list[info_idx].ed.rank) && ok; 04477 } 04478 04479 COPY_OPND(IR_OPND_L(ir_idx), l_opnd); 04480 04481 # ifdef _TRANSFORM_CHAR_SEQUENCE 04482 if (arg_info_list[info_idx].ed.type == Structure && 04483 ATT_CHAR_SEQ(TYP_IDX(arg_info_list[info_idx].ed.type_idx))) { 04484 04485 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 04486 transform_char_sequence_ref(&opnd, 04487 arg_info_list[info_idx].ed.type_idx); 04488 COPY_OPND(IR_OPND_L(ir_idx), opnd); 04489 04490 IR_TYPE_IDX(ir_idx) = CRI_Ch_Ptr_8; 04491 } 04492 # endif 04493 04494 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 04495 IR_IDX_R(asg_idx) = ir_idx; 04496 04497 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 04498 04499 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 04500 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 04501 04502 gen_if_stmt(&cond_opnd, 04503 true_start_sh_idx, 04504 true_end_sh_idx, 04505 SH_NEXT_IDX(false_start_sh_idx), 04506 SH_PREV_IDX(false_end_sh_idx), 04507 line, 04508 col); 04509 04510 OPND_FLD(opnd) = CN_Tbl_Idx; 04511 OPND_IDX(opnd) = CN_INTEGER_ONE_IDX; 04512 OPND_LINE_NUM(opnd) = line; 04513 OPND_COL_NUM(opnd) = col; 04514 04515 gen_internal_call_stmt("DUMP", &opnd, After); 04516 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04517 04518 04519 /* generate if (!contig) test After */ 04520 if (SH_NEXT_IDX(true_start_sh_idx2) != true_end_sh_idx2) { 04521 ir_idx = gen_ir(OPND_FLD(dv_opnd), OPND_IDX(dv_opnd), 04522 Dv_Access_A_Contig, CG_INTEGER_DEFAULT_TYPE, line, col, 04523 NO_Tbl_Idx, NULL_IDX); 04524 04525 present_idx = gen_ir(IR_Tbl_Idx, ir_idx, 04526 Ne_Opr, LOGICAL_DEFAULT_TYPE, line, col, 04527 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 04528 04529 gen_opnd(&cond_opnd, 04530 present_idx, 04531 IR_Tbl_Idx, 04532 line, 04533 col); 04534 04535 gen_if_stmt(&cond_opnd, 04536 SH_NEXT_IDX(true_start_sh_idx2), 04537 SH_PREV_IDX(true_end_sh_idx2), 04538 NULL_IDX, 04539 NULL_IDX, 04540 line, 04541 col); 04542 } 04543 04544 /* set argument to address temp */ 04545 04546 IL_FLD(list_idx) = AT_Tbl_Idx; 04547 IL_IDX(list_idx) = addr_tmp_idx; 04548 IL_LINE_NUM(list_idx) = line; 04549 IL_COL_NUM(list_idx) = col; 04550 #endif 04551 break; 04552 04553 } 04554 04555 dummy_idx++; 04556 04557 EXIT: 04558 04559 defer_stmt_expansion = save_defer_stmt_expansion; 04560 COPY_OPND(opnd, IL_OPND(list_idx)); 04561 stmt_expansion_control_end(&opnd); 04562 COPY_OPND(IL_OPND(list_idx), opnd); 04563 IL_ARG_MULTI_FLAGS(list_idx) = association; 04564 04565 list_idx = IL_NEXT_LIST_IDX(list_idx); 04566 } 04567 04568 expr_mode = save_expr_mode; 04569 04570 TRACE (Func_Exit, "final_arg_work", NULL); 04571 04572 return(ok); 04573 04574 } /* final_arg_work */ 04575 04576 /******************************************************************************\ 04577 |* *| 04578 |* Description: *| 04579 |* Linearizes the attributes of a dummy arg for table lookup in *| 04580 |* final_arg_work. *| 04581 |* *| 04582 |* Input parameters: *| 04583 |* darg_idx - dummy arg. *| 04584 |* *| 04585 |* Output parameters: *| 04586 |* NONE *| 04587 |* *| 04588 |* Returns: *| 04589 |* dummy_arg_type. *| 04590 |* *| 04591 \******************************************************************************/ 04592 04593 static dummy_arg_type get_dummy_arg_type(int darg_idx) 04594 04595 { 04596 dummy_arg_type d_type = Unknown_Dummy; 04597 04598 04599 TRACE (Func_Entry, "get_dummy_arg_type", NULL); 04600 04601 if (darg_idx != NULL_IDX) { 04602 # ifdef _DEBUG 04603 if (AT_OBJ_CLASS(darg_idx) != Data_Obj) { 04604 PRINTMSG(stmt_start_line, 325, Internal, stmt_start_col); 04605 } 04606 # endif 04607 if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) { 04608 04609 if (ATD_POINTER(darg_idx)) { 04610 d_type = Scalar_Ptr_Dummy; 04611 } 04612 else if (ATD_INTRIN_DARG(darg_idx) && 04613 ATD_IM_A_DOPE(darg_idx)) { 04614 d_type = Intrin_Dope_Dummy; 04615 } 04616 # if 0 04617 /* BHJ DOPE VECTOR TARGET */ 04618 /* save this in case the interp changes. */ 04619 04620 else if (ATD_TARGET(darg_idx)) { 04621 d_type = Scalar_Target_Dummy; 04622 } 04623 # endif 04624 else { 04625 d_type = Scalar_Dummy; 04626 } 04627 } 04628 else { 04629 04630 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(darg_idx)) == Assumed_Shape) { 04631 d_type = Assumed_Shape_Dummy; 04632 } 04633 else if (ATD_POINTER(darg_idx)) { 04634 d_type = Array_Ptr_Dummy; 04635 } 04636 else if (ATD_INTRIN_DARG(darg_idx) && 04637 ATD_IM_A_DOPE(darg_idx)) { 04638 d_type = Intrin_Dope_Dummy; 04639 } 04640 # if 0 04641 /* BHJ DOPE VECTOR TARGET */ 04642 /* save this in case the interp changes. */ 04643 04644 04645 else if (ATD_TARGET(darg_idx)) { 04646 d_type = Array_Target_Dummy; 04647 } 04648 # endif 04649 else { 04650 d_type = Sequence_Array_Dummy; 04651 } 04652 } 04653 } 04654 04655 TRACE (Func_Exit, "get_dummy_arg_type", NULL); 04656 04657 return(d_type); 04658 04659 } /* get_dummy_arg_type */ 04660 04661 /******************************************************************************\ 04662 |* *| 04663 |* Description: *| 04664 |* Linearizes actual argument attributes for table lookup in *| 04665 |* final_arg_work. *| 04666 |* *| 04667 |* Input parameters: *| 04668 |* list_idx - IL idx for actual arg. *| 04669 |* info_idx - arg_info_list idx for description of actual arg *| 04670 |* *| 04671 |* Output parameters: *| 04672 |* NONE *| 04673 |* *| 04674 |* Returns: *| 04675 |* act_arg_type. *| 04676 |* *| 04677 \******************************************************************************/ 04678 04679 act_arg_type get_act_arg_type(expr_arg_type *exp_desc) 04680 04681 { 04682 act_arg_type a_type; 04683 04684 TRACE (Func_Entry, "get_act_arg_type", NULL); 04685 04686 if (exp_desc->rank == 0) { 04687 04688 if (exp_desc->constant) { 04689 if (exp_desc->tmp_reference) { 04690 a_type = Scalar_Tmp_Var; 04691 } 04692 else { 04693 a_type = Scalar_Constant; 04694 } 04695 } 04696 else if (exp_desc->pointer) { 04697 if (exp_desc->tmp_reference) { 04698 a_type = Scalar_Tmp_Ptr; 04699 } 04700 else { 04701 a_type = Scalar_Ptr; 04702 } 04703 } 04704 else if (exp_desc->reference) { 04705 04706 if (exp_desc->array_elt) { 04707 if (exp_desc->tmp_reference) { 04708 a_type = Array_Tmp_Elt; 04709 } 04710 else { 04711 a_type = Array_Elt; 04712 } 04713 } 04714 else if (exp_desc->has_symbolic) { 04715 a_type = Scalar_Expression; 04716 } 04717 else { 04718 if (exp_desc->tmp_reference) { 04719 a_type = Scalar_Tmp_Var; 04720 } 04721 else { 04722 a_type = Scalar_Var; 04723 } 04724 } 04725 } 04726 else if (exp_desc->tmp_reference) { 04727 if (exp_desc->dope_vector) { 04728 a_type = Scalar_Tmp_Ptr; 04729 } 04730 else { 04731 a_type = Scalar_Tmp_Var; 04732 } 04733 } 04734 else { 04735 a_type = Scalar_Expression; 04736 } 04737 } 04738 else { 04739 04740 if (exp_desc->constant) { 04741 if (exp_desc->section) { 04742 a_type = Constant_Array_Section; 04743 } 04744 else if (exp_desc->tmp_reference) { 04745 a_type = Whole_Tmp_Sequence; 04746 } 04747 else { 04748 a_type = Whole_Array_Constant; 04749 } 04750 } 04751 else if (exp_desc->pointer) { 04752 if (exp_desc->tmp_reference) { 04753 a_type = Array_Tmp_Ptr; 04754 } 04755 else { 04756 a_type = Array_Ptr; 04757 } 04758 } 04759 else if (exp_desc->reference) { 04760 04761 if (exp_desc->vector_subscript) { 04762 a_type = Vector_Subscript_Section; 04763 } 04764 else if (exp_desc->section) { 04765 04766 if (exp_desc->contig_array) { 04767 if (exp_desc->dope_vector) { 04768 a_type = Dv_Contig_Section; 04769 } 04770 else { 04771 a_type = Contig_Section; 04772 } 04773 } 04774 else if (exp_desc->dope_vector) { 04775 a_type = Dv_Array_Section; 04776 } 04777 else { 04778 a_type = Sequence_Array_Section; 04779 } 04780 } 04781 else if (exp_desc->allocatable) { 04782 if (exp_desc->tmp_reference) { 04783 a_type = Whole_Tmp_Allocatable; 04784 } 04785 else { 04786 a_type = Whole_Allocatable; 04787 } 04788 } 04789 else if (exp_desc->assumed_shape) { 04790 a_type = Whole_Ass_Shape; 04791 } 04792 else { 04793 if (exp_desc->tmp_reference) { 04794 a_type = Whole_Tmp_Sequence; 04795 } 04796 else { 04797 a_type = Whole_Sequence; 04798 } 04799 } 04800 } 04801 else if (exp_desc->tmp_reference) { 04802 if (exp_desc->allocatable) { 04803 a_type = Whole_Tmp_Allocatable; 04804 } 04805 else if (exp_desc->dope_vector) { 04806 04807 /* I'm using Array_Tmp_Ptr here because don't know for sure */ 04808 /* sure if the tmp is contiguous. */ 04809 04810 a_type = Array_Tmp_Ptr; 04811 } 04812 else { 04813 a_type = Whole_Tmp_Sequence; 04814 } 04815 } 04816 else { 04817 a_type = Array_Expr; 04818 } 04819 } 04820 04821 TRACE (Func_Exit, "get_act_arg_type", NULL); 04822 04823 return(a_type); 04824 04825 } /* get_act_arg_type */ 04826 04827 /******************************************************************************\ 04828 |* *| 04829 |* Description: *| 04830 |* Creates a temp assignment for copy in situations. Creates both stack *| 04831 |* heap temps. *| 04832 |* *| 04833 |* Input parameters: *| 04834 |* r_opnd - right hand side expression. *| 04835 |* exp_desc - expression descriptor for right hand side expression. *| 04836 |* intent - Intent_In, Intent_Inout, Intent_Out. A flag to specify if *| 04837 |* Assignments are needed before, after, or both. *| 04838 |* stmt_tmp - TRUE if ok to reuse stmt tmp. *| 04839 |* save_where_dealloc_stmt - if this is for where mask, don't insert the *| 04840 |* dealloc stmt. *| 04841 |* *| 04842 |* Output parameters: *| 04843 |* left_opnd - the reference tree used in the assignment stmt. This is *| 04844 |* a complete tree include whole_subscripts or substrings. *| 04845 |* *| 04846 |* Returns: *| 04847 |* attr idx for temp. *| 04848 |* *| 04849 \******************************************************************************/ 04850 04851 int create_tmp_asg(opnd_type *r_opnd, 04852 expr_arg_type *exp_desc, 04853 opnd_type *left_opnd, 04854 int intent, 04855 boolean stmt_tmp, 04856 boolean save_where_dealloc_stmt) 04857 04858 { 04859 int alloc_idx; 04860 int asg_idx; 04861 int base_asg_idx; 04862 int base_tmp_idx; 04863 int bd_idx; 04864 int col; 04865 boolean constant_shape = TRUE; 04866 int dealloc_idx = NULL_IDX; 04867 int ir_idx; 04868 int line; 04869 int list_idx; 04870 int max_idx; 04871 boolean ok = TRUE; 04872 opnd_type opnd; 04873 int save_curr_stmt_sh_idx; 04874 boolean save_defer_stmt_expansion; 04875 opnd_type size_opnd; 04876 int tmp_idx; 04877 int true_start_sh_idx; 04878 int true_end_sh_idx; 04879 04880 04881 TRACE (Func_Entry, "create_tmp_asg", NULL); 04882 04883 find_opnd_line_and_column(r_opnd, &line, &col); 04884 04885 # ifdef _DEBUG 04886 if (defer_stmt_expansion && 04887 alloc_block_start_idx && 04888 save_where_dealloc_stmt) { 04889 PRINTMSG(line, 626, Internal, col, 04890 "no defer_stmt_expansion", "create_tmp_asg"); 04891 } 04892 04893 if (orig_sh_idx != NULL_IDX && 04894 alloc_block_start_idx && 04895 save_where_dealloc_stmt) { 04896 PRINTMSG(line, 626, Internal, col, 04897 "no orig_sh_idx", "create_tmp_asg"); 04898 } 04899 # endif 04900 04901 stmt_expansion_control_start(); 04902 save_defer_stmt_expansion = defer_stmt_expansion; 04903 defer_stmt_expansion = FALSE; 04904 04905 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04906 04907 if (alloc_block_start_idx && 04908 save_where_dealloc_stmt) { 04909 curr_stmt_sh_idx = alloc_block_start_idx; 04910 } 04911 04912 if (exp_desc->rank) { 04913 constant_shape = gen_bd_entry(r_opnd, exp_desc, &bd_idx, line, col); 04914 } 04915 else if (exp_desc->type == Character) { 04916 ok = validate_char_len(r_opnd, exp_desc); 04917 04918 if (TYP_FLD(exp_desc->type_idx) != CN_Tbl_Idx) { 04919 constant_shape = FALSE; 04920 } 04921 } 04922 04923 tmp_idx = NULL_IDX; 04924 04925 if (stmt_tmp && 04926 constant_shape) { 04927 tmp_idx = get_stmt_tmp(exp_desc->type_idx, 04928 FALSE, 04929 exp_desc->rank); 04930 } 04931 04932 if (tmp_idx) { 04933 NTR_IR_TBL(asg_idx); 04934 IR_OPR(asg_idx) = Asg_Opr; 04935 04936 IR_TYPE_IDX(asg_idx) = exp_desc->type_idx; 04937 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 04938 IR_IDX_L(asg_idx) = tmp_idx; 04939 IR_LINE_NUM_L(asg_idx) = line; 04940 IR_LINE_NUM(asg_idx) = line; 04941 IR_COL_NUM_L(asg_idx) = col; 04942 IR_COL_NUM(asg_idx) = col; 04943 ATD_TMP_IDX(tmp_idx) = asg_idx; 04944 ATD_FLD(tmp_idx) = IR_Tbl_Idx; 04945 AT_DEFINED(tmp_idx) = TRUE; 04946 } 04947 else { 04948 GEN_COMPILER_TMP_ASG(asg_idx, 04949 tmp_idx, 04950 TRUE, /* Semantics done */ 04951 line, 04952 col, 04953 exp_desc->type_idx, 04954 Priv); 04955 } 04956 04957 ATD_ASG_TMP(tmp_idx) = TRUE; 04958 04959 if (!constant_shape) { 04960 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 04961 } 04962 04963 if (exp_desc->rank) { 04964 04965 if (! constant_shape) { 04966 /* initialize size_opnd to the number of elements for */ 04967 /* determine_tmp_size. */ 04968 04969 OPND_FLD(size_opnd) = BD_LEN_FLD(bd_idx); 04970 OPND_IDX(size_opnd) = BD_LEN_IDX(bd_idx); 04971 OPND_LINE_NUM(size_opnd) = line; 04972 OPND_COL_NUM(size_opnd) = col; 04973 } 04974 04975 ATD_ARRAY_IDX(tmp_idx) = bd_idx; 04976 } 04977 else if (! constant_shape) { 04978 /* initialize size_opnd to constant one for scalar for */ 04979 /* determine_tmp_size. */ 04980 04981 OPND_FLD(size_opnd) = CN_Tbl_Idx; 04982 OPND_IDX(size_opnd) = CN_INTEGER_ONE_IDX; 04983 OPND_LINE_NUM(size_opnd) = line; 04984 OPND_COL_NUM(size_opnd) = col; 04985 } 04986 04987 /* gen whole subscript or whole substring for tmp_idx */ 04988 04989 COPY_OPND((*left_opnd), IR_OPND_L(asg_idx)); 04990 04991 if (exp_desc->rank) { 04992 ok = gen_whole_subscript(left_opnd, exp_desc); 04993 } 04994 else if (exp_desc->type == Character) { 04995 ok = gen_whole_substring(left_opnd, 0); 04996 } 04997 04998 COPY_OPND(IR_OPND_L(asg_idx), (*left_opnd)); 04999 05000 05001 IR_RANK(asg_idx) = exp_desc->rank; 05002 05003 if (! constant_shape) { 05004 /* now for the alloc and dealloc stmts */ 05005 05006 ATD_AUTOMATIC(tmp_idx) = TRUE; 05007 05008 GEN_COMPILER_TMP_ASG(base_asg_idx, 05009 base_tmp_idx, 05010 TRUE, /* Semantics done */ 05011 line, 05012 col, 05013 SA_INTEGER_DEFAULT_TYPE, 05014 Priv); 05015 05016 ATD_AUTO_BASE_IDX(tmp_idx) = base_tmp_idx; 05017 05018 determine_tmp_size(&size_opnd, exp_desc->type_idx); 05019 05020 NTR_IR_TBL(max_idx); 05021 IR_OPR(max_idx) = Max_Opr; 05022 IR_TYPE_IDX(max_idx) = SA_INTEGER_DEFAULT_TYPE; 05023 IR_LINE_NUM(max_idx) = line; 05024 IR_COL_NUM(max_idx) = col; 05025 IR_FLD_L(max_idx) = IL_Tbl_Idx; 05026 IR_LIST_CNT_L(max_idx) = 2; 05027 05028 NTR_IR_LIST_TBL(list_idx); 05029 IR_IDX_L(max_idx) = list_idx; 05030 05031 IL_FLD(list_idx) = CN_Tbl_Idx; 05032 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 05033 IL_LINE_NUM(list_idx) = line; 05034 IL_COL_NUM(list_idx) = col; 05035 05036 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 05037 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 05038 list_idx = IL_NEXT_LIST_IDX(list_idx); 05039 05040 COPY_OPND(IL_OPND(list_idx), size_opnd); 05041 05042 OPND_FLD(size_opnd) = IR_Tbl_Idx; 05043 OPND_IDX(size_opnd) = max_idx; 05044 05045 NTR_IR_TBL(alloc_idx); 05046 IR_OPR(alloc_idx) = Alloc_Opr; 05047 IR_TYPE_IDX(alloc_idx) = TYPELESS_DEFAULT_TYPE; 05048 IR_LINE_NUM(alloc_idx) = line; 05049 IR_COL_NUM(alloc_idx) = col; 05050 COPY_OPND(IR_OPND_L(alloc_idx), size_opnd); 05051 IR_FLD_R(base_asg_idx) = IR_Tbl_Idx; 05052 IR_IDX_R(base_asg_idx) = alloc_idx; 05053 05054 gen_sh(Before, Assignment_Stmt, line, 05055 col, FALSE, FALSE, TRUE); 05056 05057 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = base_asg_idx; 05058 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05059 05060 NTR_IR_TBL(dealloc_idx); 05061 IR_OPR(dealloc_idx) = Dealloc_Opr; 05062 IR_TYPE_IDX(dealloc_idx) = TYPELESS_DEFAULT_TYPE; 05063 IR_LINE_NUM(dealloc_idx) = line; 05064 IR_COL_NUM(dealloc_idx) = col; 05065 COPY_OPND(IR_OPND_L(dealloc_idx), IR_OPND_L(base_asg_idx)); 05066 05067 if (save_where_dealloc_stmt) { 05068 05069 if (alloc_block_start_idx) { 05070 curr_stmt_sh_idx = alloc_block_end_idx; 05071 gen_sh(After, Assignment_Stmt, line, 05072 col, FALSE, FALSE, TRUE); 05073 05074 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx; 05075 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05076 } 05077 else { 05078 where_dealloc_stmt_idx = ntr_sh_tbl(); 05079 SH_STMT_TYPE(where_dealloc_stmt_idx) = Assignment_Stmt; 05080 SH_GLB_LINE(where_dealloc_stmt_idx) = line; 05081 SH_COL_NUM(where_dealloc_stmt_idx) = col; 05082 SH_COMPILER_GEN(where_dealloc_stmt_idx) = TRUE; 05083 SH_P2_SKIP_ME(where_dealloc_stmt_idx) = TRUE; 05084 05085 SH_IR_IDX(where_dealloc_stmt_idx) = dealloc_idx; 05086 } 05087 } 05088 else if (orig_sh_idx != NULL_IDX) { 05089 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05090 curr_stmt_sh_idx = orig_sh_idx; 05091 05092 if (contig_test_ir_idx != NULL_IDX) { 05093 05094 true_start_sh_idx = curr_stmt_sh_idx; 05095 true_end_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 05096 05097 /* gen the branch around test */ 05098 05099 gen_opnd(&opnd, contig_test_ir_idx, IR_Tbl_Idx, line, col); 05100 copy_subtree(&opnd, &opnd); 05101 ir_idx = OPND_IDX(opnd); 05102 IR_OPR(ir_idx) = Ne_Opr; 05103 05104 /* insert the dealloc stmt */ 05105 05106 gen_sh(After, Assignment_Stmt, line, 05107 col, FALSE, FALSE, TRUE); 05108 05109 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx; 05110 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05111 05112 05113 gen_if_stmt(&opnd, 05114 SH_NEXT_IDX(true_start_sh_idx), 05115 SH_PREV_IDX(true_end_sh_idx), 05116 NULL_IDX, 05117 NULL_IDX, 05118 line, 05119 col); 05120 05121 } 05122 else { 05123 gen_sh(After, Assignment_Stmt, line, 05124 col, FALSE, FALSE, TRUE); 05125 05126 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx; 05127 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05128 } 05129 05130 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05131 } 05132 else { 05133 gen_sh(After, Assignment_Stmt, line, 05134 col, FALSE, FALSE, TRUE); 05135 05136 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx; 05137 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05138 05139 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 05140 } 05141 } 05142 05143 if (alloc_block_start_idx && 05144 save_where_dealloc_stmt) { 05145 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05146 } 05147 05148 05149 05150 COPY_OPND(IR_OPND_R(asg_idx), (*r_opnd)); 05151 05152 # ifdef _TRANSFORM_CHAR_SEQUENCE 05153 if (exp_desc->type == Structure && 05154 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) { 05155 05156 COPY_OPND(opnd, IR_OPND_L(asg_idx)); 05157 transform_char_sequence_ref(&opnd, exp_desc->type_idx); 05158 COPY_OPND(IR_OPND_L(asg_idx), opnd); 05159 05160 COPY_OPND(opnd, IR_OPND_R(asg_idx)); 05161 transform_char_sequence_ref(&opnd, exp_desc->type_idx); 05162 COPY_OPND(IR_OPND_R(asg_idx), opnd); 05163 } 05164 # endif 05165 05166 if (intent == Intent_In || intent == Intent_Inout) { 05167 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05168 05169 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05170 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05171 } 05172 05173 if (intent == Intent_Out || intent == Intent_Inout) { 05174 NTR_IR_TBL(asg_idx); 05175 IR_OPR(asg_idx) = Asg_Opr; 05176 IR_TYPE_IDX(asg_idx) = exp_desc->type_idx; 05177 IR_LINE_NUM(asg_idx) = line; 05178 IR_COL_NUM(asg_idx) = col; 05179 IR_RANK(asg_idx) = exp_desc->rank; 05180 COPY_OPND(IR_OPND_R(asg_idx), (*left_opnd)); 05181 COPY_OPND(IR_OPND_L(asg_idx), (*r_opnd)); 05182 05183 gen_sh(After, Assignment_Stmt, stmt_start_line, 05184 stmt_start_col, FALSE, FALSE, TRUE); 05185 05186 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 05187 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05188 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 05189 } 05190 05191 /* change the flags in the expression descriptor to show it's now a tmp */ 05192 05193 exp_desc->constant = FALSE; 05194 exp_desc->foldable = FALSE; 05195 exp_desc->will_fold_later = FALSE; 05196 05197 exp_desc->tmp_reference = TRUE; 05198 exp_desc->section = FALSE; 05199 05200 if (exp_desc->rank > 0) { 05201 exp_desc->contig_array = TRUE; 05202 } 05203 05204 defer_stmt_expansion = save_defer_stmt_expansion; 05205 stmt_expansion_control_end(left_opnd); 05206 05207 TRACE (Func_Exit, "create_tmp_asg", NULL); 05208 05209 return(tmp_idx); 05210 05211 } /* create_tmp_asg */ 05212 05213 /******************************************************************************\ 05214 |* *| 05215 |* Description: *| 05216 |* generates a new bounds table entry from information in an exp_desc. *| 05217 |* *| 05218 |* Input parameters: *| 05219 |* r_opnd - right hand side expression. (might be NULL) *| 05220 |* exp_desc - expression descriptor for right hand side expression. *| 05221 |* *| 05222 |* Output parameters: *| 05223 |* *| 05224 |* Returns: *| 05225 |* TRUE if constant shape. *| 05226 |* *| 05227 \******************************************************************************/ 05228 05229 boolean gen_bd_entry(opnd_type *r_opnd, 05230 expr_arg_type *exp_desc, 05231 int *res_bd_idx, 05232 int line, 05233 int col) 05234 05235 { 05236 int attr_idx; 05237 int bd_idx; 05238 int br_idx; 05239 int ch_asg_idx; 05240 boolean constant_shape = TRUE; 05241 int ir_idx; 05242 int label_idx; 05243 expr_arg_type loc_exp_desc; 05244 int i; 05245 int minus_idx; 05246 int mult_idx; 05247 opnd_type num_el_opnd; 05248 boolean ok = TRUE; 05249 opnd_type opnd; 05250 int plus_idx; 05251 expr_mode_type save_expr_mode; 05252 cif_usage_code_type save_xref_state; 05253 opnd_type sm_opnd; 05254 size_offset_type stride; 05255 int tmp_idx; 05256 05257 05258 TRACE (Func_Entry, "gen_bd_entry", NULL); 05259 05260 bd_idx = reserve_array_ntry(exp_desc->rank); 05261 BD_RESOLVED(bd_idx) = TRUE; 05262 05263 for (i = 1; i <= exp_desc->rank; i++) { 05264 05265 if (shared_bd_idx != NULL_IDX) { 05266 /* This is a copy for the COPY_ASSUMED_SHAPE directive. */ 05267 /* if shared_bd_idx < 0, this is the first one, else if */ 05268 /* shared_bd_idx > 0 it is the bd_idx where we get XT. */ 05269 05270 constant_shape = FALSE; 05271 05272 # ifdef _DEBUG 05273 if (r_opnd == NULL) { 05274 PRINTMSG(line, 626, Internal, col, "r_opnd", "gen_bd_entry"); 05275 } 05276 # endif 05277 attr_idx = find_left_attr(r_opnd); 05278 05279 BD_LB_FLD(bd_idx,i) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),i); 05280 BD_LB_IDX(bd_idx,i) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),i); 05281 05282 /* XT is from the shape operand */ 05283 05284 if (shared_bd_idx < 0) { 05285 05286 if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx && 05287 ATD_CLASS(OPND_IDX(exp_desc->shape[i-1])) == Compiler_Tmp) { 05288 05289 BD_XT_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]); 05290 BD_XT_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]); 05291 } 05292 else { /* must do tmp assignments */ 05293 05294 GEN_COMPILER_TMP_ASG(ch_asg_idx, 05295 tmp_idx, 05296 TRUE, /* Semantics done */ 05297 line, 05298 col, 05299 CG_INTEGER_DEFAULT_TYPE, 05300 Priv); 05301 05302 IR_FLD_R(ch_asg_idx) = OPND_FLD(exp_desc->shape[i-1]); 05303 IR_IDX_R(ch_asg_idx) = OPND_IDX(exp_desc->shape[i-1]); 05304 IR_LINE_NUM_R(ch_asg_idx) = line; 05305 IR_COL_NUM_R(ch_asg_idx) = col; 05306 05307 if (reassign_XT_temps) { 05308 /* gen the branch around test */ 05309 05310 label_idx = gen_internal_lbl(line); 05311 05312 NTR_IR_TBL(br_idx); 05313 IR_OPR(br_idx) = Br_True_Opr; 05314 IR_TYPE_IDX(br_idx) = LOGICAL_DEFAULT_TYPE; 05315 IR_LINE_NUM(br_idx) = line; 05316 IR_COL_NUM(br_idx) = col; 05317 05318 NTR_IR_TBL(ir_idx); 05319 IR_OPR(ir_idx) = Ge_Opr; 05320 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 05321 IR_LINE_NUM(ir_idx) = line; 05322 IR_COL_NUM(ir_idx) = col; 05323 05324 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 05325 IR_IDX_L(ir_idx) = tmp_idx; 05326 IR_LINE_NUM_L(ir_idx) = line; 05327 IR_COL_NUM_L(ir_idx) = col; 05328 05329 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 05330 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 05331 IR_LINE_NUM_R(ir_idx) = line; 05332 IR_COL_NUM_R(ir_idx) = col; 05333 05334 IR_FLD_L(br_idx) = IR_Tbl_Idx; 05335 IR_IDX_L(br_idx) = ir_idx; 05336 IR_FLD_R(br_idx) = AT_Tbl_Idx; 05337 IR_IDX_R(br_idx) = label_idx; 05338 IR_LINE_NUM_R(br_idx) = line; 05339 IR_COL_NUM_R(br_idx) = col; 05340 05341 gen_sh(Before, If_Stmt, line, 05342 col, FALSE, FALSE, TRUE); 05343 05344 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_idx; 05345 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05346 } 05347 05348 /* insert the assignment */ 05349 05350 gen_sh(Before, Assignment_Stmt, line, 05351 col , FALSE, FALSE, TRUE); 05352 05353 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 05354 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05355 05356 gen_copyin_bounds_stmt(tmp_idx); 05357 05358 if (reassign_XT_temps) { 05359 /* gen the label stmt */ 05360 05361 NTR_IR_TBL(ir_idx); 05362 IR_OPR(ir_idx) = Label_Opr; 05363 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 05364 IR_LINE_NUM(ir_idx) = line; 05365 IR_COL_NUM(ir_idx) = col; 05366 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 05367 IR_IDX_L(ir_idx) = label_idx; 05368 IR_COL_NUM_L(ir_idx) = col; 05369 IR_LINE_NUM_L(ir_idx) = line; 05370 05371 AT_DEFINED(label_idx) = TRUE; 05372 05373 gen_sh(Before, Continue_Stmt, line, col, 05374 FALSE, FALSE, TRUE); 05375 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05376 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 05377 05378 ATL_DEF_STMT_IDX(label_idx)=SH_PREV_IDX(curr_stmt_sh_idx); 05379 } 05380 05381 BD_XT_FLD(bd_idx, i) = AT_Tbl_Idx; 05382 BD_XT_IDX(bd_idx, i) = tmp_idx; 05383 OPND_FLD(exp_desc->shape[i-1]) = AT_Tbl_Idx; 05384 OPND_IDX(exp_desc->shape[i-1]) = tmp_idx; 05385 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE; 05386 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE; 05387 } 05388 } 05389 else { 05390 /* get the shared XT */ 05391 BD_XT_FLD(bd_idx,i) = BD_XT_FLD(shared_bd_idx,i); 05392 BD_XT_IDX(bd_idx,i) = BD_XT_IDX(shared_bd_idx,i); 05393 05394 if (reassign_XT_temps) { 05395 /* generate an assignment to the shared xt temp */ 05396 05397 /* gen the branch around test */ 05398 05399 label_idx = gen_internal_lbl(line); 05400 05401 NTR_IR_TBL(br_idx); 05402 IR_OPR(br_idx) = Br_True_Opr; 05403 IR_TYPE_IDX(br_idx) = LOGICAL_DEFAULT_TYPE; 05404 IR_LINE_NUM(br_idx) = line; 05405 IR_COL_NUM(br_idx) = col; 05406 05407 NTR_IR_TBL(ir_idx); 05408 IR_OPR(ir_idx) = Ge_Opr; 05409 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 05410 IR_LINE_NUM(ir_idx) = line; 05411 IR_COL_NUM(ir_idx) = col; 05412 05413 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 05414 IR_IDX_L(ir_idx) = BD_XT_IDX(bd_idx,i); 05415 IR_LINE_NUM_L(ir_idx) = line; 05416 IR_COL_NUM_L(ir_idx) = col; 05417 05418 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 05419 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 05420 IR_LINE_NUM_R(ir_idx) = line; 05421 IR_COL_NUM_R(ir_idx) = col; 05422 05423 IR_FLD_L(br_idx) = IR_Tbl_Idx; 05424 IR_IDX_L(br_idx) = ir_idx; 05425 IR_FLD_R(br_idx) = AT_Tbl_Idx; 05426 IR_IDX_R(br_idx) = label_idx; 05427 IR_LINE_NUM_R(br_idx) = line; 05428 IR_COL_NUM_R(br_idx) = col; 05429 05430 gen_sh(Before, If_Stmt, line, 05431 col, FALSE, FALSE, TRUE); 05432 05433 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_idx; 05434 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05435 05436 /* insert the assignment */ 05437 05438 NTR_IR_TBL(ch_asg_idx); 05439 IR_OPR(ch_asg_idx) = Asg_Opr; 05440 IR_TYPE_IDX(ch_asg_idx) = ATD_TYPE_IDX(BD_XT_IDX(bd_idx,i)); 05441 IR_LINE_NUM(ch_asg_idx) = line; 05442 IR_COL_NUM(ch_asg_idx) = col; 05443 IR_LINE_NUM_L(ch_asg_idx) = line; 05444 IR_COL_NUM_L(ch_asg_idx) = col; 05445 05446 IR_FLD_L(ch_asg_idx) = AT_Tbl_Idx; 05447 IR_IDX_L(ch_asg_idx) = BD_XT_IDX(bd_idx,i); 05448 05449 IR_FLD_R(ch_asg_idx) = OPND_FLD(exp_desc->shape[i-1]); 05450 IR_IDX_R(ch_asg_idx) = OPND_IDX(exp_desc->shape[i-1]); 05451 IR_LINE_NUM_R(ch_asg_idx) = line; 05452 IR_COL_NUM_R(ch_asg_idx) = col; 05453 05454 gen_sh(Before, Assignment_Stmt, line, 05455 col, FALSE, FALSE, TRUE); 05456 05457 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 05458 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05459 05460 gen_copyin_bounds_stmt(BD_XT_IDX(bd_idx,i)); 05461 05462 /* gen the label stmt */ 05463 05464 NTR_IR_TBL(ir_idx); 05465 IR_OPR(ir_idx) = Label_Opr; 05466 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 05467 IR_LINE_NUM(ir_idx) = line; 05468 IR_COL_NUM(ir_idx) = col; 05469 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 05470 IR_IDX_L(ir_idx) = label_idx; 05471 IR_COL_NUM_L(ir_idx) = col; 05472 IR_LINE_NUM_L(ir_idx) = line; 05473 05474 AT_DEFINED(label_idx) = TRUE; 05475 05476 gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 05477 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05478 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 05479 05480 ATL_DEF_STMT_IDX(label_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 05481 } 05482 } 05483 05484 /* calculate UB from UB = LB - 1 + XT */ 05485 05486 if (BD_LB_FLD(bd_idx, i) == CN_Tbl_Idx && 05487 compare_cn_and_value(BD_LB_IDX(bd_idx, i), 1L, Eq_Opr)) { 05488 05489 BD_UB_FLD(bd_idx,i) = BD_XT_FLD(bd_idx,i); 05490 BD_UB_IDX(bd_idx,i) = BD_XT_IDX(bd_idx,i); 05491 } 05492 else { 05493 NTR_IR_TBL(plus_idx); 05494 IR_OPR(plus_idx) = Plus_Opr; 05495 IR_LINE_NUM(plus_idx) = line; 05496 IR_COL_NUM(plus_idx) = col; 05497 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE; 05498 IR_FLD_R(plus_idx) = BD_XT_FLD(bd_idx,i); 05499 IR_IDX_R(plus_idx) = BD_XT_IDX(bd_idx,i); 05500 IR_LINE_NUM_R(plus_idx) = line; 05501 IR_COL_NUM_R(plus_idx) = col; 05502 05503 NTR_IR_TBL(minus_idx); 05504 IR_OPR(minus_idx) = Minus_Opr; 05505 IR_LINE_NUM(minus_idx) = line; 05506 IR_COL_NUM(minus_idx) = col; 05507 IR_TYPE_IDX(minus_idx) = SA_INTEGER_DEFAULT_TYPE; 05508 IR_FLD_L(minus_idx) = BD_LB_FLD(bd_idx,i); 05509 IR_IDX_L(minus_idx) = BD_LB_IDX(bd_idx,i); 05510 IR_LINE_NUM_L(minus_idx) = line; 05511 IR_COL_NUM_L(minus_idx) = col; 05512 IR_FLD_R(minus_idx) = CN_Tbl_Idx; 05513 IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX; 05514 IR_LINE_NUM_R(minus_idx) = line; 05515 IR_COL_NUM_R(minus_idx) = col; 05516 05517 if (BD_LB_FLD(bd_idx, i) == CN_Tbl_Idx) { 05518 OPND_FLD(opnd) = IR_Tbl_Idx; 05519 OPND_IDX(opnd) = minus_idx; 05520 05521 save_xref_state = xref_state; 05522 xref_state = CIF_No_Usage_Rec; 05523 save_expr_mode = expr_mode; 05524 expr_mode = Regular_Expr; 05525 05526 loc_exp_desc.rank = 0; 05527 ok = expr_semantics(&opnd, &loc_exp_desc); 05528 xref_state = save_xref_state; 05529 expr_mode = save_expr_mode; 05530 05531 COPY_OPND(IR_OPND_L(plus_idx), opnd); 05532 } 05533 else { 05534 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 05535 IR_IDX_L(plus_idx) = minus_idx; 05536 } 05537 05538 GEN_COMPILER_TMP_ASG(ch_asg_idx, 05539 tmp_idx, 05540 TRUE, /* Semantics done */ 05541 line, 05542 col, 05543 SA_INTEGER_DEFAULT_TYPE, 05544 Priv); 05545 05546 IR_FLD_R(ch_asg_idx) = IR_Tbl_Idx; 05547 IR_IDX_R(ch_asg_idx) = plus_idx; 05548 IR_LINE_NUM_R(ch_asg_idx) = line; 05549 IR_COL_NUM_R(ch_asg_idx) = col; 05550 05551 gen_sh(Before, Assignment_Stmt, line, 05552 col, FALSE, FALSE, TRUE); 05553 05554 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 05555 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05556 05557 gen_copyin_bounds_stmt(tmp_idx); 05558 05559 BD_UB_FLD(bd_idx, i) = AT_Tbl_Idx; 05560 BD_UB_IDX(bd_idx, i) = tmp_idx; 05561 } 05562 } 05563 else { 05564 05565 BD_LB_FLD(bd_idx,i) = CN_Tbl_Idx; 05566 BD_LB_IDX(bd_idx,i) = CN_INTEGER_ONE_IDX; 05567 05568 if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx || TRUE ) { /*August*/ 05569 BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]); 05570 BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]); 05571 } 05572 else { 05573 constant_shape = FALSE; 05574 05575 if (OPND_FLD(exp_desc->shape[i-1]) == AT_Tbl_Idx && 05576 ATD_CLASS(OPND_IDX(exp_desc->shape[i-1])) == Compiler_Tmp) { 05577 05578 BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]); 05579 BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]); 05580 } 05581 else { /* must do tmp assignments */ 05582 GEN_COMPILER_TMP_ASG(ch_asg_idx, 05583 tmp_idx, 05584 TRUE, /* Semantics done */ 05585 line, 05586 col, 05587 SA_INTEGER_DEFAULT_TYPE, 05588 Priv); 05589 05590 IR_FLD_R(ch_asg_idx) = OPND_FLD(exp_desc->shape[i-1]); 05591 IR_IDX_R(ch_asg_idx) = OPND_IDX(exp_desc->shape[i-1]); 05592 IR_LINE_NUM_R(ch_asg_idx) = line; 05593 IR_COL_NUM_R(ch_asg_idx) = col; 05594 05595 gen_sh(Before, Assignment_Stmt, line, 05596 col, FALSE, FALSE, TRUE); 05597 05598 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 05599 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05600 05601 gen_copyin_bounds_stmt(tmp_idx); 05602 05603 BD_UB_FLD(bd_idx, i) = AT_Tbl_Idx; 05604 BD_UB_IDX(bd_idx, i) = tmp_idx; 05605 OPND_FLD(exp_desc->shape[i-1]) = AT_Tbl_Idx; 05606 OPND_IDX(exp_desc->shape[i-1]) = tmp_idx; 05607 SHAPE_FOLDABLE(exp_desc->shape[i-1]) = FALSE; 05608 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i-1]) = FALSE; 05609 } 05610 } 05611 05612 BD_XT_FLD(bd_idx,i) = BD_UB_FLD(bd_idx,i); 05613 BD_XT_IDX(bd_idx,i) = BD_UB_IDX(bd_idx,i); 05614 } 05615 05616 # if defined(GENERATE_WHIRL) 05617 if (BD_UB_FLD(bd_idx,i) == AT_Tbl_Idx && 05618 AT_OBJ_CLASS(BD_UB_IDX(bd_idx,i)) == Data_Obj && 05619 ATD_CLASS(BD_UB_IDX(bd_idx,i)) == Compiler_Tmp && 05620 ATD_TASK_PRIVATE(BD_UB_IDX(bd_idx,i))) { 05621 05622 /* need to initialize this to one to hack away an mp */ 05623 /* lowerer problem. The lowerer will try to allocate */ 05624 /* the array as a vla on entry to the parallel region */ 05625 /* Setting the bound to one prevents seg faults. */ 05626 05627 gen_temp_init(BD_UB_IDX(bd_idx,i), 05628 CN_INTEGER_ONE_IDX); 05629 } 05630 # endif 05631 } 05632 05633 if (exp_desc->type == Character && 05634 r_opnd != NULL) { 05635 ok = validate_char_len(r_opnd, exp_desc); 05636 } 05637 05638 if (exp_desc->type == Character && 05639 TYP_FLD(exp_desc->type_idx) != CN_Tbl_Idx) { 05640 constant_shape = FALSE; 05641 } 05642 05643 BD_RANK(bd_idx) = exp_desc->rank; 05644 BD_LINE_NUM(bd_idx) = line; 05645 BD_COLUMN_NUM(bd_idx) = col; 05646 05647 determine_num_elements(&num_el_opnd, exp_desc, line, col); 05648 05649 loc_exp_desc.rank = 0; 05650 save_xref_state = xref_state; 05651 xref_state = CIF_No_Usage_Rec; 05652 05653 ok = expr_semantics(&num_el_opnd, &loc_exp_desc); 05654 05655 xref_state = save_xref_state; 05656 05657 if (loc_exp_desc.constant) { 05658 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx; 05659 BD_LEN_IDX(bd_idx) = OPND_IDX(num_el_opnd); 05660 } 05661 else if (OPND_FLD(num_el_opnd) == AT_Tbl_Idx && 05662 ATD_CLASS(OPND_IDX(num_el_opnd)) == Compiler_Tmp) { 05663 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 05664 BD_LEN_IDX(bd_idx) = OPND_IDX(num_el_opnd); 05665 } 05666 else { /* tmp assign the num_elements */ 05667 05668 GEN_COMPILER_TMP_ASG(ch_asg_idx, 05669 tmp_idx, 05670 TRUE, /* Semantics done */ 05671 line, 05672 col, 05673 loc_exp_desc.type_idx, 05674 Priv); 05675 05676 COPY_OPND(IR_OPND_R(ch_asg_idx), num_el_opnd); 05677 gen_sh(Before, Assignment_Stmt, line, 05678 col, FALSE, FALSE, TRUE); 05679 05680 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 05681 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05682 05683 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 05684 BD_LEN_IDX(bd_idx) = tmp_idx; 05685 } 05686 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape; 05687 05688 if (constant_shape) { 05689 BD_ARRAY_SIZE(bd_idx) = Constant_Size; 05690 } 05691 else { 05692 BD_ARRAY_SIZE(bd_idx) = Var_Len_Array; 05693 } 05694 05695 set_stride_for_first_dim(exp_desc->type_idx, &stride); 05696 05697 BD_SM_FLD(bd_idx, 1) = stride.fld; 05698 BD_SM_IDX(bd_idx, 1) = stride.idx; 05699 05700 for (i = 2; i <= BD_RANK(bd_idx); i++) { 05701 NTR_IR_TBL(mult_idx); /* Create Stride * Extent */ 05702 IR_OPR(mult_idx) = Mult_Opr; 05703 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 05704 IR_LINE_NUM(mult_idx) = line; 05705 IR_COL_NUM(mult_idx) = col; 05706 IR_FLD_L(mult_idx) = BD_SM_FLD(bd_idx, i - 1); 05707 IR_IDX_L(mult_idx) = BD_SM_IDX(bd_idx, i - 1); 05708 IR_LINE_NUM_L(mult_idx) = line; 05709 IR_COL_NUM_L(mult_idx) = col; 05710 IR_FLD_R(mult_idx) = BD_XT_FLD(bd_idx, i - 1); 05711 IR_IDX_R(mult_idx) = BD_XT_IDX(bd_idx, i - 1); 05712 IR_LINE_NUM_R(mult_idx) = line; 05713 IR_COL_NUM_R(mult_idx) = col; 05714 OPND_FLD(sm_opnd) = IR_Tbl_Idx; 05715 OPND_IDX(sm_opnd) = mult_idx; 05716 05717 loc_exp_desc.rank = 0; 05718 save_xref_state = xref_state; 05719 xref_state = CIF_No_Usage_Rec; 05720 05721 ok = expr_semantics(&sm_opnd, &loc_exp_desc); 05722 05723 xref_state = save_xref_state; 05724 05725 if (loc_exp_desc.constant) { 05726 BD_SM_FLD(bd_idx, i) = CN_Tbl_Idx; 05727 BD_SM_IDX(bd_idx, i) = OPND_IDX(sm_opnd); 05728 } 05729 else if (OPND_FLD(sm_opnd) == AT_Tbl_Idx && 05730 ATD_CLASS(OPND_IDX(sm_opnd)) == Compiler_Tmp) { 05731 BD_SM_FLD(bd_idx, i) = AT_Tbl_Idx; 05732 BD_SM_IDX(bd_idx, i) = OPND_IDX(sm_opnd); 05733 } 05734 else { 05735 05736 GEN_COMPILER_TMP_ASG(ch_asg_idx, 05737 tmp_idx, 05738 TRUE, /* Semantics done */ 05739 line, 05740 col, 05741 loc_exp_desc.type_idx, 05742 Priv); 05743 05744 COPY_OPND(IR_OPND_R(ch_asg_idx), sm_opnd); 05745 gen_sh(Before, Assignment_Stmt, line, 05746 col, FALSE, FALSE, TRUE); 05747 05748 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 05749 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05750 05751 BD_SM_FLD(bd_idx, i) = AT_Tbl_Idx; 05752 BD_SM_IDX(bd_idx, i) = tmp_idx; 05753 } 05754 } 05755 05756 BD_FLOW_DEPENDENT(bd_idx) = TRUE; 05757 05758 *res_bd_idx = ntr_array_in_bd_tbl(bd_idx); 05759 05760 TRACE (Func_Exit, "gen_bd_entry", NULL); 05761 05762 return(constant_shape); 05763 05764 } /* gen_bd_entry */ 05765 05766 /******************************************************************************\ 05767 |* *| 05768 |* Description: *| 05769 |* Creates a temp dope vector assignment stmt. *| 05770 |* *| 05771 |* Input parameters: *| 05772 |* list_idx - IL idx for actual arg. *| 05773 |* info_idx - arg_info_list idx. *| 05774 |* *| 05775 |* Output parameters: *| 05776 |* NONE *| 05777 |* *| 05778 |* Returns: *| 05779 |* attr idx for temp dope vector. *| 05780 |* *| 05781 \******************************************************************************/ 05782 05783 static int create_tmp_DV_asg(int list_idx, 05784 int info_idx) 05785 05786 { 05787 int asg_idx; 05788 int column; 05789 int line; 05790 int tmp_idx; 05791 05792 05793 TRACE (Func_Entry, "create_tmp_DV_asg", NULL); 05794 05795 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 05796 &line, 05797 &column); 05798 05799 # ifdef _DEBUG 05800 if (info_idx == NULL_IDX) { 05801 PRINTMSG(line, 626, Internal, column, 05802 "valid info_idx", "create_tmp_DV_asg"); 05803 } 05804 # endif 05805 05806 GEN_COMPILER_TMP_ASG(asg_idx, 05807 tmp_idx, 05808 TRUE, /* Semantics done */ 05809 line, 05810 column, 05811 arg_info_list[info_idx].ed.type_idx, 05812 Priv); 05813 05814 IR_OPR(asg_idx) = Dv_Whole_Copy_Opr; 05815 IR_DV_DIM(asg_idx) = arg_info_list[info_idx].ed.rank; 05816 /* March ATD_IM_A_DOPE(tmp_idx) = TRUE; */ 05817 ATD_ARRAY_IDX(tmp_idx) = ATD_ARRAY_IDX(find_base_attr(&IL_OPND(list_idx), 05818 &line, &column)); 05819 05820 05821 if (IL_FLD(list_idx) == IR_Tbl_Idx && 05822 IR_OPR(IL_IDX(list_idx)) == Whole_Substring_Opr) { 05823 05824 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx))); 05825 } 05826 05827 if (IL_FLD(list_idx) == IR_Tbl_Idx && 05828 IR_OPR(IL_IDX(list_idx)) == Whole_Subscript_Opr) { 05829 05830 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx))); 05831 } 05832 05833 /* had better be a deref_opr */ 05834 # if 0 /*fzhao April*/ 05835 if (IL_FLD(list_idx) != IR_Tbl_Idx || 05836 IR_OPR(IL_IDX(list_idx)) != Dv_Deref_Opr) { 05837 05838 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 05839 &line, 05840 &column); 05841 PRINTMSG(line, 861, Internal, column, 05842 "create_tmp_DV_asg"); 05843 } 05844 # endif 05845 05846 COPY_OPND(IR_OPND_R(asg_idx), IR_OPND_L(IL_IDX(list_idx))); 05847 05848 gen_sh(Before, Assignment_Stmt, stmt_start_line, 05849 stmt_start_col, FALSE, FALSE, TRUE); 05850 05851 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05852 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05853 05854 TRACE (Func_Exit, "create_tmp_DV_asg", NULL); 05855 05856 return(tmp_idx); 05857 05858 } /* create_tmp_DV_asg */ 05859 05860 /******************************************************************************\ 05861 |* *| 05862 |* Description: *| 05863 |* Find the correct attr to set AT_ACTUAL_ARG and set it. *| 05864 |* *| 05865 |* Input parameters: *| 05866 |* list_idx - IL idx for actual arg. *| 05867 |* *| 05868 |* Output parameters: *| 05869 |* NONE *| 05870 |* *| 05871 |* Returns: *| 05872 |* NOTHING *| 05873 |* *| 05874 \******************************************************************************/ 05875 05876 static void set_at_actual_arg(int list_idx) 05877 05878 { 05879 opnd_type opnd; 05880 05881 TRACE (Func_Entry, "set_at_actual_arg", NULL); 05882 05883 COPY_OPND(opnd, IL_OPND(list_idx)); 05884 05885 while (TRUE) { 05886 switch (OPND_FLD(opnd)) { 05887 case AT_Tbl_Idx : 05888 AT_ACTUAL_ARG(OPND_IDX(opnd)) = TRUE; 05889 goto EXIT; 05890 05891 case IR_Tbl_Idx : 05892 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 05893 break; 05894 05895 default : 05896 goto EXIT; 05897 } 05898 } 05899 05900 EXIT: 05901 05902 TRACE (Func_Exit, "set_at_actual_arg", NULL); 05903 05904 return; 05905 05906 } /* set_at_actual_arg */ 05907 05908 /******************************************************************************\ 05909 |* *| 05910 |* Description: *| 05911 |* Creates an operand that holds the size needed for a heap array tmp. *| 05912 |* *| 05913 |* Input parameters: *| 05914 |* opnd - holds number of elements on entry. *| 05915 |* type_idx - type tbl idx for tmp. *| 05916 |* *| 05917 |* Output parameters: *| 05918 |* opnd - holds resultant expression for tmp size. *| 05919 |* *| 05920 |* Returns: *| 05921 |* NOTHING *| 05922 |* *| 05923 \******************************************************************************/ 05924 void determine_tmp_size(opnd_type *opnd, 05925 int type_idx) 05926 05927 { 05928 int col; 05929 size_offset_type length; 05930 int line; 05931 expr_arg_type loc_exp_desc; 05932 int mult_idx; 05933 size_offset_type result; 05934 cif_usage_code_type save_xref_state; 05935 05936 # if !defined(_HEAP_REQUEST_IN_BYTES) 05937 long_type constant; 05938 int div_idx; 05939 int plus_idx; 05940 # endif 05941 05942 05943 TRACE (Func_Entry, "determine_tmp_size", NULL); 05944 05945 find_opnd_line_and_column(opnd, &line, &col); 05946 05947 # ifdef _HEAP_REQUEST_IN_BYTES 05948 05949 /* solaris compiler expects heap request in bytes */ 05950 05951 /* opnd HOLDS THE NUMBER OF ELEMENTS ON ENTRY. */ 05952 05953 if (TYP_TYPE(type_idx) == Character) { 05954 05955 NTR_IR_TBL(mult_idx); 05956 IR_OPR(mult_idx) = Mult_Opr; 05957 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 05958 IR_LINE_NUM(mult_idx) = line; 05959 IR_COL_NUM(mult_idx) = col; 05960 COPY_OPND(IR_OPND_L(mult_idx), (*opnd)); 05961 IR_FLD_R(mult_idx) = TYP_FLD(type_idx); 05962 IR_IDX_R(mult_idx) = TYP_IDX(type_idx); 05963 IR_LINE_NUM_R(mult_idx) = line; 05964 IR_COL_NUM_R(mult_idx) = col; 05965 05966 05967 OPND_FLD((*opnd)) = IR_Tbl_Idx; 05968 OPND_IDX((*opnd)) = mult_idx; 05969 } 05970 else if (TYP_TYPE(type_idx) == Structure && 05971 ATT_CHAR_SEQ(TYP_IDX(type_idx))) { 05972 NTR_IR_TBL(mult_idx); 05973 IR_OPR(mult_idx) = Mult_Opr; 05974 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 05975 IR_LINE_NUM(mult_idx) = line; 05976 IR_COL_NUM(mult_idx) = col; 05977 COPY_OPND(IR_OPND_L(mult_idx), (*opnd)); 05978 05979 # if defined(_DEBUG) 05980 05981 if (ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)) != CN_Tbl_Idx) { 05982 PRINTMSG(line, 1201, Internal, col, 05983 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 05984 } 05985 05986 # endif 05987 05988 result.idx = CN_INTEGER_CHAR_BIT_IDX; 05989 result.fld = CN_Tbl_Idx; 05990 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 05991 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 05992 05993 size_offset_binary_calc(&length, 05994 &result, 05995 Div_Opr, 05996 &result); 05997 05998 if (result.fld == NO_Tbl_Idx) { 05999 IR_FLD_R(mult_idx) = CN_Tbl_Idx; 06000 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx, 06001 FALSE, 06002 result.constant); 06003 } 06004 else { 06005 IR_FLD_R(mult_idx) = result.fld; 06006 IR_IDX_R(mult_idx) = result.idx; 06007 } 06008 06009 IR_LINE_NUM_R(mult_idx) = line; 06010 IR_COL_NUM_R(mult_idx) = col; 06011 06012 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06013 OPND_IDX((*opnd)) = mult_idx; 06014 } 06015 else { 06016 NTR_IR_TBL(mult_idx); 06017 IR_OPR(mult_idx) = Mult_Opr; 06018 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 06019 IR_LINE_NUM(mult_idx) = line; 06020 IR_COL_NUM(mult_idx) = col; 06021 COPY_OPND(IR_OPND_L(mult_idx), (*opnd)); 06022 06023 if (TYP_TYPE(type_idx) == Structure) { 06024 result.idx = CN_INTEGER_CHAR_BIT_IDX; 06025 result.fld = CN_Tbl_Idx; 06026 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 06027 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 06028 06029 # if defined(_DEBUG) 06030 06031 if (length.fld != CN_Tbl_Idx) { 06032 PRINTMSG(line, 1201, Internal, col, 06033 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 06034 } 06035 # endif 06036 06037 size_offset_binary_calc(&length, 06038 &result, 06039 Div_Opr, 06040 &result); 06041 } 06042 else { 06043 C_TO_F_INT(result.constant, 06044 (storage_bit_size_tbl[TYP_LINEAR(type_idx)] / 8), 06045 CG_INTEGER_DEFAULT_TYPE); 06046 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 06047 result.fld = NO_Tbl_Idx; 06048 } 06049 06050 if (result.fld == NO_Tbl_Idx) { 06051 IR_FLD_R(mult_idx) = CN_Tbl_Idx; 06052 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx, 06053 FALSE, 06054 result.constant); 06055 } 06056 else { 06057 IR_FLD_R(mult_idx) = result.fld; 06058 IR_IDX_R(mult_idx) = result.idx; 06059 } 06060 06061 IR_LINE_NUM_R(mult_idx) = line; 06062 IR_COL_NUM_R(mult_idx) = col; 06063 06064 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06065 OPND_IDX((*opnd)) = mult_idx; 06066 } 06067 06068 # else 06069 06070 /* cray compiler expects heap request in words */ 06071 06072 /* opnd HOLDS THE NUMBER OF ELEMENTS ON ENTRY. */ 06073 06074 if (TYP_TYPE(type_idx) == Character) { 06075 06076 NTR_IR_TBL(mult_idx); 06077 IR_OPR(mult_idx) = Mult_Opr; 06078 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 06079 IR_LINE_NUM(mult_idx) = line; 06080 IR_COL_NUM(mult_idx) = col; 06081 COPY_OPND(IR_OPND_L(mult_idx), (*opnd)); 06082 IR_FLD_R(mult_idx) = TYP_FLD(type_idx); 06083 IR_IDX_R(mult_idx) = TYP_IDX(type_idx); 06084 IR_LINE_NUM_R(mult_idx) = line; 06085 IR_COL_NUM_R(mult_idx) = col; 06086 06087 /* now calculate word size from byte size */ 06088 NTR_IR_TBL(div_idx); 06089 IR_OPR(div_idx) = Div_Opr; 06090 IR_TYPE_IDX(div_idx) = SA_INTEGER_DEFAULT_TYPE; 06091 IR_LINE_NUM(div_idx) = line; 06092 IR_COL_NUM(div_idx) = col; 06093 IR_FLD_R(div_idx) = CN_Tbl_Idx; 06094 constant = TARGET_CHARS_PER_WORD; 06095 IR_IDX_R(div_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 06096 TARGET_CHARS_PER_WORD); 06097 IR_LINE_NUM_R(div_idx) = line; 06098 IR_COL_NUM_R(div_idx) = col; 06099 06100 NTR_IR_TBL(plus_idx); 06101 IR_OPR(plus_idx) = Plus_Opr; 06102 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE; 06103 IR_LINE_NUM(plus_idx) = line; 06104 IR_COL_NUM(plus_idx) = col; 06105 IR_FLD_L(div_idx) = IR_Tbl_Idx; 06106 IR_IDX_L(div_idx) = plus_idx; 06107 06108 constant--; 06109 IR_FLD_R(plus_idx) = CN_Tbl_Idx; 06110 IR_IDX_R(plus_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 06111 constant); 06112 IR_LINE_NUM_R(plus_idx) = line; 06113 IR_COL_NUM_R(plus_idx) = col; 06114 06115 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 06116 IR_IDX_L(plus_idx) = mult_idx; 06117 06118 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06119 OPND_IDX((*opnd)) = div_idx; 06120 } 06121 else if (TYP_TYPE(type_idx) == Structure && 06122 ATT_CHAR_SEQ(TYP_IDX(type_idx))) { 06123 06124 NTR_IR_TBL(mult_idx); 06125 IR_OPR(mult_idx) = Mult_Opr; 06126 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 06127 IR_LINE_NUM(mult_idx) = line; 06128 IR_COL_NUM(mult_idx) = col; 06129 COPY_OPND(IR_OPND_L(mult_idx), (*opnd)); 06130 06131 # if defined(_DEBUG) 06132 06133 if (ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)) != CN_Tbl_Idx) { 06134 PRINTMSG(line, 1201, Internal, col, 06135 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 06136 } 06137 06138 # endif 06139 06140 result.idx = CN_INTEGER_CHAR_BIT_IDX; 06141 result.fld = CN_Tbl_Idx; 06142 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 06143 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 06144 06145 size_offset_binary_calc(&length, 06146 &result, 06147 Div_Opr, 06148 &result); 06149 06150 if (result.fld == NO_Tbl_Idx) { 06151 IR_FLD_R(mult_idx) = CN_Tbl_Idx; 06152 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx, 06153 FALSE, 06154 result.constant); 06155 } 06156 else { 06157 IR_FLD_R(mult_idx) = result.fld; 06158 IR_IDX_R(mult_idx) = result.idx; 06159 } 06160 06161 IR_LINE_NUM_R(mult_idx) = line; 06162 IR_COL_NUM_R(mult_idx) = col; 06163 06164 /* now calculate word size from byte size */ 06165 06166 NTR_IR_TBL(div_idx); 06167 IR_OPR(div_idx) = Div_Opr; 06168 IR_TYPE_IDX(div_idx) = SA_INTEGER_DEFAULT_TYPE; 06169 IR_LINE_NUM(div_idx) = line; 06170 IR_COL_NUM(div_idx) = col; 06171 IR_FLD_R(div_idx) = CN_Tbl_Idx; 06172 constant = TARGET_CHARS_PER_WORD; 06173 IR_IDX_R(div_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 06174 TARGET_CHARS_PER_WORD); 06175 IR_LINE_NUM_R(div_idx) = line; 06176 IR_COL_NUM_R(div_idx) = col; 06177 06178 NTR_IR_TBL(plus_idx); 06179 IR_OPR(plus_idx) = Plus_Opr; 06180 IR_TYPE_IDX(plus_idx) = SA_INTEGER_DEFAULT_TYPE; 06181 IR_LINE_NUM(plus_idx) = line; 06182 IR_COL_NUM(plus_idx) = col; 06183 IR_FLD_L(div_idx) = IR_Tbl_Idx; 06184 IR_IDX_L(div_idx) = plus_idx; 06185 06186 constant--; 06187 IR_FLD_R(plus_idx) = CN_Tbl_Idx; 06188 IR_IDX_R(plus_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 06189 constant); 06190 IR_LINE_NUM_R(plus_idx) = line; 06191 IR_COL_NUM_R(plus_idx) = col; 06192 06193 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 06194 IR_IDX_L(plus_idx) = mult_idx; 06195 06196 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06197 OPND_IDX((*opnd)) = div_idx; 06198 } 06199 else { 06200 06201 NTR_IR_TBL(mult_idx); 06202 IR_OPR(mult_idx) = Mult_Opr; 06203 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 06204 IR_LINE_NUM(mult_idx) = line; 06205 IR_COL_NUM(mult_idx) = col; 06206 COPY_OPND(IR_OPND_L(mult_idx), (*opnd)); 06207 06208 if (TYP_TYPE(type_idx) == Structure) { 06209 result.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 06210 result.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 06211 } 06212 else { 06213 C_TO_F_INT(result.constant, 06214 storage_bit_size_tbl[TYP_LINEAR(type_idx)], 06215 CG_INTEGER_DEFAULT_TYPE); 06216 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 06217 result.fld = NO_Tbl_Idx; 06218 } 06219 06220 BITS_TO_WORDS(result, TARGET_BITS_PER_WORD); 06221 06222 IR_IDX_R(mult_idx) = ntr_const_tbl(result.type_idx, 06223 FALSE, 06224 result.constant); 06225 06226 IR_FLD_R(mult_idx) = CN_Tbl_Idx; 06227 IR_LINE_NUM_R(mult_idx) = line; 06228 IR_COL_NUM_R(mult_idx) = col; 06229 06230 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06231 OPND_IDX((*opnd)) = mult_idx; 06232 } 06233 06234 # endif 06235 06236 loc_exp_desc.rank = 0; 06237 save_xref_state = xref_state; 06238 xref_state = CIF_No_Usage_Rec; 06239 06240 expr_semantics(opnd, &loc_exp_desc); 06241 06242 xref_state = save_xref_state; 06243 06244 TRACE (Func_Exit, "determine_tmp_size", NULL); 06245 06246 return; 06247 06248 } /* determine_tmp_size */ 06249 06250 /******************************************************************************\ 06251 |* *| 06252 |* Description: *| 06253 |* When we have a copy in, copy out situation, and have a section ref, *| 06254 |* we must save all variable subscript, substring, section values into *| 06255 |* tmps. This is because they may be modified by the callee and we have *| 06256 |* to copy the array syntax ref back out after the call. This routine *| 06257 |* replaces all these variable things with tmps. *| 06258 |* *| 06259 |* Input parameters: *| 06260 |* list_idx - index to list text for actual arg. *| 06261 |* *| 06262 |* Output parameters: *| 06263 |* NONE *| 06264 |* *| 06265 |* Returns: *| 06266 |* NOTHING *| 06267 |* *| 06268 \******************************************************************************/ 06269 06270 static void save_array_syntax_subscripts(int list_idx) 06271 06272 06273 { 06274 int asg_idx; 06275 int column; 06276 int i; 06277 int ir_idx; 06278 int k; 06279 int l_idx; 06280 int line; 06281 int t_idx; 06282 int tmp_idx; 06283 06284 06285 TRACE (Func_Entry, "save_array_syntax_subscripts", NULL); 06286 06287 ir_idx = IL_IDX(list_idx); 06288 06289 while (TRUE) { 06290 06291 if (IR_OPR(ir_idx) == Subscript_Opr || 06292 IR_OPR(ir_idx) == Section_Subscript_Opr || 06293 IR_OPR(ir_idx) == Substring_Opr) { 06294 06295 l_idx = IR_IDX_R(ir_idx); 06296 06297 for (k = 0; k < IR_LIST_CNT_R(ir_idx); k++) { 06298 06299 if (!IL_CONSTANT_SUBSCRIPT(l_idx)) { 06300 06301 if (IL_FLD(l_idx) == IR_Tbl_Idx && 06302 IR_OPR(IL_IDX(l_idx)) == Triplet_Opr) { 06303 06304 t_idx = IR_IDX_L(IL_IDX(l_idx)); 06305 for (i = 0; i < 3; i++) { 06306 06307 if (! IL_CONSTANT_SUBSCRIPT(t_idx)) { /* create tmp */ 06308 find_opnd_line_and_column((opnd_type *) &IL_OPND(t_idx), 06309 &line, 06310 &column); 06311 06312 GEN_COMPILER_TMP_ASG(asg_idx, 06313 tmp_idx, 06314 TRUE, /* Semantics done */ 06315 line, 06316 column, 06317 CG_INTEGER_DEFAULT_TYPE, 06318 Priv); 06319 06320 COPY_OPND(IR_OPND_R(asg_idx), IL_OPND(t_idx)); 06321 06322 gen_sh(Before, Assignment_Stmt, stmt_start_line, 06323 stmt_start_col, FALSE, FALSE, TRUE); 06324 06325 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 06326 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 06327 06328 IL_FLD(t_idx) = AT_Tbl_Idx; 06329 IL_IDX(t_idx) = tmp_idx; 06330 IL_LINE_NUM(t_idx) = line; 06331 IL_COL_NUM(t_idx) = column; 06332 } 06333 06334 t_idx = IL_NEXT_LIST_IDX(t_idx); 06335 } 06336 } 06337 else { /* create tmp */ 06338 find_opnd_line_and_column((opnd_type *) &IL_OPND(l_idx), 06339 &line, 06340 &column); 06341 GEN_COMPILER_TMP_ASG(asg_idx, 06342 tmp_idx, 06343 TRUE, /* Semantics done */ 06344 line, 06345 column, 06346 CG_INTEGER_DEFAULT_TYPE, 06347 Priv); 06348 06349 COPY_OPND(IR_OPND_R(asg_idx), IL_OPND(l_idx)); 06350 06351 gen_sh(Before, Assignment_Stmt, stmt_start_line, 06352 stmt_start_col, FALSE, FALSE, TRUE); 06353 06354 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 06355 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 06356 06357 IL_FLD(l_idx) = AT_Tbl_Idx; 06358 IL_IDX(l_idx) = tmp_idx; 06359 IL_LINE_NUM(l_idx) = line; 06360 IL_COL_NUM(l_idx) = column; 06361 } 06362 } 06363 06364 l_idx = IL_NEXT_LIST_IDX(l_idx); 06365 } 06366 } 06367 06368 if (IR_FLD_L(ir_idx) != IR_Tbl_Idx) { 06369 break; 06370 } 06371 else { 06372 ir_idx = IR_IDX_L(ir_idx); 06373 } 06374 } 06375 06376 TRACE (Func_Exit, "save_array_syntax_subscripts", NULL); 06377 06378 return; 06379 06380 } /* save_array_syntax_subscripts */ 06381 06382 /******************************************************************************\ 06383 |* *| 06384 |* Description: *| 06385 |* Determine the number of elements in an array expression. *| 06386 |* *| 06387 |* Input parameters: *| 06388 |* exp_desc - expression descriptor for array expression. *| 06389 |* *| 06390 |* Output parameters: *| 06391 |* opnd - number of elements expression. *| 06392 |* *| 06393 |* Returns: *| 06394 |* NOTHING *| 06395 |* *| 06396 \******************************************************************************/ 06397 06398 static void determine_num_elements(opnd_type *opnd, 06399 expr_arg_type *exp_desc, 06400 int line, 06401 int col) 06402 06403 { 06404 int i; 06405 int list_idx; 06406 int max_idx; 06407 int mult_idx; 06408 06409 06410 TRACE (Func_Entry, "determine_num_elements", NULL); 06411 06412 *opnd = null_opnd; 06413 06414 for (i = 0; i < exp_desc->rank; i++) { 06415 NTR_IR_TBL(max_idx); 06416 IR_OPR(max_idx) = Max_Opr; 06417 IR_TYPE_IDX(max_idx) = SA_INTEGER_DEFAULT_TYPE; 06418 IR_LINE_NUM(max_idx) = line; 06419 IR_COL_NUM(max_idx) = col; 06420 06421 NTR_IR_LIST_TBL(list_idx); 06422 IR_FLD_L(max_idx) = IL_Tbl_Idx; 06423 IR_IDX_L(max_idx) = list_idx; 06424 IR_LIST_CNT_L(max_idx) = 2; 06425 06426 IL_FLD(list_idx) = CN_Tbl_Idx; 06427 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 06428 IL_LINE_NUM(list_idx) = IR_LINE_NUM(max_idx); 06429 IL_COL_NUM(list_idx) = IR_COL_NUM(max_idx); 06430 06431 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06432 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06433 06434 COPY_OPND(IL_OPND(IL_NEXT_LIST_IDX(list_idx)), 06435 exp_desc->shape[i]); 06436 IL_LINE_NUM(IL_NEXT_LIST_IDX(list_idx)) = line; 06437 IL_COL_NUM(IL_NEXT_LIST_IDX(list_idx)) = col; 06438 06439 if (OPND_FLD((*opnd)) == NO_Tbl_Idx) { 06440 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06441 OPND_IDX((*opnd)) = max_idx; 06442 } 06443 else { 06444 NTR_IR_TBL(mult_idx); 06445 IR_OPR(mult_idx) = Mult_Opr; 06446 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 06447 IR_LINE_NUM(mult_idx) = line; 06448 IR_COL_NUM(mult_idx) = col; 06449 06450 COPY_OPND(IR_OPND_L(mult_idx), (*opnd)); 06451 IR_FLD_R(mult_idx) = IR_Tbl_Idx; 06452 IR_IDX_R(mult_idx) = max_idx; 06453 06454 OPND_IDX((*opnd)) = mult_idx; 06455 } 06456 } 06457 06458 06459 TRACE (Func_Exit, "determine_num_elements", NULL); 06460 06461 return; 06462 06463 } /* determine_num_elements */ 06464 06465 /******************************************************************************\ 06466 |* *| 06467 |* Description: *| 06468 |* This routine handles function calls in expressions by deciding *| 06469 |* whether to pull the function call out of the expression and replace *| 06470 |* it with a temp and also decide whether the result requires the *| 06471 |* function call to be replaced with a subroutine call where the result *| 06472 |* is the first argument. *| 06473 |* *| 06474 |* Input parameters: *| 06475 |* result - the tree with the call opr. *| 06476 |* *| 06477 |* Output parameters: *| 06478 |* result - opnd pointing to the tmp from the flattened function. *| 06479 |* *| 06480 |* Returns: *| 06481 |* NOTHING *| 06482 |* *| 06483 \******************************************************************************/ 06484 06485 void flatten_function_call(opnd_type *result) 06486 06487 06488 { 06489 int alloc_idx; 06490 int asg_idx; 06491 int attr_idx; 06492 int base_asg_idx; 06493 opnd_type base_opnd; 06494 int base_tmp_idx; 06495 int bd_idx; 06496 int cn_idx; 06497 int col; 06498 int dealloc_idx; 06499 int dv_idx; 06500 expr_arg_type elemental_exp_desc; 06501 expr_arg_type exp_desc; 06502 int ir_idx; 06503 int line; 06504 int list_idx; 06505 int loc_idx; 06506 int new_stmt_idx; 06507 int num_args; 06508 boolean ok; 06509 opnd_type opnd; 06510 int res_list_idx; 06511 boolean save_keep_orig_sh; 06512 int save_orig_sh_idx; 06513 opnd_type size_opnd; 06514 int spec_idx; 06515 int unused1; 06516 int unused2; 06517 boolean save_defer_stmt_expansion; 06518 int tmp_idx = NULL_IDX; 06519 int type_idx; 06520 boolean variable_size = FALSE; 06521 06522 # ifdef _ALLOCATE_IS_CALL 06523 int call_idx; 06524 int sub_idx; 06525 long_type the_constant; 06526 int tmp_array_idx; 06527 # endif 06528 06529 06530 TRACE (Func_Entry, "flatten_function_call", NULL); 06531 06532 if (no_func_expansion) { 06533 goto EXIT; 06534 } 06535 06536 ir_idx = OPND_IDX((*result)); 06537 06538 spec_idx = IR_IDX_L(ir_idx); 06539 attr_idx = ATP_RSLT_IDX(spec_idx); 06540 type_idx = ATD_TYPE_IDX(attr_idx); 06541 06542 line = IR_LINE_NUM(ir_idx); 06543 col = IR_COL_NUM(ir_idx); 06544 06545 save_orig_sh_idx = orig_sh_idx; 06546 06547 stmt_expansion_control_start(); 06548 save_defer_stmt_expansion = defer_stmt_expansion; 06549 defer_stmt_expansion = FALSE; 06550 06551 if (! keep_orig_sh) { 06552 orig_sh_idx = curr_stmt_sh_idx; 06553 } 06554 06555 # if 0 06556 06557 gen_sh(Before, Call_Stmt, stmt_start_line, stmt_start_col, 06558 FALSE, FALSE, TRUE); 06559 # endif 06560 06561 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 06562 new_stmt_idx = curr_stmt_sh_idx; 06563 06564 num_args = IR_LIST_CNT_R(ir_idx); 06565 06566 if (FALSE && FUNCTION_MUST_BE_SUBROUTINE(attr_idx) ) { /* March */ 06567 06568 NTR_IR_LIST_TBL(res_list_idx); 06569 IL_ARG_DESC_VARIANT(res_list_idx) = TRUE; 06570 IL_NEXT_LIST_IDX(res_list_idx) = IR_IDX_R(ir_idx); 06571 IR_IDX_R(ir_idx) = res_list_idx; 06572 IR_LIST_CNT_R(ir_idx)++; 06573 } 06574 06575 elemental_exp_desc = init_exp_desc; 06576 elemental_exp_desc.type_idx = type_idx; 06577 elemental_exp_desc.type = TYP_TYPE(type_idx); 06578 elemental_exp_desc.linear_type = TYP_LINEAR(type_idx); 06579 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 06580 ok = final_arg_work(&opnd, IR_IDX_L(ir_idx), num_args, &elemental_exp_desc); 06581 COPY_OPND(IR_OPND_R(ir_idx), opnd); 06582 06583 curr_stmt_sh_idx = new_stmt_idx; 06584 06585 #if 0 06586 if (FUNCTION_MUST_BE_SUBROUTINE(attr_idx) || 06587 ATP_ELEMENTAL(spec_idx)) { 06588 if (ATP_ELEMENTAL(spec_idx)) { 06589 #endif 06590 06591 bd_idx = ATD_ARRAY_IDX(attr_idx); 06592 06593 if (TYP_TYPE(type_idx) == Character && 06594 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char && 06595 ATP_PROC(IR_IDX_L(ir_idx)) != Dummy_Proc && 06596 attr_idx != SCP_ATTR_IDX(curr_scp_idx) && 06597 !AT_IS_INTRIN(attr_idx)) { 06598 06599 PRINTMSG(line, 939, Error, col, AT_OBJ_NAME_PTR(attr_idx)); 06600 } 06601 06602 #if 0 06603 06604 if ( /* ATP_PROC(IR_IDX_L(ir_idx)) != Intrin_Proc && */ 06605 (TYP_TYPE(type_idx) == Character && 06606 TYP_CHAR_CLASS(type_idx) == Var_Len_Char || 06607 bd_idx != NULL_IDX && 06608 BD_ARRAY_SIZE(bd_idx) == Var_Len_Array)) { 06609 06610 save_keep_orig_sh = keep_orig_sh; 06611 keep_orig_sh = TRUE; 06612 06613 process_variable_size_func(attr_idx, /* The result */ 06614 IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)), 06615 (ATP_EXTRA_DARG(IR_IDX_L(ir_idx)) ? 06616 ATP_FIRST_IDX(IR_IDX_L(ir_idx)) + 1 : 06617 ATP_FIRST_IDX(IR_IDX_L(ir_idx))), 06618 (ATP_EXTRA_DARG(IR_IDX_L(ir_idx)) ? 06619 ATP_NUM_DARGS(IR_IDX_L(ir_idx)) - 1 : 06620 ATP_NUM_DARGS(IR_IDX_L(ir_idx))), 06621 &type_idx, /* Gets new type idx - if one */ 06622 &bd_idx); /* Gets new bd idx - if one */ 06623 06624 06625 if (! ATD_IM_A_DOPE(attr_idx) && 06626 ((TYP_TYPE(type_idx) == Character && 06627 TYP_CHAR_CLASS(type_idx) == Var_Len_Char) || 06628 (bd_idx != NULL_IDX && 06629 BD_ARRAY_SIZE(bd_idx) == Var_Len_Array))) { 06630 06631 variable_size = TRUE; 06632 } 06633 06634 keep_orig_sh = save_keep_orig_sh; 06635 } 06636 06637 if ( /* April ATP_PROC(IR_IDX_L(ir_idx)) != Intrin_Proc && */ 06638 TYP_TYPE(type_idx) == Character && 06639 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char && 06640 ! ATD_IM_A_DOPE(attr_idx)) { 06641 06642 variable_size = TRUE; 06643 } 06644 06645 if (ATP_ELEMENTAL(spec_idx) && 06646 elemental_exp_desc.rank > 0) { 06647 /* create new bd entry */ 06648 elemental_exp_desc.type_idx = type_idx; 06649 variable_size |= ! gen_bd_entry(NULL, &elemental_exp_desc, &bd_idx, 06650 line, col); 06651 } 06652 06653 /* need to make it a subroutine */ 06654 06655 //# if 0 /*August */ 06656 06657 tmp_idx = get_stmt_tmp(type_idx, 06658 ATD_IM_A_DOPE(attr_idx), 06659 (bd_idx == NULL_IDX ? 0 : BD_RANK(bd_idx))); 06660 06661 if (tmp_idx == NULL_IDX) { 06662 06663 if (variable_size) { 06664 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 06665 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 06666 } 06667 else { 06668 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 06669 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 06670 } 06671 06672 ATD_TYPE_IDX(tmp_idx) = type_idx; 06673 ATD_ARRAY_IDX(tmp_idx) = bd_idx; 06674 ATD_IM_A_DOPE(tmp_idx) = ATD_IM_A_DOPE(attr_idx); 06675 06676 AT_ACTUAL_ARG(tmp_idx) = TRUE; 06677 ATD_POINTER(tmp_idx) = ATD_POINTER(attr_idx); 06678 ATD_POINTER(tmp_idx) = FALSE; 06679 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 06680 } 06681 06682 # if defined(GENERATE_WHIRL) 06683 ATD_NOT_PT_UNIQUE_MEM(tmp_idx) = TRUE; 06684 # endif 06685 06686 /* ATD_CHAR_LEN_IN_DV(tmp_idx) = ATD_CHAR_LEN_IN_DV(attr_idx); */ 06687 06688 if (variable_size && FALSE) { /* March */ 06689 06690 /* now for the alloc and dealloc stmts */ 06691 06692 ATD_AUTOMATIC(tmp_idx) = TRUE; 06693 06694 GEN_COMPILER_TMP_ASG(base_asg_idx, 06695 base_tmp_idx, 06696 TRUE, /* Semantics done */ 06697 line, 06698 col, 06699 SA_INTEGER_DEFAULT_TYPE, 06700 Priv); 06701 06702 ATD_AUTO_BASE_IDX(tmp_idx) = base_tmp_idx; 06703 # if defined(GENERATE_WHIRL) 06704 ATD_NOT_PT_UNIQUE_MEM(base_tmp_idx) = TRUE; 06705 # endif 06706 06707 if (bd_idx) { 06708 OPND_FLD(size_opnd) = BD_LEN_FLD(bd_idx); 06709 OPND_IDX(size_opnd) = BD_LEN_IDX(bd_idx); 06710 OPND_LINE_NUM(size_opnd) = line; 06711 OPND_COL_NUM(size_opnd) = col; 06712 } 06713 else { 06714 OPND_FLD(size_opnd) = CN_Tbl_Idx; 06715 OPND_IDX(size_opnd) = CN_INTEGER_ONE_IDX; 06716 OPND_LINE_NUM(size_opnd) = line; 06717 OPND_COL_NUM(size_opnd) = col; 06718 } 06719 06720 determine_tmp_size(&size_opnd, 06721 ATD_TYPE_IDX(tmp_idx)); 06722 06723 NTR_IR_TBL(alloc_idx); 06724 IR_OPR(alloc_idx) = Alloc_Opr; 06725 IR_TYPE_IDX(alloc_idx) = TYPELESS_DEFAULT_TYPE; 06726 IR_LINE_NUM(alloc_idx) = line; 06727 IR_COL_NUM(alloc_idx) = col; 06728 COPY_OPND(IR_OPND_L(alloc_idx), size_opnd); 06729 IR_FLD_R(base_asg_idx) = IR_Tbl_Idx; 06730 IR_IDX_R(base_asg_idx) = alloc_idx; 06731 06732 /* put this before new_stmt_idx (which should be curr_stmt_sh_idx) */ 06733 06734 gen_sh(Before, Assignment_Stmt, stmt_start_line, 06735 stmt_start_col, FALSE, FALSE, TRUE); 06736 06737 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = base_asg_idx; 06738 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 06739 06740 NTR_IR_TBL(dealloc_idx); 06741 IR_OPR(dealloc_idx) = Dealloc_Opr; 06742 IR_TYPE_IDX(dealloc_idx) = TYPELESS_DEFAULT_TYPE; 06743 IR_LINE_NUM(dealloc_idx) = line; 06744 IR_COL_NUM(dealloc_idx) = col; 06745 COPY_OPND(IR_OPND_L(dealloc_idx), IR_OPND_L(base_asg_idx)); 06746 06747 /* put this after orig_sh_idx */ 06748 06749 curr_stmt_sh_idx = orig_sh_idx; 06750 06751 gen_sh(After, Assignment_Stmt, stmt_start_line, 06752 stmt_start_col, FALSE, FALSE, TRUE); 06753 06754 SH_IR_IDX(curr_stmt_sh_idx) = dealloc_idx; 06755 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 06756 curr_stmt_sh_idx = new_stmt_idx; 06757 } 06758 else if (ATD_IM_A_DOPE(tmp_idx)) { 06759 06760 if (AT_IS_INTRIN(IR_IDX_L(ir_idx))) { 06761 06762 /* need to dealloc the dope vector pointee */ 06763 06764 if (glb_tbl_idx[Dealloc_Attr_Idx] == NULL_IDX) { 06765 glb_tbl_idx[Dealloc_Attr_Idx] = create_lib_entry_attr( 06766 DEALLOC_LIB_ENTRY, 06767 DEALLOC_NAME_LEN, 06768 line, 06769 col); 06770 } 06771 06772 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Dealloc_Attr_Idx]); 06773 06774 /* create array to send to DEALLOC */ 06775 06776 /* these go before "next" stmt which is orig_sh_idx */ 06777 06778 curr_stmt_sh_idx = SH_NEXT_IDX(orig_sh_idx); 06779 06780 # ifdef _ALLOCATE_IS_CALL 06781 tmp_array_idx = create_alloc_descriptor(1, line, col, FALSE); 06782 06783 /* put loc of dope vector, tmp_idx, into tmp_array_idx(2) */ 06784 06785 NTR_IR_TBL(sub_idx); 06786 IR_OPR(sub_idx) = Subscript_Opr; 06787 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(tmp_array_idx); 06788 IR_LINE_NUM(sub_idx) = line; 06789 IR_COL_NUM(sub_idx) = col; 06790 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 06791 IR_IDX_L(sub_idx) = tmp_array_idx; 06792 IR_LINE_NUM_L(sub_idx) = line; 06793 IR_COL_NUM_L(sub_idx) = col; 06794 06795 NTR_IR_LIST_TBL(list_idx); 06796 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 06797 IR_IDX_R(sub_idx) = list_idx; 06798 IR_LIST_CNT_R(sub_idx) = 1; 06799 06800 IL_FLD(list_idx) = CN_Tbl_Idx; 06801 the_constant = 2L; 06802 06803 # if defined(GENERATE_WHIRL) 06804 if (TYP_LINEAR(ATD_TYPE_IDX(tmp_array_idx)) == Integer_4) { 06805 the_constant++; 06806 } 06807 # endif 06808 06809 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 06810 the_constant); 06811 IL_LINE_NUM(list_idx) = line; 06812 IL_COL_NUM(list_idx) = col; 06813 06814 NTR_IR_TBL(asg_idx); 06815 IR_OPR(asg_idx) = Asg_Opr; 06816 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 06817 06818 IR_LINE_NUM(asg_idx) = line; 06819 IR_COL_NUM(asg_idx) = col; 06820 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 06821 IR_IDX_L(asg_idx) = sub_idx; 06822 NTR_IR_TBL(loc_idx); 06823 IR_OPR(loc_idx) = Loc_Opr; 06824 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 06825 IR_LINE_NUM(loc_idx) = line; 06826 IR_COL_NUM(loc_idx) = col; 06827 06828 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 06829 IR_IDX_R(asg_idx) = loc_idx; 06830 06831 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 06832 IR_IDX_L(loc_idx) = tmp_idx; 06833 IR_LINE_NUM_L(loc_idx) = line; 06834 IR_COL_NUM_L(loc_idx) = col; 06835 06836 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 06837 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 06838 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 06839 06840 /* now set up call to DEALLOC */ 06841 06842 NTR_IR_TBL(call_idx); 06843 IR_OPR(call_idx) = Call_Opr; 06844 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE; 06845 IR_LINE_NUM(call_idx) = line; 06846 IR_COL_NUM(call_idx) = col; 06847 IR_FLD_L(call_idx) = AT_Tbl_Idx; 06848 IR_IDX_L(call_idx) = glb_tbl_idx[Dealloc_Attr_Idx]; 06849 IR_LINE_NUM_L(call_idx) = line; 06850 IR_COL_NUM_L(call_idx) = col; 06851 06852 NTR_IR_LIST_TBL(list_idx); 06853 IR_FLD_R(call_idx) = IL_Tbl_Idx; 06854 IR_IDX_R(call_idx) = list_idx; 06855 IR_LIST_CNT_R(call_idx) = 1; 06856 06857 NTR_IR_TBL(loc_idx); 06858 IR_OPR(loc_idx) = Aloc_Opr; 06859 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 06860 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 06861 IR_IDX_L(loc_idx) = tmp_array_idx; 06862 IR_LINE_NUM(loc_idx) = line; 06863 IR_COL_NUM(loc_idx) = col; 06864 IR_LINE_NUM_L(loc_idx) = line; 06865 IR_COL_NUM_L(loc_idx) = col; 06866 IL_FLD(list_idx) = IR_Tbl_Idx; 06867 IL_IDX(list_idx) = loc_idx; 06868 06869 gen_sh(Before, Call_Stmt, line, col, FALSE, FALSE, TRUE); 06870 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = call_idx; 06871 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 06872 # else 06873 06874 NTR_IR_TBL(asg_idx); 06875 IR_OPR(asg_idx) = Deallocate_Opr; 06876 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 06877 IR_LINE_NUM(asg_idx) = line; 06878 IR_COL_NUM(asg_idx) = col; 06879 06880 NTR_IR_LIST_TBL(list_idx); 06881 IR_FLD_L(asg_idx) = IL_Tbl_Idx; 06882 IR_IDX_L(asg_idx) = list_idx; 06883 IR_LIST_CNT_L(asg_idx) = 1; 06884 06885 NTR_IR_TBL(loc_idx); 06886 IR_OPR(loc_idx) = Aloc_Opr; 06887 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 06888 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 06889 IR_IDX_L(loc_idx) = tmp_idx; 06890 IR_LINE_NUM(loc_idx) = line; 06891 IR_COL_NUM(loc_idx) = col; 06892 IR_LINE_NUM_L(loc_idx) = line; 06893 IR_COL_NUM_L(loc_idx) = col; 06894 IL_FLD(list_idx) = IR_Tbl_Idx; 06895 IL_IDX(list_idx) = loc_idx; 06896 06897 NTR_IR_LIST_TBL(list_idx); 06898 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 06899 IR_IDX_R(asg_idx) = list_idx; 06900 IR_LIST_CNT_R(asg_idx) = 3; 06901 IL_FLD(list_idx) = AT_Tbl_Idx; 06902 IL_IDX(list_idx) = glb_tbl_idx[Dealloc_Attr_Idx]; 06903 IL_LINE_NUM(list_idx) = line; 06904 IL_COL_NUM(list_idx) = col; 06905 06906 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06907 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06908 list_idx = IL_NEXT_LIST_IDX(list_idx); 06909 06910 IL_FLD(list_idx) = CN_Tbl_Idx; 06911 IL_IDX(list_idx) = gen_alloc_header_const(Integer_8, 06912 1, 06913 FALSE, 06914 &cn_idx); 06915 IL_LINE_NUM(list_idx) = line; 06916 IL_COL_NUM(list_idx) = col; 06917 06918 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06919 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06920 list_idx = IL_NEXT_LIST_IDX(list_idx); 06921 06922 IL_FLD(list_idx) = CN_Tbl_Idx; 06923 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 06924 IL_LINE_NUM(list_idx) = line; 06925 IL_COL_NUM(list_idx) = col; 06926 06927 gen_sh(Before, Call_Stmt, line, col, FALSE, FALSE, TRUE); 06928 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 06929 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 06930 # endif 06931 06932 curr_stmt_sh_idx = new_stmt_idx; 06933 } 06934 } 06935 06936 if (ATD_IM_A_DOPE(tmp_idx)) { 06937 /* fill in constant fields in temp dope vector */ 06938 06939 OPND_FLD(opnd) = AT_Tbl_Idx; 06940 OPND_IDX(opnd) = tmp_idx; 06941 OPND_LINE_NUM(opnd) = line; 06942 OPND_COL_NUM(opnd) = col; 06943 06944 gen_dv_whole_def_init(&opnd, tmp_idx, Before); 06945 } 06946 else if (TYP_TYPE(type_idx) == Structure && 06947 (ATT_POINTER_CPNT(TYP_IDX(type_idx)) || 06948 ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx)))) { 06949 06950 OPND_FLD(opnd) = AT_Tbl_Idx; 06951 OPND_IDX(opnd) = tmp_idx; 06952 OPND_LINE_NUM(opnd) = line; 06953 OPND_COL_NUM(opnd) = col; 06954 06955 if (ATD_ARRAY_IDX(tmp_idx) != NULL_IDX) { 06956 ok = gen_whole_subscript(&opnd, &exp_desc); 06957 } 06958 06959 process_cpnt_inits(&opnd, 06960 TYP_IDX(type_idx), 06961 gen_dv_whole_def_init, 06962 Asg_Opr, 06963 Before); 06964 } 06965 06966 if ( FALSE && FUNCTION_MUST_BE_SUBROUTINE(attr_idx) ) { /* March */ 06967 /* insert tmp as first argument to call */ 06968 06969 OPND_FLD(opnd) = AT_Tbl_Idx; 06970 OPND_IDX(opnd) = tmp_idx; 06971 OPND_LINE_NUM(opnd) = line; 06972 OPND_COL_NUM(opnd) = col; 06973 06974 NTR_IR_TBL(loc_idx); 06975 06976 IR_OPR(loc_idx) = Aloc_Opr; 06977 06978 /* JBL - this is for array element change */ 06979 06980 if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character && 06981 ! ATD_IM_A_DOPE(tmp_idx)) { 06982 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 06983 } 06984 else { 06985 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 06986 } 06987 06988 if (ATD_ARRAY_IDX(tmp_idx) != NULL_IDX && 06989 ! ATD_IM_A_DOPE(tmp_idx)) { 06990 06991 ok &= gen_whole_subscript(&opnd, &exp_desc); 06992 06993 # ifndef _FRONTEND_INLINER 06994 if (OPND_FLD(opnd) == IR_Tbl_Idx && 06995 ! ATP_ELEMENTAL(spec_idx)) { 06996 06997 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) { 06998 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 06999 } 07000 } 07001 07002 # endif 07003 if (! ATP_ELEMENTAL(spec_idx)) { 07004 unused1 = NULL_IDX; 07005 unused2 = NULL_IDX; 07006 make_base_subtree(&opnd, &base_opnd, &unused1, &unused2); 07007 COPY_OPND(opnd, base_opnd); 07008 } 07009 } 07010 else if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character && 07011 ! ATD_IM_A_DOPE(tmp_idx)) { 07012 ok = gen_whole_substring(&opnd, 07013 (ATD_ARRAY_IDX(tmp_idx) ? 07014 BD_RANK(ATD_ARRAY_IDX(tmp_idx)) : 0)); 07015 } 07016 07017 IR_LINE_NUM(loc_idx) = line; 07018 IR_COL_NUM(loc_idx) = col; 07019 07020 COPY_OPND(IR_OPND_L(loc_idx), opnd); 07021 07022 # ifdef _TRANSFORM_CHAR_SEQUENCE 07023 if (! ATD_IM_A_DOPE(tmp_idx) && 07024 TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Structure && 07025 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(tmp_idx)))) { 07026 07027 transform_char_sequence_ref(&opnd, 07028 ATD_TYPE_IDX(tmp_idx)); 07029 COPY_OPND(IR_OPND_L(loc_idx), opnd); 07030 07031 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 07032 } 07033 # endif 07034 07035 07036 IL_FLD(res_list_idx) = IR_Tbl_Idx; 07037 IL_IDX(res_list_idx) = loc_idx; 07038 07039 IR_RANK(ir_idx) = 0; 07040 07041 SH_IR_IDX(new_stmt_idx) = ir_idx; 07042 SH_P2_SKIP_ME(new_stmt_idx) = TRUE; 07043 07044 OPND_FLD((*result)) = AT_Tbl_Idx; 07045 OPND_IDX((*result)) = tmp_idx; 07046 OPND_LINE_NUM((*result)) = line; 07047 OPND_COL_NUM((*result)) = col; 07048 07049 if (ATD_IM_A_DOPE(tmp_idx)) { 07050 NTR_IR_TBL(dv_idx); 07051 IR_OPR(dv_idx) = Dv_Deref_Opr; 07052 IR_TYPE_IDX(dv_idx) = ATD_TYPE_IDX(tmp_idx); 07053 IR_LINE_NUM(dv_idx) = line; 07054 IR_COL_NUM(dv_idx) = col; 07055 07056 COPY_OPND(IR_OPND_L(dv_idx), (*result)); 07057 OPND_FLD((*result)) = IR_Tbl_Idx; 07058 OPND_IDX((*result)) = dv_idx; 07059 } 07060 07061 if (ATD_ARRAY_IDX(tmp_idx)) { 07062 ok = gen_whole_subscript(result, &exp_desc); 07063 } 07064 else if (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) == Character) { 07065 ok = gen_whole_substring(result, 0); 07066 } 07067 07068 if (ATD_IM_A_DOPE(tmp_idx) && 07069 ATD_ARRAY_IDX(tmp_idx) && 07070 AT_IS_INTRIN(IR_IDX_L(ir_idx)) && 07071 ATP_INTRIN_ENUM(IR_IDX_L(ir_idx)) != Spread_Intrinsic && 07072 TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) != Character && 07073 (TYP_TYPE(ATD_TYPE_IDX(tmp_idx)) != Structure || 07074 ! ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(tmp_idx))))) { 07075 07076 /* find Whole_Subscript_Opr and mark it for use */ 07077 /* as a fei_as_ref (contiguous array ref) */ 07078 07079 if (OPND_FLD((*result)) == IR_Tbl_Idx && 07080 IR_OPR(OPND_IDX((*result))) == Whole_Subscript_Opr) { 07081 07082 IR_CONTIG_ARRAY(OPND_IDX((*result))) = TRUE; 07083 } 07084 } 07085 } 07086 else { 07087 07088 /* this is for ELEMENTAL calls only */ 07089 /* leave as temp = call */ 07090 07091 ATD_ELEMENTAL_CALL_TMP(tmp_idx) = TRUE; 07092 07093 NTR_IR_TBL(asg_idx); 07094 IR_OPR(asg_idx) = Asg_Opr; 07095 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(attr_idx); 07096 IR_LINE_NUM(asg_idx) = IR_LINE_NUM(ir_idx); 07097 IR_COL_NUM(asg_idx) = IR_COL_NUM(ir_idx); 07098 ATD_TMP_IDX(tmp_idx) = asg_idx; 07099 ATD_FLD(tmp_idx) = IR_Tbl_Idx; 07100 AT_DEFINED(tmp_idx) = TRUE; 07101 07102 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 07103 IR_IDX_R(asg_idx) = ir_idx; 07104 07105 OPND_FLD(opnd) = AT_Tbl_Idx; 07106 OPND_IDX(opnd) = tmp_idx; 07107 OPND_LINE_NUM(opnd) = IR_LINE_NUM(ir_idx); 07108 OPND_COL_NUM(opnd) = IR_COL_NUM(ir_idx); 07109 07110 if (ATD_ARRAY_IDX(tmp_idx)) { 07111 ok = gen_whole_subscript(&opnd, &exp_desc); 07112 } 07113 07114 COPY_OPND(IR_OPND_L(asg_idx), opnd); 07115 07116 SH_IR_IDX(new_stmt_idx) = asg_idx; 07117 SH_P2_SKIP_ME(new_stmt_idx) = TRUE; 07118 07119 if (where_ir_idx) { 07120 change_asg_to_where(asg_idx); 07121 } 07122 07123 COPY_OPND((*result), opnd); 07124 07125 } 07126 /* } */ 07127 else { 07128 tmp_idx = get_stmt_tmp(ATD_TYPE_IDX(attr_idx), 07129 FALSE, 07130 0); 07131 07132 if (tmp_idx) { 07133 NTR_IR_TBL(asg_idx); 07134 IR_OPR(asg_idx) = Asg_Opr; 07135 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(attr_idx); 07136 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 07137 IR_IDX_L(asg_idx) = tmp_idx; 07138 IR_LINE_NUM_L(asg_idx) = IR_LINE_NUM(ir_idx); 07139 IR_LINE_NUM(asg_idx) = IR_LINE_NUM(ir_idx); 07140 IR_COL_NUM_L(asg_idx) = IR_COL_NUM(ir_idx); 07141 IR_COL_NUM(asg_idx) = IR_COL_NUM(ir_idx); 07142 ATD_TMP_IDX(tmp_idx) = asg_idx; 07143 ATD_FLD(tmp_idx) = IR_Tbl_Idx; 07144 AT_DEFINED(tmp_idx) = TRUE; 07145 } 07146 else { 07147 GEN_COMPILER_TMP_ASG(asg_idx, 07148 tmp_idx, 07149 TRUE, /* Semantics done */ 07150 IR_LINE_NUM(ir_idx), 07151 IR_COL_NUM(ir_idx), 07152 ATD_TYPE_IDX(attr_idx), 07153 Priv); 07154 } 07155 07156 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 07157 IR_IDX_R(asg_idx) = ir_idx; 07158 07159 SH_IR_IDX(new_stmt_idx) = asg_idx; 07160 SH_P2_SKIP_ME(new_stmt_idx) = TRUE; 07161 07162 if (where_ir_idx) { 07163 change_asg_to_where(asg_idx); 07164 } 07165 07166 OPND_FLD((*result)) = AT_Tbl_Idx; 07167 OPND_IDX((*result)) = tmp_idx; 07168 OPND_LINE_NUM((*result)) = line; 07169 OPND_COL_NUM((*result)) = col; 07170 07171 /* tmp_idx is not character, array or dope vector, so .. */ 07172 /* no extra ir generation is needed. */ 07173 } 07174 07175 # endif /*August*/ 07176 07177 orig_sh_idx = save_orig_sh_idx; 07178 07179 defer_stmt_expansion = save_defer_stmt_expansion; 07180 stmt_expansion_control_end(result); 07181 07182 EXIT: 07183 07184 TRACE (Func_Exit, "flatten_function_call", NULL); 07185 07186 return; 07187 07188 } /* flatten_function_call */ 07189 07190 /******************************************************************************\ 07191 |* *| 07192 |* Description: *| 07193 |* Evaluate a bounds stmt function and assign it to a tmp. *| 07194 |* *| 07195 |* Input parameters: *| 07196 |* sf_idx - stmt function attr idx. *| 07197 |* list_idx - start list node for actual args. *| 07198 |* *| 07199 |* Output parameters: *| 07200 |* NONE *| 07201 |* *| 07202 |* Returns: *| 07203 |* tmp attr idx. *| 07204 |* *| 07205 \******************************************************************************/ 07206 static int create_tmp_from_stmt_func(int sf_idx) 07207 07208 { 07209 int asg_idx; 07210 expr_arg_type exp_desc; 07211 opnd_type opnd; 07212 cif_usage_code_type save_xref_state; 07213 int tmp_idx; 07214 07215 07216 TRACE (Func_Entry, "create_tmp_from_stmt_func", NULL); 07217 07218 gen_opnd(&opnd, ATS_SF_IDX(sf_idx), (fld_type) ATS_SF_FLD(sf_idx), 07219 stmt_start_line, stmt_start_col); 07220 copy_subtree(&opnd, &opnd); 07221 07222 /* Look for struct_opr to see if any components will */ 07223 /* need updating to the correct component attr. */ 07224 07225 exp_desc.rank = 0; 07226 save_xref_state = xref_state; 07227 xref_state = CIF_No_Usage_Rec; 07228 expr_semantics(&opnd, &exp_desc); 07229 xref_state = save_xref_state; 07230 07231 GEN_COMPILER_TMP_ASG(asg_idx, 07232 tmp_idx, 07233 TRUE, /* Semantics done */ 07234 stmt_start_line, 07235 stmt_start_col, 07236 exp_desc.type_idx, 07237 Priv); 07238 07239 /* Look for struct_opr to see if any components will */ 07240 /* need updating to the correct component attr. */ 07241 07242 update_components(&opnd); 07243 07244 COPY_OPND(IR_OPND_R(asg_idx), opnd); 07245 07246 gen_sh(Before, Assignment_Stmt, stmt_start_line, 07247 stmt_start_col, FALSE, FALSE, TRUE); 07248 07249 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 07250 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07251 07252 TRACE (Func_Exit, "create_tmp_from_stmt_func", NULL); 07253 07254 return(tmp_idx); 07255 07256 } /* create_tmp_from_stmt_func */ 07257 07258 /******************************************************************************\ 07259 |* *| 07260 |* Description: *| 07261 |* Take a rslt_idx describing a character function result and create the *| 07262 |* tmp needed to find the character length. *| 07263 |* *| 07264 |* Input parameters: *| 07265 |* rslt_idx - character function result attr idx. *| 07266 |* *| 07267 |* Output parameters: *| 07268 |* new_type_idx - return type idx. *| 07269 |* new_bd_idx - new bounds table idx. *| 07270 |* *| 07271 |* Returns: *| 07272 |* NOTHING *| 07273 |* *| 07274 \******************************************************************************/ 07275 static void make_new_bd_entries(int rslt_idx, 07276 int *new_type_idx, 07277 int *new_bd_idx) 07278 07279 { 07280 long attr_link_list[38]; /* (Max dimensions * 5) + 3 */ 07281 int attr_link_idx = NULL_IDX; 07282 int bd_idx; 07283 boolean constant_size_array; 07284 int dim; 07285 boolean had_variable_len_char = FALSE; 07286 int i; 07287 int ir_idx; 07288 int new_tmp_idx; 07289 boolean symbolic_constant_size_array; /* BRIANJ KAYKAY - not used */ 07290 int tmp_idx; 07291 int type_idx; 07292 int ub_idx; 07293 07294 07295 TRACE (Func_Entry, "make_new_bd_entries", NULL); 07296 07297 type_idx = ATD_TYPE_IDX(rslt_idx); 07298 bd_idx = ATD_ARRAY_IDX(rslt_idx); 07299 07300 if (TYP_TYPE(type_idx) == Character && 07301 (TYP_CHAR_CLASS(type_idx) == Var_Len_Char || 07302 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char)) { 07303 07304 /* TYP_ORIG_LEN_IDX is the bounds tmp used to create the character */ 07305 /* length. TYP_IDX is the character length, which is MAX(length,0). */ 07306 07307 if (TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) { 07308 /* TYP_ORIG_LEN_IDX not set for Assumed_Size_Char */ 07309 tmp_idx = TYP_IDX(type_idx); 07310 } 07311 else { 07312 tmp_idx = TYP_ORIG_LEN_IDX(type_idx); 07313 } 07314 07315 had_variable_len_char = TRUE; 07316 07317 new_tmp_idx = expand_user_bound(tmp_idx); 07318 attr_link_list[attr_link_idx++] = tmp_idx; 07319 tmp_idx = TYP_IDX(type_idx); 07320 new_tmp_idx = copy_and_replace_tmps(tmp_idx); 07321 attr_link_list[attr_link_idx++] = tmp_idx; 07322 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 07323 07324 if (ATD_CLASS(new_tmp_idx) == Constant) { 07325 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 07326 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 07327 TYP_IDX(TYP_WORK_IDX) = ATD_CONST_IDX(new_tmp_idx); 07328 } 07329 else { 07330 TYP_CHAR_CLASS(TYP_WORK_IDX) = Var_Len_Char; 07331 TYP_FLD(TYP_WORK_IDX) = AT_Tbl_Idx; 07332 TYP_IDX(TYP_WORK_IDX) = new_tmp_idx; 07333 TYP_ORIG_LEN_IDX(TYP_WORK_IDX) = new_tmp_idx; 07334 } 07335 07336 TYP_TYPE(TYP_WORK_IDX) = Character; 07337 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 07338 *new_type_idx = ntr_type_tbl(); 07339 } 07340 07341 if (bd_idx != NULL_IDX && 07342 ! ATD_IM_A_DOPE(rslt_idx) && 07343 (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array || 07344 had_variable_len_char)) { 07345 07346 *new_bd_idx = reserve_array_ntry(BD_RANK(bd_idx)); 07347 07348 COPY_BD_NTRY(*new_bd_idx, bd_idx); 07349 07350 BD_LINE_NUM(*new_bd_idx) = stmt_start_line; 07351 BD_COLUMN_NUM(*new_bd_idx) = stmt_start_col; 07352 BD_RESOLVED(*new_bd_idx) = TRUE; 07353 constant_size_array = TRUE; 07354 symbolic_constant_size_array = FALSE; 07355 07356 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 07357 07358 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx && 07359 !ATD_SYMBOLIC_CONSTANT(BD_LB_IDX(bd_idx,dim))) { 07360 07361 tmp_idx = BD_LB_IDX(bd_idx, dim); 07362 new_tmp_idx = expand_user_bound(tmp_idx); 07363 attr_link_list[attr_link_idx++] = tmp_idx; 07364 07365 if (ATD_CLASS(new_tmp_idx) == Constant) { 07366 BD_LB_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx); 07367 BD_LB_FLD(*new_bd_idx, dim) = CN_Tbl_Idx; 07368 } 07369 else { 07370 07371 # if defined(_TARGET_OS_MAX) 07372 07373 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) { 07374 symbolic_constant_size_array = TRUE; 07375 } 07376 else { 07377 constant_size_array = FALSE; 07378 } 07379 # else 07380 constant_size_array = FALSE; 07381 # endif 07382 gen_copyin_bounds_stmt(new_tmp_idx); 07383 07384 BD_LB_IDX(*new_bd_idx, dim) = new_tmp_idx; 07385 BD_LB_FLD(*new_bd_idx, dim) = AT_Tbl_Idx; 07386 } 07387 } 07388 07389 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx && 07390 !ATD_SYMBOLIC_CONSTANT(BD_UB_IDX(bd_idx,dim))) { 07391 tmp_idx = BD_UB_IDX(bd_idx, dim); 07392 ub_idx = tmp_idx; 07393 new_tmp_idx = expand_user_bound(tmp_idx); 07394 07395 attr_link_list[attr_link_idx++] = tmp_idx; 07396 07397 if (ATD_CLASS(new_tmp_idx) == Constant) { 07398 BD_UB_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx); 07399 BD_UB_FLD(*new_bd_idx, dim) = CN_Tbl_Idx; 07400 } 07401 else { 07402 07403 # if defined(_TARGET_OS_MAX) 07404 07405 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) { 07406 symbolic_constant_size_array = TRUE; 07407 } 07408 else { 07409 constant_size_array = FALSE; 07410 } 07411 # else 07412 constant_size_array = FALSE; 07413 # endif 07414 gen_copyin_bounds_stmt(new_tmp_idx); 07415 07416 BD_UB_IDX(*new_bd_idx, dim) = new_tmp_idx; 07417 BD_UB_FLD(*new_bd_idx, dim) = AT_Tbl_Idx; 07418 } 07419 } 07420 else { 07421 ub_idx = NULL_IDX; 07422 } 07423 07424 if (BD_XT_FLD(bd_idx, dim) == AT_Tbl_Idx && 07425 !ATD_SYMBOLIC_CONSTANT(BD_XT_IDX(bd_idx,dim))) { 07426 07427 /* If the lower bound is a constant one, we take a shortcut */ 07428 /* in array_dcl_semantics that makes the upper bound and the */ 07429 /* extent be the same tmp. We have to check to see if the */ 07430 /* upper bound and the extent are the same tmp here. If */ 07431 /* they are not the same temp, we need to copy and replace */ 07432 /* the tmp hidden in the max(tmp,0) stuff. */ 07433 /* The extent should always look like t1 = max(t2,0). */ 07434 /* To check whether we need to handle the second tmp or not */ 07435 /* compare t2 to the upper bound tmp. If it is the same, we */ 07436 07437 /* t$1 = i (lb); t$2 = j (ub); */ 07438 /* t$3 = t$2 - t$1 + 1 Extra tmp */ 07439 /* t$4 = max(t$3,0) extent tmp */ 07440 07441 tmp_idx = BD_XT_IDX(bd_idx, dim); 07442 07443 if (ATD_FLD(tmp_idx) == IR_Tbl_Idx) { 07444 ir_idx = IR_IDX_R(ATD_TMP_IDX(tmp_idx)); 07445 07446 # ifdef _DEBUG 07447 if (IR_OPR(ir_idx) != Max_Opr || 07448 IL_FLD(IR_IDX_L(ir_idx)) != AT_Tbl_Idx) { 07449 PRINTMSG(BD_LINE_NUM(bd_idx), 775, Internal, 07450 BD_COLUMN_NUM(bd_idx), 07451 AT_OBJ_NAME_PTR(tmp_idx), 07452 tmp_idx); 07453 } 07454 # endif 07455 07456 tmp_idx = IL_IDX(IR_IDX_L(ir_idx)); 07457 07458 if (tmp_idx != ub_idx) { 07459 new_tmp_idx = copy_and_replace_tmps(tmp_idx); 07460 attr_link_list[attr_link_idx++] = tmp_idx; 07461 } 07462 } 07463 07464 tmp_idx = BD_XT_IDX(bd_idx, dim); 07465 new_tmp_idx = copy_and_replace_tmps(tmp_idx); 07466 attr_link_list[attr_link_idx++] = tmp_idx; 07467 07468 if (ATD_CLASS(new_tmp_idx) == Constant) { 07469 BD_XT_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx); 07470 BD_XT_FLD(*new_bd_idx, dim) = CN_Tbl_Idx; 07471 } 07472 else { 07473 07474 # if defined(_TARGET_OS_MAX) 07475 07476 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) { 07477 symbolic_constant_size_array = TRUE; 07478 } 07479 else { 07480 constant_size_array = FALSE; 07481 } 07482 # else 07483 constant_size_array = FALSE; 07484 # endif 07485 gen_copyin_bounds_stmt(new_tmp_idx); 07486 07487 BD_XT_IDX(*new_bd_idx, dim) = new_tmp_idx; 07488 BD_XT_FLD(*new_bd_idx, dim) = AT_Tbl_Idx; 07489 } 07490 } 07491 07492 if (BD_SM_FLD(bd_idx, dim) == AT_Tbl_Idx && 07493 !ATD_SYMBOLIC_CONSTANT(BD_SM_IDX(bd_idx, dim))) { 07494 tmp_idx = BD_SM_IDX(bd_idx, dim); 07495 new_tmp_idx = copy_and_replace_tmps(tmp_idx); 07496 attr_link_list[attr_link_idx++] = tmp_idx; 07497 07498 if (ATD_CLASS(new_tmp_idx) == Constant) { 07499 BD_SM_IDX(*new_bd_idx, dim) = ATD_CONST_IDX(new_tmp_idx); 07500 BD_SM_FLD(*new_bd_idx, dim) = CN_Tbl_Idx; 07501 } 07502 else { 07503 07504 # if defined(_TARGET_OS_MAX) 07505 07506 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) { 07507 symbolic_constant_size_array = TRUE; 07508 } 07509 else { 07510 constant_size_array = FALSE; 07511 } 07512 # else 07513 constant_size_array = FALSE; 07514 # endif 07515 BD_SM_IDX(*new_bd_idx, dim) = new_tmp_idx; 07516 BD_SM_FLD(*new_bd_idx, dim) = AT_Tbl_Idx; 07517 } 07518 } 07519 } 07520 07521 if (BD_LEN_FLD(bd_idx) == AT_Tbl_Idx && 07522 !ATD_SYMBOLIC_CONSTANT(BD_LEN_IDX(bd_idx))) { 07523 tmp_idx = BD_LEN_IDX(bd_idx); 07524 new_tmp_idx = copy_and_replace_tmps(tmp_idx); 07525 attr_link_list[attr_link_idx++]= tmp_idx; 07526 07527 if (ATD_CLASS(new_tmp_idx) == Constant) { 07528 BD_LEN_IDX(*new_bd_idx) = ATD_CONST_IDX(new_tmp_idx); 07529 BD_LEN_FLD(*new_bd_idx) = CN_Tbl_Idx; 07530 } 07531 else { 07532 07533 # if defined(_TARGET_OS_MAX) 07534 07535 if (ATD_SYMBOLIC_CONSTANT(new_tmp_idx)) { 07536 symbolic_constant_size_array = TRUE; 07537 } 07538 else { 07539 constant_size_array = FALSE; 07540 } 07541 # else 07542 constant_size_array = FALSE; 07543 # endif 07544 BD_LEN_IDX(*new_bd_idx) = new_tmp_idx; 07545 BD_LEN_FLD(*new_bd_idx) = AT_Tbl_Idx; 07546 } 07547 } 07548 07549 if (constant_size_array) { 07550 BD_ARRAY_SIZE(*new_bd_idx) = Constant_Size; 07551 } 07552 07553 BD_FLOW_DEPENDENT(*new_bd_idx) = TRUE; 07554 *new_bd_idx = ntr_array_in_bd_tbl(*new_bd_idx); 07555 } 07556 07557 for (i = 0; i < attr_link_idx; i++) { 07558 AT_ATTR_LINK(attr_link_list[i]) = NULL_IDX; 07559 } 07560 07561 TRACE (Func_Exit, "make_new_bd_entries", NULL); 07562 07563 return; 07564 07565 } /* make_new_bd_entries */ 07566 07567 /******************************************************************************\ 07568 |* *| 07569 |* Description: *| 07570 |* This routine copies the IR for the bound tmp being passed in. It *| 07571 |* then calls expr_semantics to try to fold the bounds IR. expr_semantic*| 07572 |* will replace the original (placeholder tmps) in the IR with the new *| 07573 |* tmps created by this routines callee. (When bounds are generated for *| 07574 |* functions, they are just placeholder tmps. Each place that a call is *| 07575 |* made, the placeholder tmps need to be replaced by tmps generated for *| 07576 |* the current scope. The tmps get replaced via the attr_link mechanism.*| 07577 |* New tmps are generated and the old tmps are attr linked to the new *| 07578 |* ones, then expr_semantics replaces the old tmps with the new ones in *| 07579 |* the IR stream. After expr_semantics is called, the old attr_link is *| 07580 |* broken.) If the IR folds, a new constant attr is created and *| 07581 |* returned, otherwise a tmp is generated to hold the IR and the IR is *| 07582 |* put into the current IR stream. The tmp is returned. *| 07583 |* *| 07584 |* Input parameters: *| 07585 |* NONE *| 07586 |* *| 07587 |* Output parameters: *| 07588 |* NONE *| 07589 |* *| 07590 |* Returns: *| 07591 |* NOTHING *| 07592 |* *| 07593 \******************************************************************************/ 07594 static int copy_and_replace_tmps(int attr_idx) 07595 07596 { 07597 expr_arg_type exp_desc; 07598 int ir_idx; 07599 opnd_type opnd; 07600 cif_usage_code_type save_xref_state; 07601 int tmp_attr_idx; 07602 07603 07604 TRACE (Func_Entry, "copy_and_replace_tmps", NULL); 07605 07606 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx))); 07607 copy_subtree(&opnd, &opnd); 07608 07609 exp_desc.rank = 0; 07610 save_xref_state = xref_state; 07611 xref_state = CIF_No_Usage_Rec; 07612 07613 expr_semantics(&opnd, &exp_desc); 07614 07615 xref_state = save_xref_state; 07616 07617 if (OPND_FLD(opnd) == CN_Tbl_Idx) { /* Folded to a constant */ 07618 tmp_attr_idx = gen_compiler_tmp(stmt_start_line, 07619 stmt_start_col, 07620 Priv, TRUE); 07621 ATD_CLASS(tmp_attr_idx) = Constant; 07622 AT_TYPED(tmp_attr_idx) = TRUE; 07623 ATD_TYPE_IDX(tmp_attr_idx) = exp_desc.type_idx; 07624 AT_DEFINED(tmp_attr_idx) = FALSE; 07625 AT_REFERENCED(tmp_attr_idx) = Not_Referenced; 07626 AT_SEMANTICS_DONE(tmp_attr_idx) = TRUE; 07627 ATD_CONST_IDX(tmp_attr_idx) = OPND_IDX(opnd); 07628 ATD_FLD(tmp_attr_idx) = CN_Tbl_Idx; 07629 } 07630 else { 07631 GEN_COMPILER_TMP_ASG(ir_idx, 07632 tmp_attr_idx, 07633 TRUE, /* Semantics done */ 07634 stmt_start_line, 07635 stmt_start_col, 07636 exp_desc.type_idx, 07637 Priv); 07638 07639 COPY_OPND(IR_OPND_R(ATD_TMP_IDX(tmp_attr_idx)), opnd); 07640 07641 gen_sh(Before, Assignment_Stmt, stmt_start_line, 07642 stmt_start_col, FALSE, FALSE, TRUE); 07643 07644 AT_DEFINED(tmp_attr_idx) = TRUE; 07645 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 07646 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07647 } 07648 07649 AT_ATTR_LINK(attr_idx) = tmp_attr_idx; 07650 07651 TRACE (Func_Exit, "copy_and_replace_tmps", NULL); 07652 07653 return(tmp_attr_idx); 07654 07655 } /* copy_and_replace_tmps */ 07656 07657 /******************************************************************************\ 07658 |* *| 07659 |* Description: *| 07660 |* Takes as input, a tmp for a user specified bound. (Char length, *| 07661 |* lower bound or upper bound). It expands the dummy args with the *| 07662 |* actual args specified in list_idx. If it folds to a constant, it *| 07663 |* changes the tmp into a constant tmp. *| 07664 |* *| 07665 |* Input parameters: *| 07666 |* tmp_idx - A tmp for the user specified bound. *| 07667 |* list_idx - A list of actual args to replace the dummy args. *| 07668 |* *| 07669 |* Output parameters: *| 07670 |* NONE *| 07671 |* *| 07672 |* Returns: *| 07673 |* The newly expanded tmp. It may be a compiler tmp or a compiler *| 07674 |* constant. *| 07675 |* *| 07676 \******************************************************************************/ 07677 static int expand_user_bound(int tmp_idx) 07678 07679 { 07680 int const_idx; 07681 int ir_idx; 07682 int new_tmp_idx; 07683 opnd_type opnd; 07684 int sf_attr_idx; 07685 int sh_idx; 07686 07687 07688 TRACE (Func_Exit, "expand_user_bound", NULL); 07689 07690 /* Create a stmt function for the length tmp, so it */ 07691 /* can be expanded with the actual arguments. */ 07692 07693 NTR_ATTR_TBL(sf_attr_idx); 07694 AT_OBJ_CLASS(sf_attr_idx) = Stmt_Func; 07695 AT_COMPILER_GEND(sf_attr_idx)= TRUE; 07696 ATD_TYPE_IDX(sf_attr_idx) = CG_INTEGER_DEFAULT_TYPE; 07697 ATS_SF_FLD(sf_attr_idx) = IR_FLD_R(ATD_TMP_IDX(tmp_idx)); 07698 ATS_SF_IDX(sf_attr_idx) = IR_IDX_R(ATD_TMP_IDX(tmp_idx)); 07699 07700 new_tmp_idx = create_tmp_from_stmt_func(sf_attr_idx); 07701 AT_ATTR_LINK(tmp_idx) = new_tmp_idx; 07702 OPND_FLD(opnd) = IR_FLD_R(ATD_TMP_IDX(new_tmp_idx)); 07703 OPND_IDX(opnd) = IR_IDX_R(ATD_TMP_IDX(new_tmp_idx)); 07704 07705 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 07706 const_idx = OPND_IDX(opnd); 07707 CLEAR_VARIANT_ATTR_INFO(new_tmp_idx, Data_Obj); 07708 ATD_CLASS(new_tmp_idx) = Constant; 07709 AT_TYPED(new_tmp_idx) = TRUE; 07710 ATD_TYPE_IDX(new_tmp_idx) = CN_TYPE_IDX(const_idx); 07711 AT_DEFINED(new_tmp_idx) = FALSE; 07712 AT_REFERENCED(new_tmp_idx) = Not_Referenced; 07713 ATD_CONST_IDX(new_tmp_idx) = const_idx; 07714 ATD_FLD(new_tmp_idx) = CN_Tbl_Idx; 07715 07716 /* Free the SH created for this IR. */ 07717 07718 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07719 remove_sh(sh_idx); 07720 FREE_IR_NODE(SH_IR_IDX(sh_idx)); 07721 FREE_SH_NODE(sh_idx); 07722 } 07723 07724 # if defined(_TARGET_OS_MAX) 07725 07726 else if (expr_is_symbolic_constant(&opnd)) { 07727 ATD_SYMBOLIC_CONSTANT(new_tmp_idx) = TRUE; 07728 AT_DEFINED(new_tmp_idx) = FALSE; 07729 AT_REFERENCED(new_tmp_idx) = Not_Referenced; 07730 ATD_FLD(new_tmp_idx) = OPND_FLD(opnd); 07731 ATD_TMP_IDX(new_tmp_idx) = OPND_IDX(opnd); 07732 07733 /* Free the SH created for this IR. */ 07734 07735 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07736 remove_sh(sh_idx); 07737 FREE_IR_NODE(SH_IR_IDX(sh_idx)); 07738 FREE_SH_NODE(sh_idx); 07739 } 07740 07741 # endif 07742 07743 else { 07744 AT_DEFINED(new_tmp_idx) = TRUE; 07745 AT_REFERENCED(new_tmp_idx) = Referenced; 07746 07747 if (ATD_FLD(new_tmp_idx) == AT_Tbl_Idx) { 07748 find_attrs_used_in_bound(ATD_TMP_IDX(new_tmp_idx)); 07749 } 07750 else if (ATD_FLD(new_tmp_idx) == IR_Tbl_Idx) { 07751 ir_idx = ATD_TMP_IDX(new_tmp_idx); 07752 07753 switch (IR_FLD_R(ir_idx)) { 07754 case AT_Tbl_Idx: 07755 find_attrs_used_in_bound(IR_IDX_R(ir_idx)); 07756 break; 07757 07758 case IR_Tbl_Idx: 07759 find_attrs_in_ir(IR_IDX_R(ir_idx)); 07760 break; 07761 07762 case IL_Tbl_Idx: 07763 find_attrs_in_il(IR_IDX_R(ir_idx)); 07764 break; 07765 } 07766 } 07767 } 07768 07769 TRACE (Func_Exit, "expand_user_bound", NULL); 07770 07771 return(new_tmp_idx); 07772 07773 } /* expand_user_bound */ 07774 07775 /******************************************************************************\ 07776 |* *| 07777 |* Description: *| 07778 |* *| 07779 |* Input parameters: *| 07780 |* NONE *| 07781 |* *| 07782 |* Output parameters: *| 07783 |* NONE *| 07784 |* *| 07785 |* Returns: *| 07786 |* NONE *| 07787 |* *| 07788 \******************************************************************************/ 07789 static void find_attrs_used_in_bound(int attr_idx) 07790 07791 { 07792 int asg_idx; 07793 int ir_idx; 07794 int list_idx; 07795 int name_idx; 07796 int old_attr_idx; 07797 07798 07799 TRACE (Func_Entry, "find_attrs_used_in_bound", NULL); 07800 07801 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 07802 07803 if (ATD_CLASS(attr_idx) == Struct_Component) { 07804 return; 07805 } 07806 07807 if (ATD_CLASS(attr_idx) == Function_Result) { 07808 attr_idx = ATD_FUNC_IDX(attr_idx); 07809 } 07810 } 07811 07812 old_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(attr_idx), 07813 AT_NAME_LEN(attr_idx), 07814 &name_idx); 07815 07816 /* If the object is in this scope - just return */ 07817 07818 if (old_attr_idx == attr_idx) { 07819 return; 07820 } 07821 else if (old_attr_idx != NULL_IDX && 07822 AT_OBJ_CLASS(old_attr_idx) == Interface && 07823 ATI_PROC_IDX(old_attr_idx) != NULL_IDX && 07824 attr_idx == ATI_PROC_IDX(old_attr_idx)) { 07825 return; 07826 } 07827 07828 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 07829 ATD_CLASS(attr_idx) == Compiler_Tmp) { 07830 07831 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) { 07832 find_attrs_used_in_bound(ATD_TMP_IDX(attr_idx)); 07833 } 07834 else if (ATD_FLD(attr_idx) == IR_Tbl_Idx) { 07835 ir_idx = ATD_TMP_IDX(attr_idx); 07836 07837 switch (IR_FLD_R(ir_idx)) { 07838 case AT_Tbl_Idx: 07839 find_attrs_used_in_bound(IR_IDX_R(ir_idx)); 07840 break; 07841 07842 case IR_Tbl_Idx: 07843 find_attrs_in_ir(IR_IDX_R(ir_idx)); 07844 break; 07845 07846 case IL_Tbl_Idx: 07847 find_attrs_in_il(IR_IDX_R(ir_idx)); 07848 break; 07849 } 07850 } 07851 else if (ATD_FLD(attr_idx) == CN_Tbl_Idx) { 07852 07853 if (SB_ORIG_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 07854 07855 /* Tmp for an aggregate constant that is defined in an */ 07856 /* interface block. This tmp is in the static block of */ 07857 /* the interface which doesn't exist. It needs to be in */ 07858 /* a static block in the caller. It also needs to get its */ 07859 /* initialization data generated in the callers scope. */ 07860 /* The interface's static block is added to the caller and */ 07861 /* initialization code is generated. host_assocociated_ */ 07862 /* attr_semantics handles the generation of the storage */ 07863 /* block. Following is generation of the IR. */ 07864 07865 /* create data init stmt */ 07866 07867 NTR_IR_TBL(asg_idx); 07868 IR_OPR(asg_idx) = Init_Opr; 07869 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 07870 IR_LINE_NUM(asg_idx) = AT_DEF_LINE(attr_idx); 07871 IR_COL_NUM(asg_idx) = AT_DEF_COLUMN(attr_idx); 07872 IR_LINE_NUM_L(asg_idx) = AT_DEF_LINE(attr_idx); 07873 IR_COL_NUM_L(asg_idx) = AT_DEF_COLUMN(attr_idx); 07874 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 07875 IR_IDX_L(asg_idx) = attr_idx; 07876 AT_DEFINED(attr_idx) = TRUE; 07877 07878 NTR_IR_LIST_TBL(list_idx); 07879 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 07880 IR_IDX_R(asg_idx) = list_idx; 07881 IR_LIST_CNT_R(asg_idx) = 3; 07882 07883 IL_FLD(list_idx) = CN_Tbl_Idx; 07884 IL_IDX(list_idx) = ATD_TMP_IDX(attr_idx); 07885 IL_LINE_NUM(list_idx) = AT_DEF_LINE(attr_idx); 07886 IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx); 07887 07888 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07889 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07890 07891 list_idx = IL_NEXT_LIST_IDX(list_idx); 07892 IL_FLD(list_idx) = CN_Tbl_Idx; 07893 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 07894 IL_LINE_NUM(list_idx) = AT_DEF_LINE(attr_idx); 07895 IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx); 07896 07897 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07898 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07899 07900 list_idx = IL_NEXT_LIST_IDX(list_idx); 07901 IL_FLD(list_idx) = CN_Tbl_Idx; 07902 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 07903 IL_LINE_NUM(list_idx) = AT_DEF_LINE(attr_idx); 07904 IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx); 07905 07906 gen_sh(Before, 07907 Assignment_Stmt, 07908 AT_DEF_LINE(attr_idx), 07909 AT_DEF_COLUMN(attr_idx), 07910 FALSE, 07911 FALSE, 07912 TRUE); 07913 07914 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 07915 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07916 } 07917 } 07918 } 07919 07920 AT_REFERENCED(attr_idx) = Referenced; 07921 07922 host_associated_attr_semantics(attr_idx, TRUE); 07923 07924 TRACE (Func_Exit, "find_attrs_used_in_bound", NULL); 07925 07926 return; 07927 07928 } /* find_attrs_used_in_bound */ 07929 07930 /******************************************************************************\ 07931 |* *| 07932 |* Description: *| 07933 |* *| 07934 |* Input parameters: *| 07935 |* ir_idx => ir to check *| 07936 |* *| 07937 |* Output parameters: *| 07938 |* NONE *| 07939 |* *| 07940 |* Returns: *| 07941 |* NONE *| 07942 |* *| 07943 \******************************************************************************/ 07944 static void find_attrs_in_ir(int ir_idx) 07945 { 07946 07947 TRACE (Func_Entry, "find_attrs_in_ir", NULL); 07948 07949 switch (IR_FLD_L(ir_idx)) { 07950 case AT_Tbl_Idx: 07951 find_attrs_used_in_bound(IR_IDX_L(ir_idx)); 07952 break; 07953 07954 case IR_Tbl_Idx: 07955 find_attrs_in_ir(IR_IDX_L(ir_idx)); 07956 break; 07957 07958 case IL_Tbl_Idx: 07959 find_attrs_in_il(IR_IDX_L(ir_idx)); 07960 break; 07961 } 07962 07963 switch (IR_FLD_R(ir_idx)) { 07964 case AT_Tbl_Idx: 07965 find_attrs_used_in_bound(IR_IDX_R(ir_idx)); 07966 break; 07967 07968 case IR_Tbl_Idx: 07969 find_attrs_in_ir(IR_IDX_R(ir_idx)); 07970 break; 07971 07972 case IL_Tbl_Idx: 07973 find_attrs_in_il(IR_IDX_R(ir_idx)); 07974 break; 07975 } 07976 07977 TRACE (Func_Exit, "find_attrs_in_ir", NULL); 07978 07979 return; 07980 07981 } /* find_attrs_in_ir */ 07982 07983 /******************************************************************************\ 07984 |* *| 07985 |* Description: *| 07986 |* *| 07987 |* Input parameters: *| 07988 |* list_idx => il to check *| 07989 |* *| 07990 |* Output parameters: *| 07991 |* NONE *| 07992 |* *| 07993 |* Returns: *| 07994 |* NONE *| 07995 |* *| 07996 \******************************************************************************/ 07997 static void find_attrs_in_il(int list_idx) 07998 { 07999 08000 TRACE (Func_Entry, "find_attrs_in_il", NULL); 08001 08002 while (list_idx != NULL_IDX) { 08003 08004 switch (IL_FLD(list_idx)) { 08005 08006 case AT_Tbl_Idx: 08007 find_attrs_used_in_bound(IL_IDX(list_idx)); 08008 break; 08009 08010 case IR_Tbl_Idx: 08011 find_attrs_in_ir(IL_IDX(list_idx)); 08012 break; 08013 08014 case IL_Tbl_Idx: 08015 find_attrs_in_il(IL_IDX(list_idx)); 08016 break; 08017 08018 } 08019 list_idx = IL_NEXT_LIST_IDX(list_idx); 08020 } 08021 08022 TRACE (Func_Exit, "find_attrs_in_il", NULL); 08023 08024 return; 08025 08026 } /* find_attrs_in_il */ 08027 08028 /******************************************************************************\ 08029 |* *| 08030 |* Description: *| 08031 |* This routine will return a scalar or dope vector tmp that has only *| 08032 |* a statements duration. It will try to reuse tmps if possible by *| 08033 |* checking the stmt_tmp_tbl. If the global variables stmt_start_line *| 08034 |* and stmt_start_col are different from the line and col in the IL *| 08035 |* entry in the tmp list, then we can use that tmp. *| 08036 |* *| 08037 |* Input parameters: *| 08038 |* type_idx - type tbl idx needed. *| 08039 |* dope_vector - TRUE if this is a dope vector. *| 08040 |* rank - rank of tmp. *| 08041 |* *| 08042 |* Output parameters: *| 08043 |* NONE *| 08044 |* *| 08045 |* Returns: *| 08046 |* tmp attr idx. *| 08047 |* *| 08048 \******************************************************************************/ 08049 08050 int get_stmt_tmp(int type_idx, 08051 boolean dope_vector, 08052 int rank) 08053 08054 { 08055 08056 linear_type_type linear_type; 08057 int list_idx; 08058 int tmp_idx = NULL_IDX; 08059 08060 # if 0 08061 int save_curr_stmt_sh_idx; 08062 # endif 08063 08064 08065 TRACE (Func_Entry, "get_stmt_tmp", NULL); 08066 08067 if (comp_phase != Pass2_Semantics) { 08068 goto EXIT; 08069 } 08070 08071 # if defined(GENERATE_WHIRL) 08072 if (dump_flags.mp) { 08073 goto EXIT; 08074 } 08075 # endif 08076 08077 if (cdir_switches.parallel_region) { 08078 goto EXIT; 08079 } 08080 08081 linear_type = TYP_LINEAR(type_idx); 08082 08083 if (stmt_tmp_tbl[linear_type].scalar_tmps_head < 0) { 08084 goto EXIT; 08085 } 08086 08087 if (! dope_vector && rank != 0) { 08088 goto EXIT; 08089 } 08090 08091 if (dope_vector) { 08092 08093 if (stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] == NULL_IDX) { 08094 08095 goto EXIT; 08096 # if 0 08097 /* create new tmp, put it on list */ 08098 08099 tmp_idx = gen_compiler_tmp(stmt_start_line, 08100 stmt_start_col, 08101 Priv, TRUE); 08102 ATD_TYPE_IDX(tmp_idx) = type_idx; 08103 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08104 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 08105 08106 if (rank) { 08107 /* Positions 1-7 are deferred shape entries in the bd table. */ 08108 ATD_ARRAY_IDX(tmp_idx) = rank; 08109 } 08110 08111 /* March ATD_IM_A_DOPE(tmp_idx) = TRUE; */ 08112 08113 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 08114 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 08115 08116 gen_entry_dope_code(tmp_idx); 08117 08118 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 08119 08120 NTR_IR_LIST_TBL(list_idx); 08121 IL_LINE_NUM(list_idx) = stmt_start_line; 08122 IL_COL_NUM(list_idx) = stmt_start_col; 08123 IL_IDX(list_idx) = tmp_idx; 08124 IL_FLD(list_idx) = AT_Tbl_Idx; 08125 stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] = list_idx; 08126 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank] = list_idx; 08127 # endif 08128 } 08129 else { 08130 08131 list_idx = stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank]; 08132 08133 if (IL_LINE_NUM(list_idx) == stmt_start_line && 08134 IL_COL_NUM(list_idx) == stmt_start_col) { 08135 08136 /* this tmp in use, and all others in list */ 08137 /* create new tmp, put it on list */ 08138 08139 goto EXIT; 08140 # if 0 08141 tmp_idx = gen_compiler_tmp(stmt_start_line, 08142 stmt_start_col, 08143 Priv, TRUE); 08144 ATD_TYPE_IDX(tmp_idx) = type_idx; 08145 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08146 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 08147 08148 if (rank) { 08149 /* Positions 1-7 are deferred shape entries in the bd table. */ 08150 ATD_ARRAY_IDX(tmp_idx) = rank; 08151 } 08152 08153 /* March ATD_IM_A_DOPE(tmp_idx) = TRUE; */ 08154 08155 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 08156 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 08157 08158 gen_entry_dope_code(tmp_idx); 08159 08160 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 08161 08162 NTR_IR_LIST_TBL(list_idx); 08163 IL_LINE_NUM(list_idx) = stmt_start_line; 08164 IL_COL_NUM(list_idx) = stmt_start_col; 08165 IL_IDX(list_idx) = tmp_idx; 08166 IL_FLD(list_idx) = AT_Tbl_Idx; 08167 08168 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type]. 08169 dope_vector_tmps_tail[rank]) = list_idx; 08170 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank] = list_idx; 08171 # endif 08172 08173 } 08174 else { 08175 tmp_idx = IL_IDX(list_idx); 08176 IL_LINE_NUM(list_idx) = stmt_start_line; 08177 IL_COL_NUM(list_idx) = stmt_start_col; 08178 08179 /* move tmp to end of list */ 08180 08181 if (stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] == 08182 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank]) { 08183 /* just one tmp on list */ 08184 /* intentionally blank */ 08185 } 08186 else { 08187 stmt_tmp_tbl[linear_type].dope_vector_tmps_head[rank] = 08188 IL_NEXT_LIST_IDX(list_idx); 08189 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type]. 08190 dope_vector_tmps_tail[rank]) = list_idx; 08191 stmt_tmp_tbl[linear_type].dope_vector_tmps_tail[rank] = list_idx; 08192 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 08193 } 08194 } 08195 } 08196 } 08197 else { 08198 08199 if (stmt_tmp_tbl[linear_type].scalar_tmps_head == NULL_IDX) { 08200 08201 /* create new tmp, put it on list */ 08202 08203 tmp_idx = gen_compiler_tmp(stmt_start_line, 08204 stmt_start_col, 08205 Priv, TRUE); 08206 ATD_TYPE_IDX(tmp_idx) = type_idx; 08207 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08208 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 08209 08210 NTR_IR_LIST_TBL(list_idx); 08211 IL_LINE_NUM(list_idx) = stmt_start_line; 08212 IL_COL_NUM(list_idx) = stmt_start_col; 08213 IL_IDX(list_idx) = tmp_idx; 08214 IL_FLD(list_idx) = AT_Tbl_Idx; 08215 stmt_tmp_tbl[linear_type].scalar_tmps_head = list_idx; 08216 stmt_tmp_tbl[linear_type].scalar_tmps_tail = list_idx; 08217 } 08218 else { 08219 08220 list_idx = stmt_tmp_tbl[linear_type].scalar_tmps_head; 08221 08222 if (IL_LINE_NUM(list_idx) == stmt_start_line && 08223 IL_COL_NUM(list_idx) == stmt_start_col) { 08224 08225 /* this tmp in use, and all others in list */ 08226 /* create new tmp, put it on list */ 08227 08228 tmp_idx = gen_compiler_tmp(stmt_start_line, 08229 stmt_start_col, 08230 Priv, TRUE); 08231 ATD_TYPE_IDX(tmp_idx) = type_idx; 08232 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08233 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 08234 08235 NTR_IR_LIST_TBL(list_idx); 08236 IL_LINE_NUM(list_idx) = stmt_start_line; 08237 IL_COL_NUM(list_idx) = stmt_start_col; 08238 IL_IDX(list_idx) = tmp_idx; 08239 IL_FLD(list_idx) = AT_Tbl_Idx; 08240 08241 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type].scalar_tmps_tail) = 08242 list_idx; 08243 stmt_tmp_tbl[linear_type].scalar_tmps_tail = list_idx; 08244 08245 } 08246 else { 08247 tmp_idx = IL_IDX(list_idx); 08248 IL_LINE_NUM(list_idx) = stmt_start_line; 08249 IL_COL_NUM(list_idx) = stmt_start_col; 08250 08251 /* move tmp to end of list */ 08252 08253 if (stmt_tmp_tbl[linear_type].scalar_tmps_head == 08254 stmt_tmp_tbl[linear_type].scalar_tmps_tail) { 08255 /* just one tmp on list */ 08256 /* intentionally blank */ 08257 } 08258 else { 08259 stmt_tmp_tbl[linear_type].scalar_tmps_head = 08260 IL_NEXT_LIST_IDX(list_idx); 08261 IL_NEXT_LIST_IDX(stmt_tmp_tbl[linear_type].scalar_tmps_tail) = 08262 list_idx; 08263 stmt_tmp_tbl[linear_type].scalar_tmps_tail = list_idx; 08264 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 08265 } 08266 } 08267 } 08268 } 08269 08270 EXIT: 08271 08272 if (tmp_idx) { 08273 ATD_ASG_TMP(tmp_idx) = FALSE; 08274 ATD_ELEMENTAL_CALL_TMP(tmp_idx) = FALSE; 08275 } 08276 08277 TRACE (Func_Exit, "get_stmt_tmp", NULL); 08278 08279 return(tmp_idx); 08280 08281 } /* get_stmt_tmp */ 08282 08283 /******************************************************************************\ 08284 |* *| 08285 |* Description: *| 08286 |* <description> *| 08287 |* *| 08288 |* Input parameters: *| 08289 |* NONE *| 08290 |* *| 08291 |* Output parameters: *| 08292 |* NONE *| 08293 |* *| 08294 |* Returns: *| 08295 |* NOTHING *| 08296 |* *| 08297 \******************************************************************************/ 08298 08299 static void process_variable_size_func(int rslt_idx, 08300 int arg_list_idx, 08301 int sf_darg_idx, 08302 int sf_num_dargs, 08303 int *new_type_idx, 08304 int *new_bd_idx) 08305 08306 { 08307 int a_list_idx; 08308 int association; 08309 int bd_idx; 08310 int column; 08311 int dummy_idx; 08312 int d_bd_idx; 08313 int d_type_idx; 08314 expr_arg_type exp_desc; 08315 int i; 08316 int ir_idx; 08317 int k; 08318 int line; 08319 int list_idx; 08320 opnd_type list_opnd; 08321 opnd_type opnd; 08322 boolean save_variable_size_func_expr; 08323 int sn_idx; 08324 int tmp_dv_idx; 08325 int type_idx; 08326 08327 08328 TRACE (Func_Entry, "process_variable_size_func", NULL); 08329 08330 sn_idx = sf_darg_idx; 08331 08332 a_list_idx = arg_list_idx; 08333 08334 for (i = sf_num_dargs; i > 0; i--) { 08335 if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Data_Obj) { 08336 ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = TRUE; 08337 } 08338 else if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Pgm_Unit && 08339 ATP_PROC(SN_ATTR_IDX(sn_idx)) == Dummy_Proc) { 08340 08341 ATP_DUMMY_PROC_LINK(SN_ATTR_IDX(sn_idx)) = IL_IDX(a_list_idx); 08342 } 08343 08344 sn_idx++; 08345 a_list_idx = IL_NEXT_LIST_IDX(a_list_idx); 08346 } 08347 08348 type_idx = ATD_TYPE_IDX(rslt_idx); 08349 bd_idx = ATD_ARRAY_IDX(rslt_idx); 08350 08351 list_opnd = null_opnd; 08352 08353 check_bd_typ_for_dargs(bd_idx, 08354 type_idx, 08355 &list_opnd); 08356 08357 list_idx = OPND_IDX(list_opnd); 08358 08359 /* go through list of needed dummy args and hook up the actual args */ 08360 08361 for (i = 0; i < OPND_LIST_CNT(list_opnd); i++) { 08362 sn_idx = sf_darg_idx; 08363 a_list_idx = arg_list_idx; 08364 dummy_idx = IL_IDX(list_idx); 08365 08366 08367 /* find the position of the dummy/actual in question */ 08368 08369 for (k = 0; k < sf_num_dargs; k++) { 08370 if (SN_ATTR_IDX(sn_idx) == dummy_idx) { 08371 goto FOUND; 08372 } 08373 sn_idx++; 08374 a_list_idx = IL_NEXT_LIST_IDX(a_list_idx); 08375 } 08376 08377 # ifdef _DEBUG 08378 print_at(dummy_idx); 08379 # endif 08380 PRINTMSG(stmt_start_line, 1020, Internal, stmt_start_col); 08381 08382 FOUND: 08383 08384 if (AT_OBJ_CLASS(dummy_idx) == Data_Obj) { 08385 08386 ATD_SF_LINK(dummy_idx) = IL_ARG_DESC_IDX(a_list_idx); 08387 08388 association = arg_info_list[IL_ARG_DESC_IDX(a_list_idx)].association; 08389 08390 COPY_OPND(opnd, IL_OPND(a_list_idx)); 08391 08392 switch (association) { 08393 case PASS_ADDRESS: 08394 case PASS_SECTION_ADDRESS : 08395 case PASS_DV : 08396 case PASS_DV_COPY : 08397 case COPY_IN : 08398 case COPY_IN_COPY_OUT : 08399 case MAKE_DV : 08400 case COPY_IN_MAKE_DV : 08401 if (OPND_FLD(opnd) == IR_Tbl_Idx && 08402 (IR_OPR(OPND_IDX(opnd)) == Loc_Opr || 08403 IR_OPR(OPND_IDX(opnd)) == Aloc_Opr || 08404 IR_OPR(OPND_IDX(opnd)) == Const_Tmp_Loc_Opr)) { 08405 08406 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 08407 } 08408 break; 08409 08410 case CHECK_CONTIG_FLAG : 08411 /* intentionally blank */ 08412 break; 08413 08414 case PASS_ADDRESS_FROM_DV: 08415 if (arg_info_list[IL_ARG_DESC_IDX(a_list_idx)].ed.rank == 0) { 08416 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 08417 } 08418 break; 08419 } 08420 08421 if (ATD_ARRAY_IDX(dummy_idx) != NULL_IDX && 08422 ! ATD_IM_A_DOPE(dummy_idx)) { 08423 08424 /* Need to set the actual arg up as a dope vector with */ 08425 /* the base address of the actual arg and the dimension*/ 08426 /* information of the dummy arg. This is because of */ 08427 /* array reshaping of sequence association. */ 08428 08429 d_bd_idx = ATD_ARRAY_IDX(dummy_idx); 08430 d_type_idx = ATD_TYPE_IDX(dummy_idx); 08431 08432 if (TYP_TYPE(d_type_idx) == Character && 08433 TYP_CHAR_CLASS(d_type_idx) == Assumed_Size_Char) { 08434 08435 /* temporarily hook up the original actual arg */ 08436 08437 if (association == CHECK_CONTIG_FLAG) { 08438 ATD_FLD(dummy_idx) = ATD_FLD(OPND_IDX(opnd)); 08439 ATD_SF_ARG_IDX(dummy_idx) = ATD_TMP_IDX(OPND_IDX(opnd)); 08440 } 08441 else { 08442 ATD_FLD(dummy_idx) = OPND_FLD(opnd); 08443 ATD_SF_ARG_IDX(dummy_idx) = OPND_IDX(opnd); 08444 } 08445 } 08446 08447 if ((TYP_TYPE(d_type_idx) == Character && 08448 (TYP_CHAR_CLASS(d_type_idx) == Var_Len_Char || 08449 TYP_CHAR_CLASS(d_type_idx) == Assumed_Size_Char)) || 08450 BD_ARRAY_SIZE(d_bd_idx) == Var_Len_Array) { 08451 08452 make_new_bd_entries(dummy_idx, 08453 &d_type_idx, 08454 &d_bd_idx); 08455 } 08456 08457 /* put in the new rank and shape in the expression descriptor */ 08458 exp_desc = arg_info_list[IL_ARG_DESC_IDX(a_list_idx)].ed; 08459 08460 exp_desc.rank = BD_RANK(d_bd_idx); 08461 for (k = 0; k < BD_RANK(d_bd_idx); k++) { 08462 exp_desc.shape[k].fld = BD_XT_FLD(d_bd_idx, k + 1); 08463 exp_desc.shape[k].idx = BD_XT_IDX(d_bd_idx, k + 1); 08464 } 08465 exp_desc.dope_vector = TRUE; 08466 08467 arg_info_list_base = arg_info_list_top; 08468 arg_info_list_top = arg_info_list_base + 1; 08469 08470 if (arg_info_list_top >= arg_info_list_size) { 08471 enlarge_info_list_table(); 08472 } 08473 08474 ATD_SF_LINK(dummy_idx) = arg_info_list_top; 08475 arg_info_list[arg_info_list_top] = init_arg_info; 08476 arg_info_list[arg_info_list_top].ed = exp_desc; 08477 08478 tmp_dv_idx = gen_sf_dv_whole_def(&opnd, d_type_idx, d_bd_idx); 08479 08480 find_opnd_line_and_column(&opnd, &line, &column); 08481 08482 NTR_IR_TBL(ir_idx); 08483 IR_OPR(ir_idx) = Dv_Deref_Opr; 08484 IR_TYPE_IDX(ir_idx) = type_idx; 08485 IR_LINE_NUM(ir_idx) = line; 08486 IR_COL_NUM(ir_idx) = column; 08487 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 08488 IR_IDX_L(ir_idx) = tmp_dv_idx; 08489 IR_LINE_NUM_L(ir_idx) = line; 08490 IR_COL_NUM_L(ir_idx) = column; 08491 08492 OPND_FLD(opnd) = IR_Tbl_Idx; 08493 OPND_IDX(opnd) = ir_idx; 08494 } 08495 08496 ATD_FLD(dummy_idx) = OPND_FLD(opnd); 08497 ATD_SF_ARG_IDX(dummy_idx) = OPND_IDX(opnd); 08498 08499 if (ATD_ARRAY_IDX(dummy_idx) && 08500 BD_ARRAY_CLASS(ATD_ARRAY_IDX(dummy_idx)) == Assumed_Shape) { 08501 08502 # ifdef _DEBUG 08503 if (OPND_FLD(opnd) != AT_Tbl_Idx || 08504 AT_OBJ_CLASS(OPND_IDX(opnd)) != Data_Obj || 08505 ATD_CLASS(OPND_IDX(opnd)) != Compiler_Tmp) { 08506 PRINTMSG(stmt_start_line, 626, Internal, 08507 stmt_start_col, 08508 "Compiler_Tmp", "process_variable_size_func"); 08509 } 08510 # endif 08511 08512 ATD_RESHAPE_ARRAY_IDX(OPND_IDX(opnd)) = 08513 ATD_ARRAY_IDX(OPND_IDX(opnd)); 08514 ATD_ARRAY_IDX(OPND_IDX(opnd)) = ATD_ARRAY_IDX(dummy_idx); 08515 } 08516 } 08517 08518 08519 list_idx = IL_NEXT_LIST_IDX(list_idx); 08520 } 08521 08522 08523 save_variable_size_func_expr = variable_size_func_expr; 08524 variable_size_func_expr = TRUE; 08525 08526 /* now call make_new_bd_entries for the function result */ 08527 08528 make_new_bd_entries(rslt_idx, 08529 new_type_idx, 08530 new_bd_idx); 08531 08532 variable_size_func_expr = save_variable_size_func_expr; 08533 08534 sn_idx = sf_darg_idx; 08535 08536 for (i = sf_num_dargs; i > 0; i--) { 08537 if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Data_Obj) { 08538 ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = FALSE; 08539 08540 if (ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx)) && 08541 BD_ARRAY_CLASS(ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx))) == 08542 Assumed_Shape && 08543 ATD_FLD(SN_ATTR_IDX(sn_idx)) == AT_Tbl_Idx && 08544 ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx)) != NULL_IDX) { 08545 08546 ATD_ARRAY_IDX(ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx))) = 08547 ATD_RESHAPE_ARRAY_IDX(ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx))); 08548 ATD_RESHAPE_ARRAY_IDX(ATD_SF_ARG_IDX(SN_ATTR_IDX(sn_idx))) = 08549 NULL_IDX; 08550 } 08551 } 08552 else if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Pgm_Unit && 08553 ATP_PROC(SN_ATTR_IDX(sn_idx)) == Dummy_Proc) { 08554 ATP_DUMMY_PROC_LINK(SN_ATTR_IDX(sn_idx)) = NULL_IDX; 08555 } 08556 08557 sn_idx++; 08558 } 08559 08560 TRACE (Func_Exit, "process_variable_size_func", NULL); 08561 08562 return; 08563 08564 } /* process_variable_size_func */ 08565 08566 /******************************************************************************\ 08567 |* *| 08568 |* Description: *| 08569 |* <description> *| 08570 |* *| 08571 |* Input parameters: *| 08572 |* NONE *| 08573 |* *| 08574 |* Output parameters: *| 08575 |* NONE *| 08576 |* *| 08577 |* Returns: *| 08578 |* NOTHING *| 08579 |* *| 08580 \******************************************************************************/ 08581 08582 static void check_bd_typ_for_dargs(int bd_idx, 08583 int type_idx, 08584 opnd_type *list_opnd) 08585 08586 { 08587 int dim; 08588 opnd_type opnd; 08589 08590 TRACE (Func_Entry, "check_bd_typ_for_dargs", NULL); 08591 08592 if (TYP_TYPE(type_idx) == Character && 08593 TYP_CHAR_CLASS(type_idx) == Var_Len_Char) { 08594 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_ORIG_LEN_IDX(type_idx)))); 08595 search_expr_for_dargs(&opnd, list_opnd); 08596 } 08597 08598 if (bd_idx != NULL_IDX) { 08599 if (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) { 08600 08601 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 08602 08603 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 08604 08605 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(BD_LB_IDX(bd_idx, dim)))); 08606 search_expr_for_dargs(&opnd, list_opnd); 08607 } 08608 08609 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 08610 08611 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(BD_UB_IDX(bd_idx, dim)))); 08612 search_expr_for_dargs(&opnd, list_opnd); 08613 } 08614 } 08615 } 08616 else if (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) { 08617 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 08618 08619 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 08620 08621 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(BD_LB_IDX(bd_idx, dim)))); 08622 search_expr_for_dargs(&opnd, list_opnd); 08623 } 08624 } 08625 } 08626 } 08627 08628 TRACE (Func_Exit, "check_bd_typ_for_dargs", NULL); 08629 08630 return; 08631 08632 } /* check_bd_typ_for_dargs */ 08633 08634 /******************************************************************************\ 08635 |* *| 08636 |* Description: *| 08637 |* <description> *| 08638 |* *| 08639 |* Input parameters: *| 08640 |* NONE *| 08641 |* *| 08642 |* Output parameters: *| 08643 |* NONE *| 08644 |* *| 08645 |* Returns: *| 08646 |* NOTHING *| 08647 |* *| 08648 \******************************************************************************/ 08649 08650 static void search_expr_for_dargs(opnd_type *opnd, 08651 opnd_type *list_opnd) 08652 08653 { 08654 int list_idx; 08655 opnd_type loc_opnd; 08656 08657 TRACE (Func_Entry, "search_expr_for_dargs", NULL); 08658 08659 switch(OPND_FLD((*opnd))) { 08660 case AT_Tbl_Idx: 08661 if (AT_OBJ_CLASS(OPND_IDX((*opnd))) == Data_Obj && 08662 ATD_CLASS(OPND_IDX((*opnd))) == Dummy_Argument && 08663 ATD_SF_DARG(OPND_IDX((*opnd)))) { 08664 08665 if (OPND_FLD((*list_opnd)) != NO_Tbl_Idx) { 08666 list_idx = OPND_IDX((*list_opnd)); 08667 08668 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 08669 if (IL_IDX(list_idx) == OPND_IDX((*opnd))) { 08670 /* already on list */ 08671 /* this could be a flag on the dummy attr */ 08672 goto OUT; 08673 } 08674 list_idx = IL_NEXT_LIST_IDX(list_idx); 08675 } 08676 } 08677 08678 if (ATD_ARRAY_IDX(OPND_IDX((*opnd))) != NULL_IDX || 08679 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*opnd)))) == Character) { 08680 08681 check_bd_typ_for_dargs(ATD_ARRAY_IDX(OPND_IDX((*opnd))), 08682 ATD_TYPE_IDX(OPND_IDX((*opnd))), 08683 list_opnd); 08684 } 08685 08686 if (OPND_FLD((*list_opnd)) == NO_Tbl_Idx) { 08687 NTR_IR_LIST_TBL(list_idx); 08688 OPND_FLD((*list_opnd)) = IL_Tbl_Idx; 08689 OPND_IDX((*list_opnd)) = list_idx; 08690 OPND_LIST_CNT((*list_opnd)) = 1; 08691 } 08692 else { 08693 08694 list_idx = OPND_IDX((*list_opnd)); 08695 08696 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 08697 list_idx = IL_NEXT_LIST_IDX(list_idx); 08698 } 08699 08700 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 08701 OPND_LIST_CNT((*list_opnd)) += 1; 08702 list_idx = IL_NEXT_LIST_IDX(list_idx); 08703 } 08704 08705 IL_FLD(list_idx) = AT_Tbl_Idx; 08706 IL_IDX(list_idx) = OPND_IDX((*opnd)); 08707 IL_LINE_NUM(list_idx) = stmt_start_line; 08708 IL_COL_NUM(list_idx) = stmt_start_col; 08709 } 08710 break; 08711 08712 case IR_Tbl_Idx: 08713 COPY_OPND(loc_opnd, IR_OPND_L(OPND_IDX((*opnd)))); 08714 search_expr_for_dargs(&loc_opnd, list_opnd); 08715 08716 COPY_OPND(loc_opnd, IR_OPND_R(OPND_IDX((*opnd)))); 08717 search_expr_for_dargs(&loc_opnd, list_opnd); 08718 08719 break; 08720 08721 case IL_Tbl_Idx: 08722 08723 list_idx = OPND_IDX((*opnd)); 08724 08725 while (list_idx) { 08726 COPY_OPND(loc_opnd, IL_OPND(list_idx)); 08727 search_expr_for_dargs(&loc_opnd, list_opnd); 08728 list_idx = IL_NEXT_LIST_IDX(list_idx); 08729 } 08730 08731 break; 08732 08733 default : 08734 break; 08735 08736 } 08737 08738 OUT: 08739 08740 TRACE (Func_Exit, "search_expr_for_dargs", NULL); 08741 08742 return; 08743 08744 } /* search_expr_for_dargs */ 08745 08746 /******************************************************************************\ 08747 |* *| 08748 |* Description: *| 08749 |* Create the descriptor tables used in runtime argument checking. *| 08750 |* *| 08751 |* Input parameters: *| 08752 |* NONE *| 08753 |* *| 08754 |* Output parameters: *| 08755 |* NONE *| 08756 |* *| 08757 |* Returns: *| 08758 |* NOTHING *| 08759 |* *| 08760 \******************************************************************************/ 08761 08762 int create_argchck_descriptor(opnd_type *call_opnd) 08763 08764 { 08765 int arg_idx; 08766 int asg_idx; 08767 boolean this_is_call; 08768 int col; 08769 int count; 08770 int desc_idx; 08771 int entry_attr_idx; 08772 expr_arg_type exp_desc; 08773 int i; 08774 int ir_idx; 08775 int line; 08776 int list_idx; 08777 int loc_idx; 08778 boolean ok; 08779 opnd_type opnd; 08780 int rslt_idx; 08781 int shift_idx; 08782 int sub_idx; 08783 long_type the_constant; 08784 long_type the_constant2; 08785 int static_tmp_idx; 08786 int stack_tmp_idx; 08787 08788 08789 TRACE (Func_Entry, "create_argchck_descriptor", NULL); 08790 08791 if (OPND_FLD((*call_opnd)) == IR_Tbl_Idx) { 08792 /* this is a call descriptor */ 08793 this_is_call = TRUE; 08794 count = IR_LIST_CNT_R(OPND_IDX((*call_opnd))); 08795 entry_attr_idx = IR_IDX_L(OPND_IDX((*call_opnd))); 08796 line = IR_LINE_NUM(OPND_IDX((*call_opnd))); 08797 col = IR_COL_NUM(OPND_IDX((*call_opnd))); 08798 arg_idx = IR_IDX_R(OPND_IDX((*call_opnd))); 08799 08800 if (ATP_EXTRA_DARG(entry_attr_idx)) { 08801 count--; 08802 arg_idx = IL_NEXT_LIST_IDX(arg_idx); 08803 } 08804 } 08805 else { 08806 /* this is an entry descriptor */ 08807 this_is_call = FALSE; 08808 entry_attr_idx = OPND_IDX((*call_opnd)); 08809 count = ATP_NUM_DARGS(entry_attr_idx); 08810 line = AT_DEF_LINE(entry_attr_idx); 08811 col = AT_DEF_COLUMN(entry_attr_idx); 08812 arg_idx = ATP_FIRST_IDX(entry_attr_idx); 08813 08814 if (ATP_EXTRA_DARG(entry_attr_idx)) { 08815 count--; 08816 arg_idx++; 08817 } 08818 } 08819 08820 /***************************\ 08821 |* create the header table *| 08822 \***************************/ 08823 08824 if (num_argchck_suppress_msg > 0) { 08825 static_tmp_idx = 08826 gen_static_integer_array_tmp(3 + count + num_argchck_suppress_msg, 08827 line, 08828 col); 08829 } 08830 else { 08831 static_tmp_idx = gen_static_integer_array_tmp(2 + count, line, col); 08832 } 08833 08834 stack_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 08835 08836 ATD_TYPE_IDX(stack_tmp_idx) = ATD_TYPE_IDX(static_tmp_idx); 08837 ATD_STOR_BLK_IDX(stack_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08838 08839 /* This new tmp is fully created, so does not need decl_semantics */ 08840 08841 AT_SEMANTICS_DONE(stack_tmp_idx) = TRUE; 08842 08843 ATD_ARRAY_IDX(stack_tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx); 08844 08845 08846 /***********************************\ 08847 |* copy static attr to stack attr. *| 08848 \***********************************/ 08849 08850 OPND_FLD(opnd) = AT_Tbl_Idx; 08851 OPND_IDX(opnd) = stack_tmp_idx; 08852 OPND_LINE_NUM(opnd) = line; 08853 OPND_COL_NUM(opnd) = col; 08854 08855 ok = gen_whole_subscript(&opnd, &exp_desc); 08856 08857 NTR_IR_TBL(asg_idx); 08858 IR_OPR(asg_idx) = Asg_Opr; 08859 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 08860 IR_LINE_NUM(asg_idx) = line; 08861 IR_COL_NUM(asg_idx) = col; 08862 08863 COPY_OPND(IR_OPND_L(asg_idx), opnd); 08864 08865 OPND_FLD(opnd) = AT_Tbl_Idx; 08866 OPND_IDX(opnd) = static_tmp_idx; 08867 OPND_LINE_NUM(opnd) = line; 08868 OPND_COL_NUM(opnd) = col; 08869 08870 ok = gen_whole_subscript(&opnd, &exp_desc); 08871 08872 COPY_OPND(IR_OPND_R(asg_idx), opnd); 08873 08874 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 08875 08876 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 08877 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08878 08879 if (this_is_call) { 08880 /**********************************************\ 08881 |* set the seen_this flag on the static table *| 08882 \**********************************************/ 08883 08884 NTR_IR_TBL(asg_idx); 08885 IR_OPR(asg_idx) = Asg_Opr; 08886 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 08887 IR_LINE_NUM(asg_idx) = line; 08888 IR_COL_NUM(asg_idx) = col; 08889 08890 NTR_IR_TBL(sub_idx); 08891 IR_OPR(sub_idx) = Subscript_Opr; 08892 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 08893 IR_LINE_NUM(sub_idx) = line; 08894 IR_COL_NUM(sub_idx) = col; 08895 08896 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 08897 IR_IDX_L(sub_idx) = static_tmp_idx; 08898 IR_LINE_NUM_L(sub_idx) = line; 08899 IR_COL_NUM_L(sub_idx) = col; 08900 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 08901 IR_IDX_L(asg_idx) = sub_idx; 08902 08903 NTR_IR_LIST_TBL(list_idx); 08904 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 08905 IR_IDX_R(sub_idx) = list_idx; 08906 IR_LIST_CNT_R(sub_idx) = 1; 08907 08908 IL_FLD(list_idx) = CN_Tbl_Idx; 08909 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 08910 IL_LINE_NUM(list_idx) = line; 08911 IL_COL_NUM(list_idx) = col; 08912 08913 NTR_IR_TBL(shift_idx); 08914 IR_OPR(shift_idx) = Shiftl_Opr; 08915 IR_TYPE_IDX(shift_idx) = CG_INTEGER_DEFAULT_TYPE; 08916 IR_LINE_NUM(shift_idx) = line; 08917 IR_COL_NUM(shift_idx) = col; 08918 08919 NTR_IR_LIST_TBL(list_idx); 08920 IR_FLD_L(shift_idx) = IL_Tbl_Idx; 08921 IR_IDX_L(shift_idx) = list_idx; 08922 IR_LIST_CNT_L(shift_idx) = 2; 08923 08924 IL_FLD(list_idx) = CN_Tbl_Idx; 08925 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 08926 IL_LINE_NUM(list_idx) = line; 08927 IL_COL_NUM(list_idx) = col; 08928 08929 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 08930 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 08931 list_idx = IL_NEXT_LIST_IDX(list_idx); 08932 08933 the_constant = TARGET_BITS_PER_WORD - 1; 08934 08935 IL_FLD(list_idx) = CN_Tbl_Idx; 08936 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08937 the_constant); 08938 IL_LINE_NUM(list_idx) = line; 08939 IL_COL_NUM(list_idx) = col; 08940 08941 NTR_IR_TBL(ir_idx); 08942 IR_OPR(ir_idx) = Bor_Opr; 08943 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 08944 IR_LINE_NUM(ir_idx) = line; 08945 IR_COL_NUM(ir_idx) = col; 08946 08947 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 08948 IR_IDX_R(ir_idx) = shift_idx; 08949 08950 NTR_IR_TBL(sub_idx); 08951 IR_OPR(sub_idx) = Subscript_Opr; 08952 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 08953 IR_LINE_NUM(sub_idx) = line; 08954 IR_COL_NUM(sub_idx) = col; 08955 08956 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 08957 IR_IDX_L(sub_idx) = static_tmp_idx; 08958 IR_LINE_NUM_L(sub_idx) = line; 08959 IR_COL_NUM_L(sub_idx) = col; 08960 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 08961 IR_IDX_L(ir_idx) = sub_idx; 08962 08963 NTR_IR_LIST_TBL(list_idx); 08964 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 08965 IR_IDX_R(sub_idx) = list_idx; 08966 IR_LIST_CNT_R(sub_idx) = 1; 08967 08968 IL_FLD(list_idx) = CN_Tbl_Idx; 08969 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 08970 IL_LINE_NUM(list_idx) = line; 08971 IL_COL_NUM(list_idx) = col; 08972 08973 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 08974 IR_IDX_R(asg_idx) = ir_idx; 08975 08976 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 08977 08978 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 08979 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08980 } 08981 08982 /*****************************************\ 08983 |* initialize the first word with header *| 08984 \*****************************************/ 08985 08986 NTR_IR_TBL(asg_idx); 08987 IR_OPR(asg_idx) = Init_Opr; 08988 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 08989 IR_LINE_NUM(asg_idx) = line; 08990 IR_COL_NUM(asg_idx) = col; 08991 08992 NTR_IR_TBL(sub_idx); 08993 IR_OPR(sub_idx) = Subscript_Opr; 08994 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 08995 IR_LINE_NUM(sub_idx) = line; 08996 IR_COL_NUM(sub_idx) = col; 08997 08998 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 08999 IR_IDX_L(sub_idx) = static_tmp_idx; 09000 IR_LINE_NUM_L(sub_idx) = line; 09001 IR_COL_NUM_L(sub_idx) = col; 09002 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09003 IR_IDX_L(asg_idx) = sub_idx; 09004 09005 NTR_IR_LIST_TBL(list_idx); 09006 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09007 IR_IDX_R(sub_idx) = list_idx; 09008 IR_LIST_CNT_R(sub_idx) = 1; 09009 09010 IL_FLD(list_idx) = CN_Tbl_Idx; 09011 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 09012 IL_LINE_NUM(list_idx) = line; 09013 IL_COL_NUM(list_idx) = col; 09014 09015 NTR_IR_LIST_TBL(list_idx); 09016 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09017 IR_IDX_R(asg_idx) = list_idx; 09018 IR_LIST_CNT_R(asg_idx) = 3; 09019 09020 the_constant = 0; 09021 09022 ((arg_desc_header_type *)&the_constant)->seen_this = 0; 09023 ((arg_desc_header_type *)&the_constant)->f90_flag = 1; 09024 ((arg_desc_header_type *)&the_constant)->num_ck_only = 09025 cmd_line_flags.runtime_arg_count_only; 09026 ((arg_desc_header_type *)&the_constant)->arg_count = count; 09027 09028 if (num_argchck_suppress_msg > 0) { 09029 ((arg_desc_header_type *)&the_constant)->suppress_msg = 1; 09030 } 09031 09032 IL_FLD(list_idx) = CN_Tbl_Idx; 09033 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 09034 the_constant); 09035 IL_LINE_NUM(list_idx) = line; 09036 IL_COL_NUM(list_idx) = col; 09037 09038 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09039 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09040 list_idx = IL_NEXT_LIST_IDX(list_idx); 09041 09042 IL_FLD(list_idx) = CN_Tbl_Idx; 09043 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 09044 IL_LINE_NUM(list_idx) = line; 09045 IL_COL_NUM(list_idx) = col; 09046 09047 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09048 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09049 list_idx = IL_NEXT_LIST_IDX(list_idx); 09050 09051 IL_FLD(list_idx) = CN_Tbl_Idx; 09052 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09053 IL_LINE_NUM(list_idx) = line; 09054 IL_COL_NUM(list_idx) = col; 09055 09056 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09057 09058 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09059 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09060 09061 09062 # if defined(_INIT_RELOC_BASE_OFFSET) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 09063 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 09064 /* Create a temp as an overlay for the first object if */ 09065 /* there is no FIRST attr. */ 09066 09067 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(static_tmp_idx)) == NULL_IDX) { 09068 set_sb_first_attr_idx(static_tmp_idx); 09069 } 09070 # endif 09071 09072 /*******************************\ 09073 |* create call type descriptor *| 09074 \*******************************/ 09075 09076 if (ATP_PGM_UNIT(entry_attr_idx) == Function) { 09077 if (this_is_call && 09078 ATP_EXTRA_DARG(entry_attr_idx)) { 09079 09080 COPY_OPND(opnd, IL_OPND(IR_IDX_R(OPND_IDX((*call_opnd))))); 09081 rslt_idx = find_left_attr(&opnd); 09082 } 09083 else { 09084 rslt_idx = ATP_RSLT_IDX(entry_attr_idx); 09085 } 09086 } 09087 else { 09088 rslt_idx = NULL_IDX; 09089 } 09090 09091 the_constant = 2; 09092 09093 desc_idx = gen_call_type_descriptor(entry_attr_idx, 09094 rslt_idx, 09095 this_is_call, 09096 line, 09097 col); 09098 09099 if (ATD_STOR_BLK_IDX(desc_idx) == SCP_SB_STACK_IDX(curr_scp_idx)) { 09100 NTR_IR_TBL(sub_idx); 09101 IR_OPR(sub_idx) = Subscript_Opr; 09102 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09103 IR_LINE_NUM(sub_idx) = line; 09104 IR_COL_NUM(sub_idx) = col; 09105 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09106 IR_IDX_L(sub_idx) = stack_tmp_idx; 09107 IR_LINE_NUM_L(sub_idx) = line; 09108 IR_COL_NUM_L(sub_idx) = col; 09109 09110 NTR_IR_LIST_TBL(list_idx); 09111 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09112 IR_IDX_R(sub_idx) = list_idx; 09113 IR_LIST_CNT_R(sub_idx) = 1; 09114 IL_FLD(list_idx) = CN_Tbl_Idx; 09115 IL_IDX(list_idx) = CN_INTEGER_TWO_IDX; 09116 IL_LINE_NUM(list_idx) = line; 09117 IL_COL_NUM(list_idx) = col; 09118 09119 NTR_IR_TBL(asg_idx); 09120 IR_OPR(asg_idx) = Asg_Opr; 09121 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 09122 IR_LINE_NUM(asg_idx) = line; 09123 IR_COL_NUM(asg_idx) = col; 09124 09125 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09126 IR_IDX_L(asg_idx) = sub_idx; 09127 09128 NTR_IR_TBL(loc_idx); 09129 IR_OPR(loc_idx) = Loc_Opr; 09130 IR_LINE_NUM(loc_idx) = line; 09131 IR_COL_NUM(loc_idx) = col; 09132 09133 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 09134 09135 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 09136 IR_IDX_L(loc_idx) = desc_idx; 09137 IR_LINE_NUM_L(loc_idx) = line; 09138 IR_COL_NUM_L(loc_idx) = col; 09139 09140 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 09141 IR_IDX_R(asg_idx) = loc_idx; 09142 } 09143 else { 09144 NTR_IR_TBL(sub_idx); 09145 IR_OPR(sub_idx) = Subscript_Opr; 09146 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09147 IR_LINE_NUM(sub_idx) = line; 09148 IR_COL_NUM(sub_idx) = col; 09149 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09150 IR_IDX_L(sub_idx) = static_tmp_idx; 09151 IR_LINE_NUM_L(sub_idx) = line; 09152 IR_COL_NUM_L(sub_idx) = col; 09153 09154 NTR_IR_LIST_TBL(list_idx); 09155 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09156 IR_IDX_R(sub_idx) = list_idx; 09157 IR_LIST_CNT_R(sub_idx) = 1; 09158 IL_FLD(list_idx) = CN_Tbl_Idx; 09159 IL_IDX(list_idx) = CN_INTEGER_TWO_IDX; 09160 IL_LINE_NUM(list_idx) = line; 09161 IL_COL_NUM(list_idx) = col; 09162 09163 NTR_IR_TBL(asg_idx); 09164 IR_OPR(asg_idx) = Init_Reloc_Opr; 09165 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 09166 IR_LINE_NUM(asg_idx) = line; 09167 IR_COL_NUM(asg_idx) = col; 09168 09169 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09170 IR_IDX_L(asg_idx) = sub_idx; 09171 09172 NTR_IR_TBL(loc_idx); 09173 IR_OPR(loc_idx) = Loc_Opr; 09174 IR_LINE_NUM(loc_idx) = line; 09175 IR_COL_NUM(loc_idx) = col; 09176 09177 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 09178 09179 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 09180 IR_IDX_L(loc_idx) = desc_idx; 09181 IR_LINE_NUM_L(loc_idx) = line; 09182 IR_COL_NUM_L(loc_idx) = col; 09183 09184 NTR_IR_LIST_TBL(list_idx); 09185 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09186 IR_IDX_R(asg_idx) = list_idx; 09187 IR_LIST_CNT_R(asg_idx) = 2; 09188 IL_FLD(list_idx) = IR_Tbl_Idx; 09189 IL_IDX(list_idx) = loc_idx; 09190 09191 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09192 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09193 list_idx = IL_NEXT_LIST_IDX(list_idx); 09194 09195 IL_FLD(list_idx) = CN_Tbl_Idx; 09196 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09197 IL_LINE_NUM(list_idx) = line; 09198 IL_COL_NUM(list_idx) = col; 09199 } 09200 09201 09202 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09203 09204 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09205 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09206 09207 09208 /*************************************************\ 09209 |* create argument descriptors for all arguments *| 09210 \*************************************************/ 09211 09212 for (i = 0; i < count; i++) { 09213 09214 the_constant++; 09215 09216 NTR_IR_TBL(sub_idx); 09217 IR_OPR(sub_idx) = Subscript_Opr; 09218 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09219 IR_LINE_NUM(sub_idx) = line; 09220 IR_COL_NUM(sub_idx) = col; 09221 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09222 IR_IDX_L(sub_idx) = static_tmp_idx; 09223 IR_LINE_NUM_L(sub_idx) = line; 09224 IR_COL_NUM_L(sub_idx) = col; 09225 09226 NTR_IR_LIST_TBL(list_idx); 09227 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09228 IR_IDX_R(sub_idx) = list_idx; 09229 IR_LIST_CNT_R(sub_idx) = 1; 09230 IL_FLD(list_idx) = CN_Tbl_Idx; 09231 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant); 09232 IL_LINE_NUM(list_idx) = line; 09233 IL_COL_NUM(list_idx) = col; 09234 09235 if (this_is_call && 09236 IL_ARG_DESC_IDX(arg_idx) == NULL_IDX) { 09237 09238 /* argument not present, initialize to zero */ 09239 09240 NTR_IR_TBL(asg_idx); 09241 IR_OPR(asg_idx) = Init_Opr; 09242 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 09243 IR_LINE_NUM(asg_idx) = line; 09244 IR_COL_NUM(asg_idx) = col; 09245 09246 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09247 IR_IDX_L(asg_idx) = sub_idx; 09248 09249 NTR_IR_LIST_TBL(list_idx); 09250 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09251 IR_IDX_R(asg_idx) = list_idx; 09252 IR_LIST_CNT_R(asg_idx) = 3; 09253 09254 IL_FLD(list_idx) = CN_Tbl_Idx; 09255 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09256 IL_LINE_NUM(list_idx) = line; 09257 IL_COL_NUM(list_idx) = col; 09258 09259 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09260 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09261 list_idx = IL_NEXT_LIST_IDX(list_idx); 09262 09263 IL_FLD(list_idx) = CN_Tbl_Idx; 09264 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 09265 IL_LINE_NUM(list_idx) = line; 09266 IL_COL_NUM(list_idx) = col; 09267 09268 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09269 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09270 list_idx = IL_NEXT_LIST_IDX(list_idx); 09271 09272 IL_FLD(list_idx) = CN_Tbl_Idx; 09273 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09274 IL_LINE_NUM(list_idx) = line; 09275 IL_COL_NUM(list_idx) = col; 09276 } 09277 else { 09278 09279 desc_idx = gen_arg_type_descriptor(arg_idx, 09280 this_is_call, 09281 line, 09282 col); 09283 09284 if (ATD_STOR_BLK_IDX(desc_idx) == SCP_SB_STACK_IDX(curr_scp_idx)) { 09285 09286 IR_IDX_L(sub_idx) = stack_tmp_idx; 09287 09288 NTR_IR_TBL(asg_idx); 09289 IR_OPR(asg_idx) = Asg_Opr; 09290 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 09291 IR_LINE_NUM(asg_idx) = line; 09292 IR_COL_NUM(asg_idx) = col; 09293 09294 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09295 IR_IDX_L(asg_idx) = sub_idx; 09296 09297 NTR_IR_TBL(loc_idx); 09298 IR_OPR(loc_idx) = Loc_Opr; 09299 IR_LINE_NUM(loc_idx) = line; 09300 IR_COL_NUM(loc_idx) = col; 09301 09302 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 09303 09304 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 09305 IR_IDX_L(loc_idx) = desc_idx; 09306 IR_LINE_NUM_L(loc_idx) = line; 09307 IR_COL_NUM_L(loc_idx) = col; 09308 09309 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 09310 IR_IDX_R(asg_idx) = loc_idx; 09311 } 09312 else { 09313 09314 NTR_IR_TBL(asg_idx); 09315 IR_OPR(asg_idx) = Init_Reloc_Opr; 09316 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 09317 IR_LINE_NUM(asg_idx) = line; 09318 IR_COL_NUM(asg_idx) = col; 09319 09320 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09321 IR_IDX_L(asg_idx) = sub_idx; 09322 09323 NTR_IR_TBL(loc_idx); 09324 IR_OPR(loc_idx) = Loc_Opr; 09325 IR_LINE_NUM(loc_idx) = line; 09326 IR_COL_NUM(loc_idx) = col; 09327 09328 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 09329 09330 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 09331 IR_IDX_L(loc_idx) = desc_idx; 09332 IR_LINE_NUM_L(loc_idx) = line; 09333 IR_COL_NUM_L(loc_idx) = col; 09334 09335 NTR_IR_LIST_TBL(list_idx); 09336 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09337 IR_IDX_R(asg_idx) = list_idx; 09338 IR_LIST_CNT_R(asg_idx) = 2; 09339 IL_FLD(list_idx) = IR_Tbl_Idx; 09340 IL_IDX(list_idx) = loc_idx; 09341 09342 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09343 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09344 list_idx = IL_NEXT_LIST_IDX(list_idx); 09345 09346 IL_FLD(list_idx) = CN_Tbl_Idx; 09347 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09348 IL_LINE_NUM(list_idx) = line; 09349 IL_COL_NUM(list_idx) = col; 09350 } 09351 } 09352 09353 09354 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09355 09356 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09357 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09358 09359 09360 if (this_is_call) { 09361 arg_idx = IL_NEXT_LIST_IDX(arg_idx); 09362 } 09363 else { 09364 arg_idx++; 09365 } 09366 } 09367 09368 if (num_argchck_suppress_msg > 0) { 09369 for (i = 1; i <= num_argchck_suppress_msg+1; i++) { 09370 the_constant++; 09371 09372 NTR_IR_TBL(sub_idx); 09373 IR_OPR(sub_idx) = Subscript_Opr; 09374 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09375 IR_LINE_NUM(sub_idx) = line; 09376 IR_COL_NUM(sub_idx) = col; 09377 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09378 IR_IDX_L(sub_idx) = static_tmp_idx; 09379 IR_LINE_NUM_L(sub_idx) = line; 09380 IR_COL_NUM_L(sub_idx) = col; 09381 09382 NTR_IR_LIST_TBL(list_idx); 09383 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09384 IR_IDX_R(sub_idx) = list_idx; 09385 IR_LIST_CNT_R(sub_idx) = 1; 09386 IL_FLD(list_idx) = CN_Tbl_Idx; 09387 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant); 09388 IL_LINE_NUM(list_idx) = line; 09389 IL_COL_NUM(list_idx) = col; 09390 09391 NTR_IR_TBL(asg_idx); 09392 IR_OPR(asg_idx) = Init_Opr; 09393 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 09394 IR_LINE_NUM(asg_idx) = line; 09395 IR_COL_NUM(asg_idx) = col; 09396 09397 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09398 IR_IDX_L(asg_idx) = sub_idx; 09399 09400 NTR_IR_LIST_TBL(list_idx); 09401 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09402 IR_IDX_R(asg_idx) = list_idx; 09403 IR_LIST_CNT_R(asg_idx) = 3; 09404 09405 the_constant2 = argchck_suppress_msg[i]; 09406 09407 IL_FLD(list_idx) = CN_Tbl_Idx; 09408 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant2); 09409 IL_LINE_NUM(list_idx) = line; 09410 IL_COL_NUM(list_idx) = col; 09411 09412 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09413 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09414 list_idx = IL_NEXT_LIST_IDX(list_idx); 09415 09416 IL_FLD(list_idx) = CN_Tbl_Idx; 09417 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 09418 IL_LINE_NUM(list_idx) = line; 09419 IL_COL_NUM(list_idx) = col; 09420 09421 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09422 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09423 list_idx = IL_NEXT_LIST_IDX(list_idx); 09424 09425 IL_FLD(list_idx) = CN_Tbl_Idx; 09426 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09427 IL_LINE_NUM(list_idx) = line; 09428 IL_COL_NUM(list_idx) = col; 09429 09430 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09431 09432 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09433 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09434 } 09435 } 09436 09437 TRACE (Func_Exit, "create_argchck_descriptor", NULL); 09438 09439 return(stack_tmp_idx); 09440 09441 } /* create_argchck_descriptor */ 09442 09443 /******************************************************************************\ 09444 |* *| 09445 |* Description: *| 09446 |* <description> *| 09447 |* *| 09448 |* Input parameters: *| 09449 |* NONE *| 09450 |* *| 09451 |* Output parameters: *| 09452 |* NONE *| 09453 |* *| 09454 |* Returns: *| 09455 |* NOTHING *| 09456 |* *| 09457 \******************************************************************************/ 09458 09459 static int gen_call_type_descriptor(int attr_idx, 09460 int rslt_idx, 09461 boolean this_is_call, 09462 int line, 09463 int col) 09464 09465 { 09466 int act_file_line; 09467 int asg_idx; 09468 int const_idx; 09469 expr_arg_type exp_desc; 09470 int glb_idx; 09471 int idx; 09472 int list_idx; 09473 int loc_idx; 09474 long_type num[MAX_WORDS_FOR_INTEGER]; 09475 boolean ok; 09476 opnd_type opnd; 09477 int sub_idx; 09478 int static_tmp_idx; 09479 int stack_tmp_idx = NULL_IDX; 09480 long_type the_constant; 09481 int type_idx; 09482 09483 09484 TRACE (Func_Entry, "gen_call_type_descriptor", NULL); 09485 09486 /*******************************\ 09487 |* create the descriptor table *| 09488 \*******************************/ 09489 09490 static_tmp_idx = gen_static_integer_array_tmp(NUM_TARGET_ARGCHCK_DESC_WORDS, 09491 line, 09492 col); 09493 09494 09495 if (ATP_PGM_UNIT(attr_idx) == Function && 09496 ((ATD_ARRAY_IDX(rslt_idx) != NULL_IDX && 09497 BD_LEN_FLD(ATD_ARRAY_IDX(rslt_idx)) != CN_Tbl_Idx && 09498 BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)) != NULL_IDX) || 09499 (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character && 09500 TYP_FLD(ATD_TYPE_IDX(rslt_idx)) != CN_Tbl_Idx))) { 09501 09502 stack_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 09503 09504 ATD_TYPE_IDX(stack_tmp_idx) = ATD_TYPE_IDX(static_tmp_idx); 09505 ATD_STOR_BLK_IDX(stack_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 09506 09507 /* This new tmp is fully created, so does not need decl_semantics */ 09508 09509 AT_SEMANTICS_DONE(stack_tmp_idx) = TRUE; 09510 09511 ATD_ARRAY_IDX(stack_tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx); 09512 09513 09514 /***********************************\ 09515 |* copy static attr to stack attr. *| 09516 \***********************************/ 09517 09518 OPND_FLD(opnd) = AT_Tbl_Idx; 09519 OPND_IDX(opnd) = stack_tmp_idx; 09520 OPND_LINE_NUM(opnd) = line; 09521 OPND_COL_NUM(opnd) = col; 09522 09523 ok = gen_whole_subscript(&opnd, &exp_desc); 09524 09525 NTR_IR_TBL(asg_idx); 09526 IR_OPR(asg_idx) = Asg_Opr; 09527 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 09528 IR_LINE_NUM(asg_idx) = line; 09529 IR_COL_NUM(asg_idx) = col; 09530 09531 COPY_OPND(IR_OPND_L(asg_idx), opnd); 09532 09533 OPND_FLD(opnd) = AT_Tbl_Idx; 09534 OPND_IDX(opnd) = static_tmp_idx; 09535 OPND_LINE_NUM(opnd) = line; 09536 OPND_COL_NUM(opnd) = col; 09537 09538 ok = gen_whole_subscript(&opnd, &exp_desc); 09539 09540 COPY_OPND(IR_OPND_R(asg_idx), opnd); 09541 09542 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09543 09544 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09545 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09546 09547 } 09548 09549 /* get a typeless constant that is one less than the size of the temp */ 09550 /* This is to allow a reloc init on the last word. Some codegens won't */ 09551 /* allow multiple inits of the same address. */ 09552 09553 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 09554 TYP_TYPE(TYP_WORK_IDX) = Typeless; 09555 TYP_BIT_LEN(TYP_WORK_IDX) = (NUM_TARGET_ARGCHCK_DESC_WORDS - 1) * 09556 TARGET_BITS_PER_WORD; 09557 type_idx = ntr_type_tbl(); 09558 09559 const_idx = ntr_const_tbl(type_idx, FALSE, NULL); 09560 09561 NTR_IR_TBL(sub_idx); 09562 IR_OPR(sub_idx) = Subscript_Opr; 09563 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09564 IR_LINE_NUM(sub_idx) = line; 09565 IR_COL_NUM(sub_idx) = col; 09566 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09567 IR_IDX_L(sub_idx) = static_tmp_idx; 09568 IR_LINE_NUM_L(sub_idx) = line; 09569 IR_COL_NUM_L(sub_idx) = col; 09570 09571 NTR_IR_LIST_TBL(list_idx); 09572 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09573 IR_IDX_R(sub_idx) = list_idx; 09574 IR_LIST_CNT_R(sub_idx) = 1; 09575 IL_FLD(list_idx) = CN_Tbl_Idx; 09576 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 09577 IL_LINE_NUM(list_idx) = line; 09578 IL_COL_NUM(list_idx) = col; 09579 09580 09581 NTR_IR_TBL(asg_idx); 09582 IR_OPR(asg_idx) = Init_Opr; 09583 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 09584 IR_LINE_NUM(asg_idx) = line; 09585 IR_COL_NUM(asg_idx) = col; 09586 09587 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09588 IR_IDX_L(asg_idx) = sub_idx; 09589 09590 NTR_IR_LIST_TBL(list_idx); 09591 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09592 IR_IDX_R(asg_idx) = list_idx; 09593 IR_LIST_CNT_R(asg_idx) = 3; 09594 09595 IL_FLD(list_idx) = CN_Tbl_Idx; 09596 IL_IDX(list_idx) = const_idx; 09597 IL_LINE_NUM(list_idx) = line; 09598 IL_COL_NUM(list_idx) = col; 09599 09600 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09601 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09602 list_idx = IL_NEXT_LIST_IDX(list_idx); 09603 09604 IL_FLD(list_idx) = CN_Tbl_Idx; 09605 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 09606 IL_LINE_NUM(list_idx) = line; 09607 IL_COL_NUM(list_idx) = col; 09608 09609 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09610 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09611 list_idx = IL_NEXT_LIST_IDX(list_idx); 09612 09613 IL_FLD(list_idx) = CN_Tbl_Idx; 09614 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09615 IL_LINE_NUM(list_idx) = line; 09616 IL_COL_NUM(list_idx) = col; 09617 09618 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09619 09620 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09621 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09622 09623 /****************************\ 09624 |* Now fill in the constant *| 09625 \****************************/ 09626 09627 /* BRIANJ - arg desc fields. */ 09628 09629 /* fill in name and file line num for traceback */ 09630 09631 strcpy(((arg_desc_node_type *)&(CN_CONST(const_idx)))->name, 09632 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 09633 09634 if (this_is_call) { /* BRIANJ */ 09635 GLOBAL_LINE_TO_FILE_LINE(line, glb_idx, act_file_line); 09636 C_TO_F_INT(num, act_file_line, CG_INTEGER_DEFAULT_TYPE); 09637 09638 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->line = num[0]; 09639 } 09640 09641 if (ATP_PGM_UNIT(attr_idx) == Function) { 09642 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type = 09643 get_arg_type(ATD_TYPE_IDX(rslt_idx), 09644 TRUE); 09645 C_TO_F_INT(num, 09646 linear_to_kind_type[TYP_LINEAR(ATD_TYPE_IDX(rslt_idx))], 09647 CG_INTEGER_DEFAULT_TYPE); 09648 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->kind = num[0]; 09649 09650 if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX) { 09651 09652 C_TO_F_INT(num, 09653 BD_RANK(ATD_ARRAY_IDX(rslt_idx)), 09654 CG_INTEGER_DEFAULT_TYPE); 09655 09656 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0]; 09657 09658 if (BD_LEN_FLD(ATD_ARRAY_IDX(rslt_idx)) == CN_Tbl_Idx && 09659 BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)) != NULL_IDX) { 09660 09661 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = 09662 CN_CONST(BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx))); 09663 } 09664 else if (BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)) != NULL_IDX) { 09665 /* runtime code to set the size */ 09666 09667 NTR_IR_TBL(sub_idx); 09668 IR_OPR(sub_idx) = Subscript_Opr; 09669 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09670 IR_LINE_NUM(sub_idx) = line; 09671 IR_COL_NUM(sub_idx) = col; 09672 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09673 IR_IDX_L(sub_idx) = stack_tmp_idx; 09674 IR_LINE_NUM_L(sub_idx) = line; 09675 IR_COL_NUM_L(sub_idx) = col; 09676 09677 NTR_IR_LIST_TBL(list_idx); 09678 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09679 IR_IDX_R(sub_idx) = list_idx; 09680 IR_LIST_CNT_R(sub_idx) = 1; 09681 IL_FLD(list_idx) = CN_Tbl_Idx; 09682 09683 the_constant = ARGCHCK_SIZE_IDX; 09684 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 09685 the_constant); 09686 IL_LINE_NUM(list_idx) = line; 09687 IL_COL_NUM(list_idx) = col; 09688 09689 NTR_IR_TBL(asg_idx); 09690 IR_OPR(asg_idx) = Asg_Opr; 09691 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 09692 IR_LINE_NUM(asg_idx) = line; 09693 IR_COL_NUM(asg_idx) = col; 09694 09695 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09696 IR_IDX_L(asg_idx) = sub_idx; 09697 09698 IR_FLD_R(asg_idx) = BD_LEN_FLD(ATD_ARRAY_IDX(rslt_idx)); 09699 IR_IDX_R(asg_idx) = BD_LEN_IDX(ATD_ARRAY_IDX(rslt_idx)); 09700 IR_LINE_NUM_R(asg_idx) = line; 09701 IR_COL_NUM_R(asg_idx) = col; 09702 09703 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09704 09705 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09706 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09707 } 09708 } 09709 else { 09710 C_TO_F_INT(num, 1, CG_INTEGER_DEFAULT_TYPE); 09711 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = num[0]; 09712 09713 C_TO_F_INT(num, 0, CG_INTEGER_DEFAULT_TYPE); 09714 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0]; 09715 } 09716 09717 if (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character) { 09718 09719 if (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character && 09720 TYP_CHAR_CLASS(ATD_TYPE_IDX(rslt_idx)) == Assumed_Size_Char) { 09721 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_size_char = 09722 TRUE; 09723 } 09724 else if (TYP_FLD(ATD_TYPE_IDX(rslt_idx)) == CN_Tbl_Idx) { 09725 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->char_len = 09726 CN_CONST(TYP_IDX(ATD_TYPE_IDX(rslt_idx))); 09727 } 09728 else { 09729 /* generate runtime code to insert the char length */ 09730 09731 NTR_IR_TBL(sub_idx); 09732 IR_OPR(sub_idx) = Subscript_Opr; 09733 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09734 IR_LINE_NUM(sub_idx) = line; 09735 IR_COL_NUM(sub_idx) = col; 09736 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09737 IR_IDX_L(sub_idx) = stack_tmp_idx; 09738 IR_LINE_NUM_L(sub_idx) = line; 09739 IR_COL_NUM_L(sub_idx) = col; 09740 09741 NTR_IR_LIST_TBL(list_idx); 09742 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09743 IR_IDX_R(sub_idx) = list_idx; 09744 IR_LIST_CNT_R(sub_idx) = 1; 09745 IL_FLD(list_idx) = CN_Tbl_Idx; 09746 IL_LINE_NUM(list_idx) = line; 09747 IL_COL_NUM(list_idx) = col; 09748 09749 the_constant = ARGCHCK_CHAR_LEN_IDX; 09750 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 09751 the_constant); 09752 09753 NTR_IR_TBL(asg_idx); 09754 IR_OPR(asg_idx) = Asg_Opr; 09755 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 09756 IR_LINE_NUM(asg_idx) = line; 09757 IR_COL_NUM(asg_idx) = col; 09758 09759 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09760 IR_IDX_L(asg_idx) = sub_idx; 09761 09762 IR_FLD_R(asg_idx) = TYP_FLD(ATD_TYPE_IDX(rslt_idx)); 09763 IR_IDX_R(asg_idx) = TYP_IDX(ATD_TYPE_IDX(rslt_idx)); 09764 IR_LINE_NUM_R(asg_idx) = line; 09765 IR_COL_NUM_R(asg_idx) = col; 09766 09767 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09768 09769 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09770 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09771 09772 } 09773 } 09774 else if (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Structure) { 09775 /* generate derived type table, always static */ 09776 09777 NTR_IR_TBL(sub_idx); 09778 IR_OPR(sub_idx) = Subscript_Opr; 09779 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 09780 IR_LINE_NUM(sub_idx) = line; 09781 IR_COL_NUM(sub_idx) = col; 09782 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 09783 IR_IDX_L(sub_idx) = static_tmp_idx; 09784 IR_LINE_NUM_L(sub_idx) = line; 09785 IR_COL_NUM_L(sub_idx) = col; 09786 09787 NTR_IR_LIST_TBL(list_idx); 09788 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 09789 IR_IDX_R(sub_idx) = list_idx; 09790 IR_LIST_CNT_R(sub_idx) = 1; 09791 IL_FLD(list_idx) = CN_Tbl_Idx; 09792 the_constant = ARGCHCK_STRUCT_TBL_IDX; 09793 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, the_constant); 09794 IL_LINE_NUM(list_idx) = line; 09795 IL_COL_NUM(list_idx) = col; 09796 09797 NTR_IR_TBL(asg_idx); 09798 IR_OPR(asg_idx) = Init_Reloc_Opr; 09799 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 09800 IR_LINE_NUM(asg_idx) = line; 09801 IR_COL_NUM(asg_idx) = col; 09802 09803 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 09804 IR_IDX_L(asg_idx) = sub_idx; 09805 09806 NTR_IR_TBL(loc_idx); 09807 IR_OPR(loc_idx) = Loc_Opr; 09808 IR_LINE_NUM(loc_idx) = line; 09809 IR_COL_NUM(loc_idx) = col; 09810 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 09811 09812 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 09813 idx = create_struct_argchck_tbl(TYP_IDX(ATD_TYPE_IDX(rslt_idx))); 09814 IR_IDX_L(loc_idx) = idx; 09815 IR_LINE_NUM_L(loc_idx) = line; 09816 IR_COL_NUM_L(loc_idx) = col; 09817 09818 NTR_IR_LIST_TBL(list_idx); 09819 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09820 IR_IDX_R(asg_idx) = list_idx; 09821 IR_LIST_CNT_R(asg_idx) = 2; 09822 IL_FLD(list_idx) = IR_Tbl_Idx; 09823 IL_IDX(list_idx) = loc_idx; 09824 09825 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09826 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09827 list_idx = IL_NEXT_LIST_IDX(list_idx); 09828 09829 IL_FLD(list_idx) = CN_Tbl_Idx; 09830 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09831 IL_LINE_NUM(list_idx) = line; 09832 IL_COL_NUM(list_idx) = col; 09833 09834 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09835 09836 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09837 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09838 } 09839 09840 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pointer = 09841 ATD_POINTER(rslt_idx); 09842 } 09843 else if (ATP_PGM_UNIT(attr_idx) == Subroutine) { 09844 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type = 09845 Subroutine_Arg; 09846 } 09847 else { 09848 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type = 09849 Subprogram_Arg; 09850 } 09851 09852 TRACE (Func_Exit, "gen_call_type_descriptor", NULL); 09853 09854 return((stack_tmp_idx ? stack_tmp_idx : static_tmp_idx)); 09855 09856 } /* gen_call_type_descriptor */ 09857 09858 /******************************************************************************\ 09859 |* *| 09860 |* Description: *| 09861 |* <description> *| 09862 |* *| 09863 |* Input parameters: *| 09864 |* NONE *| 09865 |* *| 09866 |* Output parameters: *| 09867 |* NONE *| 09868 |* *| 09869 |* Returns: *| 09870 |* NOTHING *| 09871 |* *| 09872 \******************************************************************************/ 09873 09874 static int gen_arg_type_descriptor(int idx, 09875 boolean this_is_call, 09876 int line, 09877 int col) 09878 09879 { 09880 int asg_idx; 09881 int attr_idx = NULL_IDX; 09882 int bd_idx = NULL_IDX; 09883 opnd_type char_len_opnd; /* BRIANJ - set but not used.*/ 09884 int const_idx; 09885 expr_arg_type exp_desc; 09886 long_type folded_const[MAX_WORDS_FOR_INTEGER]; 09887 int i; 09888 int info_idx; 09889 opnd_type len_opnd; 09890 int list_idx; 09891 int loc_idx; 09892 int mult_idx; 09893 long_type num[MAX_WORDS_FOR_INTEGER]; 09894 boolean ok; 09895 opnd_type opnd; 09896 boolean pgm_unit = FALSE; 09897 int rank = 0; 09898 expr_mode_type save_expr_mode; 09899 cif_usage_code_type save_xref_state; 09900 int sub_idx; 09901 int static_tmp_idx; 09902 int stack_tmp_idx = NULL_IDX; 09903 int type_idx = NULL_IDX; 09904 int type_idx2; 09905 int unused1; 09906 int unused2; 09907 09908 09909 TRACE (Func_Entry, "gen_arg_type_descriptor", NULL); 09910 09911 len_opnd = null_opnd; 09912 OPND_LINE_NUM(len_opnd) = line; 09913 OPND_COL_NUM(len_opnd) = col; 09914 09915 if (this_is_call) { 09916 /* then idx is a IL_TBl_Idx */ 09917 09918 info_idx = IL_ARG_DESC_IDX(idx); 09919 09920 # ifdef _DEBUG 09921 if (info_idx == NULL_IDX) { 09922 PRINTMSG(line, 626, Internal, col, 09923 "valid info_idx", "gen_arg_type_descriptor"); 09924 } 09925 # endif 09926 09927 pgm_unit = arg_info_list[info_idx].pgm_unit; 09928 09929 COPY_OPND(opnd, IL_OPND(idx)); 09930 09931 if (OPND_FLD(opnd) == IR_Tbl_Idx && 09932 (IR_OPR(OPND_IDX(opnd)) == Loc_Opr || 09933 IR_OPR(OPND_IDX(opnd)) == Aloc_Opr || 09934 IR_OPR(OPND_IDX(opnd)) == Const_Tmp_Loc_Opr)) { 09935 09936 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 09937 } 09938 09939 if (OPND_FLD(opnd) == IR_Tbl_Idx && 09940 (IR_OPR(OPND_IDX(opnd)) == Substring_Opr || 09941 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr)) { 09942 09943 COPY_OPND(char_len_opnd, 09944 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX( 09945 IR_IDX_R(OPND_IDX(opnd)))))); 09946 } 09947 09948 type_idx = arg_info_list[info_idx].ed.type_idx; 09949 rank = arg_info_list[info_idx].ed.rank; 09950 09951 if (arg_info_list[info_idx].association == PASS_SECTION_ADDRESS || 09952 arg_info_list[info_idx].association == PASS_ADDRESS_FROM_DV || 09953 arg_info_list[info_idx].association == CHECK_CONTIG_FLAG) { 09954 /* must get the array length from shape */ 09955 09956 COPY_OPND(len_opnd, arg_info_list[info_idx].ed.shape[0]); 09957 09958 for (i = 1; i < rank; i++) { 09959 NTR_IR_TBL(mult_idx); 09960 IR_OPR(mult_idx) = Mult_Opr; 09961 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 09962 IR_LINE_NUM(mult_idx) = line; 09963 IR_COL_NUM(mult_idx) = col; 09964 09965 COPY_OPND(IR_OPND_L(mult_idx), len_opnd); 09966 09967 COPY_OPND(IR_OPND_R(mult_idx), 09968 arg_info_list[info_idx].ed.shape[i]); 09969 09970 OPND_FLD(len_opnd) = IR_Tbl_Idx; 09971 OPND_IDX(len_opnd) = mult_idx; 09972 } 09973 09974 save_xref_state = xref_state; 09975 xref_state = CIF_No_Usage_Rec; 09976 save_expr_mode = expr_mode; 09977 expr_mode = Regular_Expr; 09978 09979 exp_desc.rank = 0; 09980 ok = expr_semantics(&len_opnd, &exp_desc); 09981 xref_state = save_xref_state; 09982 expr_mode = save_expr_mode; 09983 } 09984 else if (IL_FLD(idx) != CN_Tbl_Idx) { 09985 09986 COPY_OPND(opnd, IL_OPND(idx)); 09987 attr_idx = find_base_attr(&opnd, &unused1, &unused2); 09988 09989 if (attr_idx != NULL_IDX && 09990 AT_OBJ_CLASS(attr_idx) == Data_Obj && 09991 ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 09992 09993 bd_idx = ATD_ARRAY_IDX(attr_idx); 09994 09995 if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape || 09996 BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) { 09997 /* must get the array length from shape */ 09998 09999 COPY_OPND(len_opnd, arg_info_list[info_idx].ed.shape[0]); 10000 10001 for (i = 1; i < rank; i++) { 10002 NTR_IR_TBL(mult_idx); 10003 IR_OPR(mult_idx) = Mult_Opr; 10004 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 10005 IR_LINE_NUM(mult_idx) = line; 10006 IR_COL_NUM(mult_idx) = col; 10007 10008 COPY_OPND(IR_OPND_L(mult_idx), len_opnd); 10009 10010 COPY_OPND(IR_OPND_R(mult_idx), 10011 arg_info_list[info_idx].ed.shape[i]); 10012 10013 OPND_FLD(len_opnd) = IR_Tbl_Idx; 10014 OPND_IDX(len_opnd) = mult_idx; 10015 } 10016 10017 save_xref_state = xref_state; 10018 xref_state = CIF_No_Usage_Rec; 10019 save_expr_mode = expr_mode; 10020 expr_mode = Regular_Expr; 10021 10022 exp_desc.rank = 0; 10023 ok = expr_semantics(&len_opnd, &exp_desc); 10024 xref_state = save_xref_state; 10025 expr_mode = save_expr_mode; 10026 } 10027 else { 10028 OPND_FLD(len_opnd) = BD_LEN_FLD(bd_idx); 10029 OPND_IDX(len_opnd) = BD_LEN_IDX(bd_idx); 10030 } 10031 } 10032 } 10033 } 10034 else { 10035 /* idx is an secondary name table idx */ 10036 attr_idx = SN_ATTR_IDX(idx); 10037 10038 pgm_unit = (AT_OBJ_CLASS(attr_idx) == Pgm_Unit); 10039 10040 if (pgm_unit) { 10041 if (ATP_PGM_UNIT(attr_idx) == Function) { 10042 10043 if (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)) != NULL_IDX) { 10044 bd_idx = ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)); 10045 10046 rank = BD_RANK(bd_idx); 10047 10048 OPND_FLD(len_opnd) = BD_LEN_FLD(bd_idx); 10049 OPND_IDX(len_opnd) = BD_LEN_IDX(bd_idx); 10050 } 10051 10052 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 10053 10054 if (TYP_TYPE(type_idx) == Character) { 10055 OPND_FLD(char_len_opnd) = TYP_FLD(type_idx); 10056 OPND_IDX(char_len_opnd) = TYP_IDX(type_idx); 10057 } 10058 } 10059 } 10060 else { 10061 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 10062 ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 10063 bd_idx = ATD_ARRAY_IDX(attr_idx); 10064 10065 rank = BD_RANK(bd_idx); 10066 10067 OPND_FLD(len_opnd) = BD_LEN_FLD(bd_idx); 10068 OPND_IDX(len_opnd) = BD_LEN_IDX(bd_idx); 10069 } 10070 10071 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 10072 type_idx = ATD_TYPE_IDX(attr_idx); 10073 10074 if (TYP_TYPE(type_idx) == Character) { 10075 OPND_FLD(char_len_opnd) = TYP_FLD(type_idx); 10076 OPND_IDX(char_len_opnd) = TYP_IDX(type_idx); 10077 } 10078 } 10079 } 10080 } 10081 10082 /*******************************\ 10083 |* create the descriptor table *| 10084 \*******************************/ 10085 10086 static_tmp_idx = gen_static_integer_array_tmp(NUM_TARGET_ARGCHCK_DESC_WORDS, 10087 line, 10088 col); 10089 10090 if (type_idx && 10091 ((rank != 0 && 10092 OPND_FLD(len_opnd) != CN_Tbl_Idx && 10093 OPND_IDX(len_opnd) != NULL_IDX) || 10094 (TYP_TYPE(type_idx) == Character && 10095 TYP_FLD(type_idx) != CN_Tbl_Idx))) { 10096 10097 stack_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 10098 10099 ATD_TYPE_IDX(stack_tmp_idx) = ATD_TYPE_IDX(static_tmp_idx); 10100 ATD_STOR_BLK_IDX(stack_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 10101 10102 /* This new tmp is fully created, so does not need decl_semantics */ 10103 10104 AT_SEMANTICS_DONE(stack_tmp_idx) = TRUE; 10105 10106 ATD_ARRAY_IDX(stack_tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx); 10107 10108 10109 /***********************************\ 10110 |* copy static attr to stack attr. *| 10111 \***********************************/ 10112 10113 OPND_FLD(opnd) = AT_Tbl_Idx; 10114 OPND_IDX(opnd) = stack_tmp_idx; 10115 OPND_LINE_NUM(opnd) = line; 10116 OPND_COL_NUM(opnd) = col; 10117 10118 ok = gen_whole_subscript(&opnd, &exp_desc); 10119 10120 NTR_IR_TBL(asg_idx); 10121 IR_OPR(asg_idx) = Asg_Opr; 10122 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 10123 IR_LINE_NUM(asg_idx) = line; 10124 IR_COL_NUM(asg_idx) = col; 10125 10126 COPY_OPND(IR_OPND_L(asg_idx), opnd); 10127 10128 OPND_FLD(opnd) = AT_Tbl_Idx; 10129 OPND_IDX(opnd) = static_tmp_idx; 10130 OPND_LINE_NUM(opnd) = line; 10131 OPND_COL_NUM(opnd) = col; 10132 10133 ok = gen_whole_subscript(&opnd, &exp_desc); 10134 10135 COPY_OPND(IR_OPND_R(asg_idx), opnd); 10136 10137 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 10138 10139 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 10140 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10141 10142 } 10143 10144 10145 /* get a typeless constant that is one less than the size of the temp */ 10146 /* This is to allow a reloc init on the last word. Some codegens won't */ 10147 /* allow multiple inits of the same address. */ 10148 10149 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 10150 TYP_TYPE(TYP_WORK_IDX) = Typeless; 10151 TYP_BIT_LEN(TYP_WORK_IDX) = (NUM_TARGET_ARGCHCK_DESC_WORDS - 1) * 10152 TARGET_BITS_PER_WORD; 10153 type_idx2 = ntr_type_tbl(); 10154 10155 const_idx = ntr_const_tbl(type_idx2, FALSE, NULL); 10156 10157 NTR_IR_TBL(sub_idx); 10158 IR_OPR(sub_idx) = Subscript_Opr; 10159 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 10160 IR_LINE_NUM(sub_idx) = line; 10161 IR_COL_NUM(sub_idx) = col; 10162 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 10163 IR_IDX_L(sub_idx) = static_tmp_idx; 10164 IR_LINE_NUM_L(sub_idx) = line; 10165 IR_COL_NUM_L(sub_idx) = col; 10166 10167 NTR_IR_LIST_TBL(list_idx); 10168 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 10169 IR_IDX_R(sub_idx) = list_idx; 10170 IR_LIST_CNT_R(sub_idx) = 1; 10171 IL_FLD(list_idx) = CN_Tbl_Idx; 10172 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 10173 IL_LINE_NUM(list_idx) = line; 10174 IL_COL_NUM(list_idx) = col; 10175 10176 10177 NTR_IR_TBL(asg_idx); 10178 IR_OPR(asg_idx) = Init_Opr; 10179 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 10180 IR_LINE_NUM(asg_idx) = line; 10181 IR_COL_NUM(asg_idx) = col; 10182 10183 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 10184 IR_IDX_L(asg_idx) = sub_idx; 10185 10186 NTR_IR_LIST_TBL(list_idx); 10187 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 10188 IR_IDX_R(asg_idx) = list_idx; 10189 IR_LIST_CNT_R(asg_idx) = 3; 10190 10191 IL_FLD(list_idx) = CN_Tbl_Idx; 10192 IL_IDX(list_idx) = const_idx; 10193 IL_LINE_NUM(list_idx) = line; 10194 IL_COL_NUM(list_idx) = col; 10195 10196 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 10197 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10198 list_idx = IL_NEXT_LIST_IDX(list_idx); 10199 10200 IL_FLD(list_idx) = CN_Tbl_Idx; 10201 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 10202 IL_LINE_NUM(list_idx) = line; 10203 IL_COL_NUM(list_idx) = col; 10204 10205 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 10206 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10207 list_idx = IL_NEXT_LIST_IDX(list_idx); 10208 10209 IL_FLD(list_idx) = CN_Tbl_Idx; 10210 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 10211 IL_LINE_NUM(list_idx) = line; 10212 IL_COL_NUM(list_idx) = col; 10213 10214 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 10215 10216 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 10217 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10218 10219 /****************************\ 10220 |* Now fill in the constant *| 10221 \****************************/ 10222 10223 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pgm_unit = pgm_unit; 10224 10225 if (attr_idx && 10226 AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 10227 ATP_PGM_UNIT(attr_idx) == Subroutine) { 10228 10229 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type = 10230 Subroutine_Arg; 10231 } 10232 else if (type_idx) { 10233 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->arg_type = 10234 get_arg_type(type_idx, pgm_unit); 10235 10236 C_TO_F_INT(num, 10237 linear_to_kind_type[TYP_LINEAR(type_idx)], 10238 CG_INTEGER_DEFAULT_TYPE); 10239 10240 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->kind = num[0]; 10241 C_TO_F_INT(num, rank, CG_INTEGER_DEFAULT_TYPE); 10242 10243 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0]; 10244 10245 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->default_kind = 10246 (TYP_DESC(type_idx) == Default_Typed); 10247 } 10248 10249 if (attr_idx && 10250 AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 10251 ATP_PGM_UNIT(attr_idx) == Pgm_Unknown) { /* BRIANJ - target const??? */ 10252 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pgm_unknown = 1; 10253 } 10254 10255 if (this_is_call && 10256 arg_info_list[info_idx].ed.array_elt) { 10257 10258 /* calculate size to end of array. maybe */ 10259 } 10260 else if (rank != 0) { 10261 10262 if (OPND_FLD(len_opnd) == CN_Tbl_Idx && 10263 OPND_IDX(len_opnd) != NULL_IDX && 10264 TYP_TYPE(type_idx) != Character) { 10265 10266 10267 /* BRIANJ - What if these are integer_8 on a 32 bit platform? */ 10268 10269 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = 10270 CN_CONST(OPND_IDX(len_opnd)); 10271 } 10272 else if (OPND_FLD(len_opnd) == CN_Tbl_Idx && 10273 OPND_IDX(len_opnd) != NULL_IDX && 10274 TYP_TYPE(type_idx) == Character && 10275 TYP_FLD(type_idx) == CN_Tbl_Idx) { 10276 10277 type_idx2 = (TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) > 10278 TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(type_idx)))) ? 10279 CN_TYPE_IDX(OPND_IDX(len_opnd)) : 10280 CN_TYPE_IDX(TYP_IDX(type_idx)); 10281 10282 ok = folder_driver((char *)&CN_CONST(OPND_IDX(len_opnd)), 10283 CN_TYPE_IDX(OPND_IDX(len_opnd)), 10284 (char *)&CN_CONST(TYP_IDX(type_idx)), 10285 CN_TYPE_IDX(TYP_IDX(type_idx)), 10286 folded_const, 10287 &type_idx2, 10288 stmt_start_line, 10289 stmt_start_col, 10290 2, 10291 Mult_Opr); 10292 10293 /* This could loose precision if type_idx2 is Integer_8. BRIANJ */ 10294 10295 # if defined(_TARGET32) 10296 if (TYP_LINEAR(type_idx2) == Integer_8) { 10297 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = 10298 folded_const[1]; 10299 } 10300 else { 10301 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = 10302 folded_const[0]; 10303 } 10304 # else 10305 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = folded_const[0]; 10306 # endif 10307 } 10308 else if (OPND_IDX(len_opnd) != NULL_IDX) { 10309 /* runtime code to set the size */ 10310 10311 NTR_IR_TBL(sub_idx); 10312 IR_OPR(sub_idx) = Subscript_Opr; 10313 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 10314 IR_LINE_NUM(sub_idx) = line; 10315 IR_COL_NUM(sub_idx) = col; 10316 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 10317 IR_IDX_L(sub_idx) = stack_tmp_idx; 10318 IR_LINE_NUM_L(sub_idx) = line; 10319 IR_COL_NUM_L(sub_idx) = col; 10320 10321 NTR_IR_LIST_TBL(list_idx); 10322 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 10323 IR_IDX_R(sub_idx) = list_idx; 10324 IR_LIST_CNT_R(sub_idx) = 1; 10325 IL_FLD(list_idx) = CN_Tbl_Idx; 10326 10327 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 10328 ARGCHCK_SIZE_IDX); 10329 IL_LINE_NUM(list_idx) = line; 10330 IL_COL_NUM(list_idx) = col; 10331 10332 NTR_IR_TBL(asg_idx); 10333 IR_OPR(asg_idx) = Asg_Opr; 10334 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 10335 IR_LINE_NUM(asg_idx) = line; 10336 IR_COL_NUM(asg_idx) = col; 10337 10338 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 10339 IR_IDX_L(asg_idx) = sub_idx; 10340 10341 if (TYP_TYPE(type_idx) == Character) { 10342 NTR_IR_TBL(mult_idx); 10343 IR_OPR(mult_idx) = Mult_Opr; 10344 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 10345 IR_LINE_NUM(mult_idx) = line; 10346 IR_COL_NUM(mult_idx) = col; 10347 10348 COPY_OPND(IR_OPND_L(mult_idx), len_opnd); 10349 IR_FLD_R(mult_idx) = TYP_FLD(type_idx); 10350 IR_IDX_R(mult_idx) = TYP_IDX(type_idx); 10351 IR_LINE_NUM_R(mult_idx) = line; 10352 IR_COL_NUM_R(mult_idx) = col; 10353 10354 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 10355 IR_IDX_R(asg_idx) = mult_idx; 10356 } 10357 else { 10358 COPY_OPND(IR_OPND_R(asg_idx), len_opnd); 10359 } 10360 10361 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 10362 10363 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 10364 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10365 } 10366 } 10367 else { 10368 C_TO_F_INT(num, 1, CG_INTEGER_DEFAULT_TYPE); 10369 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->size = num[0]; 10370 C_TO_F_INT(num, 0, CG_INTEGER_DEFAULT_TYPE); 10371 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->rank = num[0]; 10372 } 10373 10374 if (type_idx && 10375 TYP_TYPE(type_idx) == Character) { 10376 10377 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 10378 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->char_len = 10379 CN_CONST(TYP_IDX(type_idx)); 10380 } 10381 else { 10382 /* generate runtime code to insert the char length */ 10383 10384 NTR_IR_TBL(sub_idx); 10385 IR_OPR(sub_idx) = Subscript_Opr; 10386 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 10387 IR_LINE_NUM(sub_idx) = line; 10388 IR_COL_NUM(sub_idx) = col; 10389 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 10390 IR_IDX_L(sub_idx) = stack_tmp_idx; 10391 IR_LINE_NUM_L(sub_idx) = line; 10392 IR_COL_NUM_L(sub_idx) = col; 10393 10394 NTR_IR_LIST_TBL(list_idx); 10395 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 10396 IR_IDX_R(sub_idx) = list_idx; 10397 IR_LIST_CNT_R(sub_idx) = 1; 10398 IL_FLD(list_idx) = CN_Tbl_Idx; 10399 10400 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 10401 ARGCHCK_CHAR_LEN_IDX); 10402 IL_LINE_NUM(list_idx) = line; 10403 IL_COL_NUM(list_idx) = col; 10404 10405 NTR_IR_TBL(asg_idx); 10406 IR_OPR(asg_idx) = Asg_Opr; 10407 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 10408 IR_LINE_NUM(asg_idx) = line; 10409 IR_COL_NUM(asg_idx) = col; 10410 10411 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 10412 IR_IDX_L(asg_idx) = sub_idx; 10413 10414 IR_FLD_R(asg_idx) = TYP_FLD(type_idx); 10415 IR_IDX_R(asg_idx) = TYP_IDX(type_idx); 10416 IR_LINE_NUM_R(asg_idx) = line; 10417 IR_COL_NUM_R(asg_idx) = col; 10418 10419 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 10420 10421 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 10422 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10423 10424 } 10425 } 10426 else if (type_idx && 10427 TYP_TYPE(type_idx) == Structure) { 10428 /* generate derived type table, always static */ 10429 10430 NTR_IR_TBL(sub_idx); 10431 IR_OPR(sub_idx) = Subscript_Opr; 10432 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 10433 IR_LINE_NUM(sub_idx) = line; 10434 IR_COL_NUM(sub_idx) = col; 10435 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 10436 IR_IDX_L(sub_idx) = static_tmp_idx; 10437 IR_LINE_NUM_L(sub_idx) = line; 10438 IR_COL_NUM_L(sub_idx) = col; 10439 10440 NTR_IR_LIST_TBL(list_idx); 10441 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 10442 IR_IDX_R(sub_idx) = list_idx; 10443 IR_LIST_CNT_R(sub_idx) = 1; 10444 IL_FLD(list_idx) = CN_Tbl_Idx; 10445 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 10446 ARGCHCK_STRUCT_TBL_IDX); 10447 IL_LINE_NUM(list_idx) = line; 10448 IL_COL_NUM(list_idx) = col; 10449 10450 NTR_IR_TBL(asg_idx); 10451 IR_OPR(asg_idx) = Init_Reloc_Opr; 10452 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 10453 IR_LINE_NUM(asg_idx) = line; 10454 IR_COL_NUM(asg_idx) = col; 10455 10456 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 10457 IR_IDX_L(asg_idx) = sub_idx; 10458 10459 NTR_IR_TBL(loc_idx); 10460 IR_OPR(loc_idx) = Loc_Opr; 10461 IR_LINE_NUM(loc_idx) = line; 10462 IR_COL_NUM(loc_idx) = col; 10463 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 10464 10465 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 10466 i = create_struct_argchck_tbl(TYP_IDX(type_idx)); 10467 IR_IDX_L(loc_idx) = i; 10468 IR_LINE_NUM_L(loc_idx) = line; 10469 IR_COL_NUM_L(loc_idx) = col; 10470 10471 NTR_IR_LIST_TBL(list_idx); 10472 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 10473 IR_IDX_R(asg_idx) = list_idx; 10474 IR_LIST_CNT_R(asg_idx) = 2; 10475 IL_FLD(list_idx) = IR_Tbl_Idx; 10476 IL_IDX(list_idx) = loc_idx; 10477 10478 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 10479 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10480 list_idx = IL_NEXT_LIST_IDX(list_idx); 10481 10482 IL_FLD(list_idx) = CN_Tbl_Idx; 10483 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 10484 IL_LINE_NUM(list_idx) = line; 10485 IL_COL_NUM(list_idx) = col; 10486 10487 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 10488 10489 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 10490 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10491 } 10492 10493 if (this_is_call) { 10494 /* this is an actual arg */ 10495 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->defineable = 10496 arg_info_list[info_idx].ed.reference; 10497 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->array_element = 10498 arg_info_list[info_idx].ed.array_elt; 10499 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pointer = 10500 arg_info_list[info_idx].ed.pointer; 10501 10502 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->dope_vector = 10503 arg_info_list[info_idx].ed.dope_vector; 10504 } 10505 else { 10506 /* this is a dummy arg */ 10507 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->optional = 10508 AT_OPTIONAL(attr_idx); 10509 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 10510 (ATD_INTENT(attr_idx) == Intent_Out || 10511 ATD_INTENT(attr_idx) == Intent_Inout)) { 10512 10513 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->intent_out = TRUE; 10514 } 10515 10516 if (bd_idx) { 10517 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_shape = 10518 (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape); 10519 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_size_array = 10520 (BD_ARRAY_CLASS(bd_idx) == Assumed_Size); 10521 } 10522 10523 if (type_idx && 10524 TYP_TYPE(type_idx) == Character && 10525 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) { 10526 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->assumed_size_char = 10527 TRUE; 10528 } 10529 10530 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 10531 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->pointer = 10532 ATD_POINTER(attr_idx); 10533 10534 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->dope_vector = 10535 ATD_IM_A_DOPE(attr_idx); 10536 10537 ((arg_desc_node_type *)&(CN_CONST(const_idx)))->ignore_tkr = 10538 ATD_IGNORE_TKR(attr_idx); 10539 } 10540 } 10541 10542 TRACE (Func_Exit, "gen_arg_type_descriptor", NULL); 10543 10544 return((stack_tmp_idx ? stack_tmp_idx : static_tmp_idx)); 10545 10546 } /* gen_arg_type_descriptor */ 10547 10548 /******************************************************************************\ 10549 |* *| 10550 |* Description: *| 10551 |* <description> *| 10552 |* *| 10553 |* Input parameters: *| 10554 |* NONE *| 10555 |* *| 10556 |* Output parameters: *| 10557 |* NONE *| 10558 |* *| 10559 |* Returns: *| 10560 |* NOTHING *| 10561 |* *| 10562 \******************************************************************************/ 10563 10564 static long_type get_arg_type(int type_idx, 10565 boolean is_pgm_unit) 10566 10567 { 10568 long_type arg_type; 10569 10570 10571 TRACE (Func_Entry, "get_arg_type", NULL); 10572 10573 switch (TYP_LINEAR(type_idx)) { 10574 10575 case Typeless_4: 10576 case Typeless_8: 10577 case Short_Typeless_Const: 10578 case Long_Typeless: 10579 arg_type = (is_pgm_unit ? 10580 Typeless_Function_Arg : Typeless_Arg); 10581 break; 10582 10583 case Integer_1: 10584 case Integer_2: 10585 case Integer_4: 10586 arg_type = (is_pgm_unit ? 10587 Short_Integer_Function_Arg : Short_Integer_Arg); 10588 break; 10589 10590 case Integer_8: 10591 arg_type = (is_pgm_unit ? 10592 Long_Integer_Function_Arg : Long_Integer_Arg); 10593 break; 10594 10595 case Real_4: 10596 # ifdef _TARGET64 10597 case Real_8: 10598 # endif 10599 arg_type = (is_pgm_unit ? 10600 Real_Function_Arg : Real_Arg); 10601 break; 10602 10603 # ifdef _TARGET32 10604 case Real_8: 10605 # endif 10606 case Real_16: 10607 arg_type = (is_pgm_unit ? 10608 Double_Function_Arg : Double_Arg); 10609 break; 10610 10611 case Complex_4: 10612 case Complex_8: 10613 case Complex_16: 10614 arg_type = (is_pgm_unit ? 10615 Complex_Function_Arg : Complex_Arg); 10616 break; 10617 10618 case CRI_Ptr_8: 10619 arg_type = (is_pgm_unit ? 10620 Pointer_Function_Arg : Pointer_Arg); 10621 break; 10622 10623 case Logical_1: 10624 case Logical_2: 10625 case Logical_4: 10626 case Logical_8: 10627 arg_type = (is_pgm_unit ? 10628 Logical_Function_Arg : Logical_Arg); 10629 break; 10630 10631 case Character_1: 10632 case Character_2: 10633 case Character_4: 10634 case Short_Char_Const: 10635 arg_type = (is_pgm_unit ? 10636 Character_Function_Arg : Character_Arg); 10637 break; 10638 10639 case CRI_Ch_Ptr_8: 10640 arg_type = (is_pgm_unit ? 10641 Character_Pointer_Function_Arg : Character_Pointer_Arg); 10642 break; 10643 10644 case Structure_Type: 10645 arg_type = (is_pgm_unit ? 10646 Derived_Type_Function_Arg : Derived_Type_Arg); 10647 break; 10648 10649 case CRI_Parcel_Ptr_8: 10650 arg_type = (is_pgm_unit ? 10651 Pointer_Function_Arg : Pointer_Arg); 10652 break; 10653 10654 default : 10655 PRINTMSG(stmt_start_line, 626, Internal, 1, 10656 "valid type", 10657 "get_arg_type"); 10658 break; 10659 } 10660 10661 10662 TRACE (Func_Exit, "get_arg_type", NULL); 10663 10664 return(arg_type); 10665 10666 } /* get_arg_type */ 10667 10668 /******************************************************************************\ 10669 |* *| 10670 |* Description: *| 10671 |* create the table that describes a derived type for runtime argument *| 10672 |* checking. *| 10673 |* *| 10674 |* Input parameters: *| 10675 |* NONE *| 10676 |* *| 10677 |* Output parameters: *| 10678 |* NONE *| 10679 |* *| 10680 |* Returns: *| 10681 |* NOTHING *| 10682 |* *| 10683 \******************************************************************************/ 10684 10685 static int create_struct_argchck_tbl(int dt_idx) 10686 10687 { 10688 int asg_idx; 10689 int cn_idx; 10690 int i; 10691 int list_idx; 10692 int sub_idx; 10693 int tmp_idx; 10694 int total_word_cnt; 10695 int type_idx; 10696 10697 10698 TRACE (Func_Entry, "create_struct_argchck_tbl", NULL); 10699 10700 /* first we must calculate the size of the table */ 10701 10702 total_word_cnt = 2 + determine_struct_tbl_size(dt_idx); 10703 10704 /* get the temp */ 10705 10706 tmp_idx = gen_static_integer_array_tmp(total_word_cnt, 10707 stmt_start_line, 10708 stmt_start_col); 10709 10710 /* get the constant table entry */ 10711 10712 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 10713 TYP_TYPE(TYP_WORK_IDX) = Typeless; 10714 TYP_BIT_LEN(TYP_WORK_IDX) = total_word_cnt * TARGET_BITS_PER_WORD; 10715 type_idx = ntr_type_tbl(); 10716 10717 cn_idx = ntr_const_tbl(type_idx, FALSE, NULL); 10718 10719 /* set up the the data initialization */ 10720 10721 NTR_IR_TBL(sub_idx); 10722 IR_OPR(sub_idx) = Subscript_Opr; 10723 IR_TYPE_IDX(sub_idx) = CG_INTEGER_DEFAULT_TYPE; 10724 IR_LINE_NUM(sub_idx) = stmt_start_line; 10725 IR_COL_NUM(sub_idx) = stmt_start_col; 10726 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 10727 IR_IDX_L(sub_idx) = tmp_idx; 10728 IR_LINE_NUM_L(sub_idx) = stmt_start_line; 10729 IR_COL_NUM_L(sub_idx) = stmt_start_col; 10730 10731 NTR_IR_LIST_TBL(list_idx); 10732 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 10733 IR_IDX_R(sub_idx) = list_idx; 10734 IR_LIST_CNT_R(sub_idx) = 1; 10735 IL_FLD(list_idx) = CN_Tbl_Idx; 10736 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 10737 IL_LINE_NUM(list_idx) = stmt_start_line; 10738 IL_COL_NUM(list_idx) = stmt_start_col; 10739 10740 10741 NTR_IR_TBL(asg_idx); 10742 IR_OPR(asg_idx) = Init_Opr; 10743 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 10744 IR_LINE_NUM(asg_idx) = stmt_start_line; 10745 IR_COL_NUM(asg_idx) = stmt_start_col; 10746 10747 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 10748 IR_IDX_L(asg_idx) = sub_idx; 10749 10750 NTR_IR_LIST_TBL(list_idx); 10751 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 10752 IR_IDX_R(asg_idx) = list_idx; 10753 IR_LIST_CNT_R(asg_idx) = 3; 10754 10755 IL_FLD(list_idx) = CN_Tbl_Idx; 10756 IL_IDX(list_idx) = cn_idx; 10757 IL_LINE_NUM(list_idx) = stmt_start_line; 10758 IL_COL_NUM(list_idx) = stmt_start_col; 10759 10760 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 10761 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10762 list_idx = IL_NEXT_LIST_IDX(list_idx); 10763 10764 IL_FLD(list_idx) = CN_Tbl_Idx; 10765 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 10766 IL_LINE_NUM(list_idx) = stmt_start_line; 10767 IL_COL_NUM(list_idx) = stmt_start_col; 10768 10769 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 10770 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10771 list_idx = IL_NEXT_LIST_IDX(list_idx); 10772 10773 IL_FLD(list_idx) = CN_Tbl_Idx; 10774 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 10775 IL_LINE_NUM(list_idx) = stmt_start_line; 10776 IL_COL_NUM(list_idx) = stmt_start_col; 10777 10778 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 10779 FALSE, FALSE, TRUE); 10780 10781 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 10782 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10783 10784 /****************************\ 10785 |* now fill in the constant *| 10786 \****************************/ 10787 10788 i = 0; 10789 10790 /* BRIANJ - Do we need to convert total_word_cnt to target? */ 10791 10792 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = total_word_cnt; 10793 i++; 10794 10795 if (cmd_line_flags.dalign) { 10796 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = TRUE; 10797 } 10798 i++; 10799 10800 fill_in_struct_argchck_const(dt_idx, cn_idx, &i); 10801 10802 # ifdef _DEBUG 10803 if (i != total_word_cnt) { 10804 printf("i = %d, total_word_cnt = %d \n", i, total_word_cnt); 10805 PRINTMSG(stmt_start_line, 1117, Internal, stmt_start_col); 10806 } 10807 # endif 10808 10809 TRACE (Func_Exit, "create_struct_argchck_tbl", NULL); 10810 10811 return(tmp_idx); 10812 10813 } /* create_struct_argchck_tbl */ 10814 10815 /******************************************************************************\ 10816 |* *| 10817 |* Description: *| 10818 |* This routine determines the number of words needed for a particular *| 10819 |* derived type in an argchck derived type table. *| 10820 |* *| 10821 |* Input parameters: *| 10822 |* NONE *| 10823 |* *| 10824 |* Output parameters: *| 10825 |* NONE *| 10826 |* *| 10827 |* Returns: *| 10828 |* NOTHING *| 10829 |* *| 10830 \******************************************************************************/ 10831 10832 static int determine_struct_tbl_size(int dt_idx) 10833 10834 { 10835 int i; 10836 int size = 0; 10837 int sn_idx; 10838 10839 TRACE (Func_Entry, "determine_struct_tbl_size", NULL); 10840 10841 /* add size of derived type name */ 10842 10843 size += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(dt_idx)); 10844 10845 /* add word for number of cpnts */ 10846 10847 size += 1; 10848 10849 sn_idx = ATT_FIRST_CPNT_IDX(dt_idx); 10850 10851 for (i = 0; i < ATT_NUM_CPNTS(dt_idx); i++) { 10852 10853 /* add size of component name */ 10854 10855 size += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(SN_ATTR_IDX(sn_idx))); 10856 10857 /* add a word for arg_type, kind type, rank, and pointer flags */ 10858 10859 size += 1; 10860 10861 /* add two words for each dim */ 10862 10863 if (ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx)) != NULL_IDX && 10864 BD_ARRAY_CLASS(ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx))) == 10865 Explicit_Shape) { 10866 10867 size += 2 * BD_RANK(ATD_ARRAY_IDX(SN_ATTR_IDX(sn_idx))); 10868 } 10869 10870 if (TYP_TYPE(ATD_TYPE_IDX(SN_ATTR_IDX(sn_idx))) == Character) { 10871 /* add one word for character length */ 10872 size += 1; 10873 } 10874 else if (TYP_TYPE(ATD_TYPE_IDX(SN_ATTR_IDX(sn_idx))) == Structure && 10875 !ATD_POINTER(SN_ATTR_IDX(sn_idx))) { 10876 size += determine_struct_tbl_size(TYP_IDX(ATD_TYPE_IDX( 10877 SN_ATTR_IDX(sn_idx)))); 10878 } 10879 10880 sn_idx = SN_SIBLING_LINK(sn_idx); 10881 } 10882 10883 TRACE (Func_Exit, "determine_struct_tbl_size", NULL); 10884 10885 return(size); 10886 10887 } /* determine_struct_tbl_size */ 10888 10889 /******************************************************************************\ 10890 |* *| 10891 |* Description: *| 10892 |* <description> *| 10893 |* *| 10894 |* Input parameters: *| 10895 |* NONE *| 10896 |* *| 10897 |* Output parameters: *| 10898 |* NONE *| 10899 |* *| 10900 |* Returns: *| 10901 |* NOTHING *| 10902 |* *| 10903 \******************************************************************************/ 10904 10905 static void fill_in_struct_argchck_const(int dt_idx, 10906 int cn_idx, 10907 int *idx) 10908 10909 { 10910 int attr_idx; 10911 char *char_ptr; 10912 int i; 10913 int k; 10914 int l; 10915 int sn_idx; 10916 long_type the_constant[MAX_WORDS_FOR_INTEGER]; 10917 10918 10919 TRACE (Func_Entry, "fill_in_struct_argchck_const", NULL); 10920 10921 i = *idx; 10922 10923 /* fill in name length and name */ 10924 10925 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = /* BRIANJ */ 10926 ((long_type)(AT_NAME_LEN(dt_idx)) << (TARGET_BITS_PER_WORD - 8)); 10927 10928 char_ptr = (char *)&(CP_CONSTANT(CN_POOL_IDX(cn_idx) + i)); 10929 10930 char_ptr++; 10931 10932 strncpy(char_ptr, AT_OBJ_NAME_PTR(dt_idx), AT_NAME_LEN(dt_idx)); 10933 10934 i += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(dt_idx)); 10935 10936 C_TO_F_INT(the_constant, ATT_NUM_CPNTS(dt_idx), CG_INTEGER_DEFAULT_TYPE); 10937 10938 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = the_constant[0]; 10939 10940 i++; 10941 10942 sn_idx = ATT_FIRST_CPNT_IDX(dt_idx); 10943 10944 for (k = 0; k < ATT_NUM_CPNTS(dt_idx); k++) { 10945 attr_idx = SN_ATTR_IDX(sn_idx); 10946 10947 /* BRIANJ */ 10948 10949 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = 10950 ((long_type)(AT_NAME_LEN(attr_idx)) << (TARGET_BITS_PER_WORD - 8)); 10951 10952 char_ptr = (char *)&(CP_CONSTANT(CN_POOL_IDX(cn_idx) + i)); 10953 char_ptr++; 10954 strncpy(char_ptr, AT_OBJ_NAME_PTR(attr_idx), AT_NAME_LEN(attr_idx)); 10955 i += TARGET_BYTES_TO_WORDS(1 + AT_NAME_LEN(attr_idx)); 10956 10957 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |= 10958 (get_arg_type(ATD_TYPE_IDX(attr_idx), FALSE) << 24); 10959 10960 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |= 10961 (linear_to_kind_type[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))] << 16); 10962 10963 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 10964 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |= 10965 (BD_RANK(ATD_ARRAY_IDX(attr_idx)) << 8); 10966 } 10967 10968 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) |= ATD_POINTER(attr_idx); 10969 10970 i++; 10971 10972 /* BRIANJ */ 10973 10974 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX && 10975 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Explicit_Shape) { 10976 10977 for (l = 1; l <= BD_RANK(ATD_ARRAY_IDX(attr_idx)); l++) { 10978 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = 10979 CN_CONST(BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), l)); 10980 i++; 10981 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = 10982 CN_CONST(BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), l)); 10983 i++; 10984 } 10985 } 10986 10987 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 10988 /* fill in character length */ 10989 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i) = 10990 CN_CONST(TYP_IDX(ATD_TYPE_IDX(attr_idx))); 10991 i++; 10992 } 10993 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 10994 !ATD_POINTER(attr_idx)) { 10995 fill_in_struct_argchck_const(TYP_IDX(ATD_TYPE_IDX(attr_idx)), 10996 cn_idx, &i); 10997 } 10998 10999 sn_idx = SN_SIBLING_LINK(sn_idx); 11000 } 11001 11002 *idx = i; 11003 11004 TRACE (Func_Exit, "fill_in_struct_argchck_const", NULL); 11005 11006 return; 11007 11008 } /* fill_in_struct_argchck_const */ 11009 11010 /******************************************************************************\ 11011 |* *| 11012 |* Description: *| 11013 |* <description> *| 11014 |* *| 11015 |* Input parameters: *| 11016 |* NONE *| 11017 |* *| 11018 |* Output parameters: *| 11019 |* NONE *| 11020 |* *| 11021 |* Returns: *| 11022 |* NOTHING *| 11023 |* *| 11024 \******************************************************************************/ 11025 11026 void gen_dbg_write_stmt(opnd_type *opnd, 11027 sh_position_type position) 11028 11029 { 11030 int i; 11031 int ir_idx; 11032 int list_idx; 11033 11034 11035 TRACE (Func_Entry, "gen_dbg_write_stmt", NULL); 11036 11037 NTR_IR_TBL(ir_idx); 11038 IR_OPR(ir_idx) = Write_Formatted_Opr; 11039 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 11040 IR_LINE_NUM(ir_idx) = stmt_start_line; 11041 IR_COL_NUM(ir_idx) = stmt_start_col; 11042 11043 11044 NTR_IR_LIST_TBL(list_idx); 11045 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 11046 IR_LIST_CNT_L(ir_idx) = 10; 11047 IR_IDX_L(ir_idx) = list_idx; 11048 11049 IL_FLD(list_idx) = CN_Tbl_Idx; 11050 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 11051 IL_LINE_NUM(list_idx) = stmt_start_line; 11052 IL_COL_NUM(list_idx) = stmt_start_col; 11053 11054 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 11055 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 11056 list_idx = IL_NEXT_LIST_IDX(list_idx); 11057 11058 IL_FLD(list_idx) = CN_Tbl_Idx; 11059 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 11060 IL_LINE_NUM(list_idx) = stmt_start_line; 11061 IL_COL_NUM(list_idx) = stmt_start_col; 11062 11063 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 11064 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 11065 list_idx = IL_NEXT_LIST_IDX(list_idx); 11066 11067 IL_FLD(list_idx) = CN_Tbl_Idx; 11068 IL_IDX(list_idx) = CN_INTEGER_THREE_IDX; 11069 IL_LINE_NUM(list_idx) = stmt_start_line; 11070 IL_COL_NUM(list_idx) = stmt_start_col; 11071 11072 for (i = 0; i < 7; i++) { 11073 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 11074 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 11075 list_idx = IL_NEXT_LIST_IDX(list_idx); 11076 IL_LINE_NUM(list_idx) = stmt_start_line; 11077 IL_COL_NUM(list_idx) = stmt_start_col; 11078 } 11079 11080 if (OPND_FLD((*opnd)) == IL_Tbl_Idx) { 11081 COPY_OPND(IR_OPND_R(ir_idx), (*opnd)); 11082 } 11083 else { 11084 NTR_IR_LIST_TBL(list_idx); 11085 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 11086 IR_LIST_CNT_R(ir_idx) = 1; 11087 IR_IDX_R(ir_idx) = list_idx; 11088 11089 COPY_OPND(IL_OPND(list_idx), (*opnd)); 11090 } 11091 11092 gen_sh(position, Assignment_Stmt, stmt_start_line, stmt_start_col, 11093 FALSE, FALSE, TRUE); 11094 11095 if (position == After) { 11096 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 11097 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 11098 } 11099 else { 11100 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 11101 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 11102 } 11103 11104 TRACE (Func_Exit, "gen_dbg_write_stmt", NULL); 11105 11106 return; 11107 11108 } /* gen_dbg_write_stmt */ 11109 11110 /******************************************************************************\ 11111 |* *| 11112 |* Description: *| 11113 |* <description> *| 11114 |* *| 11115 |* Input parameters: *| 11116 |* NONE *| 11117 |* *| 11118 |* Output parameters: *| 11119 |* NONE *| 11120 |* *| 11121 |* Returns: *| 11122 |* NOTHING *| 11123 |* *| 11124 \******************************************************************************/ 11125 11126 static void make_base_assumed_size(opnd_type *old_opnd, 11127 opnd_type *new_opnd) 11128 11129 { 11130 int attr_idx; 11131 int bd_idx; 11132 int col; 11133 int i; 11134 int line; 11135 int list_idx; 11136 int sub_idx; 11137 11138 TRACE (Func_Entry, "make_base_assumed_size", NULL); 11139 11140 find_opnd_line_and_column(old_opnd, &line, &col); 11141 11142 # ifdef _DEBUG 11143 if (OPND_FLD((*old_opnd)) != AT_Tbl_Idx) { 11144 PRINTMSG(line, 626, Internal, col, 11145 "AT_Tbl_Idx", "make_base_assumed_size"); 11146 } 11147 # endif 11148 11149 attr_idx = OPND_IDX((*old_opnd)); 11150 bd_idx = ATD_ARRAY_IDX(attr_idx); 11151 11152 # ifdef _DEBUG 11153 if (bd_idx == NULL_IDX || 11154 BD_ARRAY_CLASS(bd_idx) != Assumed_Size) { 11155 11156 PRINTMSG(line, 626, Internal, col, 11157 "Assumed Size array", "make_base_assumed_size"); 11158 } 11159 # endif 11160 11161 NTR_IR_TBL(sub_idx); 11162 IR_OPR(sub_idx) = Subscript_Opr; 11163 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx); 11164 IR_LINE_NUM(sub_idx) = line; 11165 IR_COL_NUM(sub_idx) = col; 11166 IR_IDX_L(sub_idx) = attr_idx; 11167 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 11168 IR_LINE_NUM_L(sub_idx) = line; 11169 IR_COL_NUM_L(sub_idx) = col; 11170 11171 NTR_IR_LIST_TBL(list_idx); 11172 IR_IDX_R(sub_idx) = list_idx; 11173 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 11174 IR_LIST_CNT_R(sub_idx) = BD_RANK(bd_idx); 11175 11176 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1); 11177 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1); 11178 IL_LINE_NUM(list_idx) = line; 11179 IL_COL_NUM(list_idx) = col; 11180 11181 for (i = 2; i <= BD_RANK(bd_idx); i++) { 11182 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 11183 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 11184 list_idx = IL_NEXT_LIST_IDX(list_idx); 11185 11186 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 11187 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 11188 IL_LINE_NUM(list_idx) = line; 11189 IL_COL_NUM(list_idx) = col; 11190 } 11191 11192 OPND_FLD((*new_opnd)) = IR_Tbl_Idx; 11193 OPND_IDX((*new_opnd)) = sub_idx; 11194 11195 TRACE (Func_Exit, "make_base_assumed_size", NULL); 11196 11197 return; 11198 11199 } /* make_base_assumed_size */ 11200 11201 /******************************************************************************\ 11202 |* *| 11203 |* Description: *| 11204 |* <description> *| 11205 |* *| 11206 |* Input parameters: *| 11207 |* NONE *| 11208 |* *| 11209 |* Output parameters: *| 11210 |* NONE *| 11211 |* *| 11212 |* Returns: *| 11213 |* NOTHING *| 11214 |* *| 11215 \******************************************************************************/ 11216 11217 static void check_call_for_global_def(int list_idx, 11218 int spec_idx, 11219 int num_dargs) 11220 11221 { 11222 uint act_file_line; 11223 int ga_idx; 11224 int gl_idx; 11225 char line_name[256]; 11226 int name_idx; 11227 int new_ga_idx; 11228 11229 11230 TRACE (Func_Entry, "check_call_for_global_def", NULL); 11231 11232 if (ATP_PROC(spec_idx) == Dummy_Proc || ATP_NAME_IN_STONE(spec_idx)) { 11233 11234 /* Exit - this is a dummy procedure which makes it a local name or */ 11235 /* this name is specified in the !DIR$ NAME directive which */ 11236 /* also makes it a local name for the external name. */ 11237 11238 return; 11239 } 11240 11241 ga_idx = NULL_IDX; 11242 11243 /* ATP_EXPL_ITRFC should be FALSE to be here. */ 11244 11245 /* There is no explicit interface for this program unit. Check */ 11246 /* the global name table to see if an explicit interface was */ 11247 /* found in another program unit. If so, do semantics checks, */ 11248 /* if not, add this to the global name table as a reference in */ 11249 /* the hope that it can be checked later. */ 11250 11251 if (srch_global_name_tbl(AT_OBJ_NAME_PTR(spec_idx), 11252 AT_NAME_LEN(spec_idx), 11253 &name_idx)) { 11254 11255 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 11256 ga_idx = GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)); 11257 } 11258 else { 11259 11260 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Pgm_Unit) { 11261 ga_idx = GN_ATTR_IDX(name_idx); 11262 } 11263 11264 # if defined(_DEBUG) 11265 #if 0 11266 /* ga_idx should always be valid in this else clause. */ 11267 11268 if (ga_idx == NULL_IDX) { 11269 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 11270 "valid attr_idx", 11271 "check_call_for_global_def"); 11272 } 11273 #endif /*Sept*/ 11274 # endif 11275 } 11276 11277 if (ga_idx == NULL_IDX) { 11278 ga_idx = ntr_global_attr_tbl(spec_idx, name_idx); 11279 11280 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 11281 GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)) = ga_idx; 11282 } 11283 else { 11284 11285 /* Only get here if non-debug and assumption */ 11286 /* fails. Fill in GN_ATTR_IDX for recovery. */ 11287 11288 GN_ATTR_IDX(name_idx) = ga_idx; 11289 } 11290 11291 ntr_ref_in_global_tbl(list_idx, 11292 spec_idx, 11293 num_dargs, 11294 &ga_idx, 11295 name_idx); 11296 } 11297 else if (GAP_NEEDS_EXPL_ITRFC(ga_idx)) { 11298 line_name[0] = '\0'; 11299 GLOBAL_LINE_TO_FILE_LINE(GA_DEF_LINE(ga_idx), gl_idx, act_file_line); 11300 11301 sprintf(line_name, "%d (%s)", act_file_line, GL_FILE_NAME_PTR(gl_idx)); 11302 PRINTMSG(stmt_start_line, 1277, Error, stmt_start_col, 11303 AT_OBJ_NAME_PTR(spec_idx), 11304 "defined", 11305 line_name); 11306 } 11307 else if (!GA_DEFINED(ga_idx)) { 11308 11309 /* The program unit being called has not been compiled yet, */ 11310 /* and no interface block has been found. Call global_name_ */ 11311 /* semantics to do a few ref to ref checks, and then add the */ 11312 /* reference to the list in case a definition is found. */ 11313 11314 /* In this case, ntr_ref just hangs the new ref off the older one. */ 11315 11316 /*Oct fzhao global_name_semantics(ga_idx, NULL_IDX, list_idx, spec_idx, NULL_IDX);*/ 11317 11318 new_ga_idx = ntr_global_attr_tbl(spec_idx, name_idx); 11319 GAP_NEXT_PGM_UNIT_IDX(new_ga_idx) = ga_idx; 11320 11321 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 11322 GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)) = new_ga_idx; 11323 } 11324 else { 11325 GN_ATTR_IDX(name_idx) = new_ga_idx; 11326 } 11327 ga_idx = new_ga_idx; 11328 11329 ntr_ref_in_global_tbl(list_idx, 11330 spec_idx, 11331 num_dargs, 11332 &ga_idx, 11333 name_idx); 11334 } 11335 else { /* True DEF to REF call */ 11336 /* Oct fzhao global_name_semantics(ga_idx, NULL_IDX, list_idx, spec_idx, NULL_IDX);*/ 11337 ; 11338 11339 } 11340 } 11341 else { 11342 ga_idx = NULL_IDX; 11343 ntr_ref_in_global_tbl(list_idx, 11344 spec_idx, 11345 num_dargs, 11346 &ga_idx, 11347 name_idx); 11348 } 11349 11350 11351 TRACE (Func_Exit, "check_call_for_global_def", NULL); 11352 11353 return; 11354 11355 } /* check_call_for_global_def */ 11356 11357 /******************************************************************************\ 11358 |* *| 11359 |* Description: *| 11360 |* Enters a procedure reference into the global attr table. *| 11361 |* This makes use of the utility routines ntr_global_name_table *| 11362 |* and fill_in_global_attr_ntry. The actual arguments must be entered *| 11363 |* differently than the dargs are, so it is done in this routine. *| 11364 |* *| 11365 |* Input parameters: *| 11366 |* list_idx -> IL index to list of actual arguments. *| 11367 |* spec_idx -> Attr index to name of procedure being called. *| 11368 |* num_dargs -> The number of dummy arguments. *| 11369 |* ga_idx -> The global attr to be filled in. If NULL, *| 11370 |* ntr_global_name_tbl is called to create a new entry. *| 11371 |* name_idx -> Valid name index in the global name table. *| 11372 |* If ga_idx is NULL_IDX, this should be the value returned *| 11373 |* from the last call to srch_global_name_tbl. *| 11374 |* *| 11375 |* Output parameters: *| 11376 |* ga_idx -> The global attr updated or created by this call. *| 11377 |* *| 11378 |* Returns: *| 11379 |* NOTHING *| 11380 |* *| 11381 \******************************************************************************/ 11382 11383 static void ntr_ref_in_global_tbl(int list_idx, 11384 int spec_idx, 11385 int num_dargs, 11386 int *ga_idx, 11387 int name_idx) 11388 11389 { 11390 static int arg_name_idx = NULL_IDX; 11391 11392 int arg_idx; 11393 id_str_type darg_name; 11394 int i; 11395 int il_idx; 11396 int info_idx; 11397 int kwd_idx; 11398 long_type *name_id; 11399 int next_il_idx; 11400 int rslt_idx; 11401 int str_idx; 11402 int type_idx; 11403 int word_len; 11404 11405 11406 11407 TRACE (Func_Entry, "ntr_ref_in_global_tbl", NULL); 11408 11409 if (*ga_idx == NULL_IDX) { 11410 11411 /* If *ga_idx is NULL we do not have an attr. Create one. */ 11412 /* Once we have an attr. Then it needs to be filled in. */ 11413 /* If *ga_idx is not NULL, the caller must have created the */ 11414 /* attr and linked it to its name. */ 11415 11416 ntr_global_name_tbl(spec_idx, NULL_IDX, name_idx); 11417 *ga_idx = GN_ATTR_IDX(name_idx); 11418 } 11419 11420 fill_in_global_attr_ntry(*ga_idx, spec_idx, NULL_IDX); 11421 11422 GA_REFERENCED(*ga_idx) = TRUE; 11423 11424 if (num_dargs == 0) { 11425 goto DONE; 11426 } 11427 11428 /* Add actual arguments to reference. */ 11429 11430 GAP_FIRST_IDX(*ga_idx) = global_attr_tbl_idx + 1; 11431 GAP_NUM_DARGS(*ga_idx) = num_dargs; 11432 11433 /* Reserve space for the dummy arguments so they are in */ 11434 /* consecutive order. Then return and fill them in. */ 11435 11436 next_il_idx = list_idx; 11437 rslt_idx = ATP_RSLT_IDX(spec_idx); 11438 11439 if (rslt_idx != NULL_IDX && FUNCTION_MUST_BE_SUBROUTINE(rslt_idx) && /* March */ 11440 FALSE) { 11441 next_il_idx = IL_NEXT_LIST_IDX(next_il_idx); 11442 } 11443 11444 for (i = 0; i < num_dargs; i++ ) { 11445 il_idx = next_il_idx; 11446 info_idx = IL_ARG_DESC_IDX(il_idx); 11447 # ifdef _DEBUG 11448 if (info_idx == NULL_IDX) { 11449 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 11450 "valid info_idx", "ntr_ref_in_global_tbl"); 11451 } 11452 # endif 11453 11454 next_il_idx = IL_NEXT_LIST_IDX(il_idx); 11455 11456 TBL_REALLOC_CK(global_attr_tbl, 1); 11457 CLEAR_TBL_NTRY(global_attr_tbl, global_attr_tbl_idx); 11458 11459 arg_idx = global_attr_tbl_idx; 11460 GA_DEF_LINE(arg_idx) = AT_DEF_LINE(spec_idx); 11461 GA_DEF_COLUMN(arg_idx) = AT_DEF_COLUMN(spec_idx); 11462 11463 if (info_idx != NULL_IDX && arg_info_list[info_idx].kwd != NULL_IDX) { 11464 11465 /* Have a keyword. Save. Right now it is a CN_Tbl_Idx */ 11466 11467 kwd_idx = arg_info_list[info_idx].kwd; 11468 GA_NAME_IDX(arg_idx) = str_pool_idx + 1; 11469 GA_NAME_LEN(arg_idx) = (uint) CN_INT_TO_C(TYP_IDX( 11470 CN_TYPE_IDX(kwd_idx))); 11471 name_id = &(CN_CONST(kwd_idx)); 11472 word_len = WORD_LEN(GN_NAME_LEN(arg_idx)) + EXTRA_WORD; 11473 11474 TBL_REALLOC_CK(str_pool, word_len); 11475 11476 for (str_idx = 0; str_idx < word_len; str_idx++) { 11477 str_pool[GA_NAME_IDX(arg_idx)+str_idx].name_long = name_id[str_idx]; 11478 } 11479 } 11480 else { /* No keyword, so use _darg as a placeholder name. */ 11481 11482 if (arg_name_idx == NULL_IDX) { 11483 CREATE_ID(darg_name, "_darg", 5); 11484 arg_name_idx = str_pool_idx + 1; 11485 name_id = (long_type *) &(darg_name.words[0]); 11486 word_len = WORD_LEN(5) + EXTRA_WORD; 11487 11488 TBL_REALLOC_CK(str_pool, word_len); 11489 11490 for (str_idx = 0; str_idx < word_len; str_idx++) { 11491 str_pool[arg_name_idx + str_idx].name_long = name_id[str_idx]; 11492 } 11493 } 11494 GA_NAME_IDX(arg_idx) = arg_name_idx; 11495 GA_NAME_LEN(arg_idx) = 5; 11496 } 11497 GA_ORIG_NAME_IDX(arg_idx) = GA_NAME_IDX(arg_idx); 11498 GA_ORIG_NAME_LEN(arg_idx) = GA_NAME_LEN(arg_idx); 11499 } 11500 11501 next_il_idx = list_idx; 11502 11503 if (rslt_idx != NULL_IDX && FUNCTION_MUST_BE_SUBROUTINE(rslt_idx)&&FALSE) { 11504 /* March */ 11505 next_il_idx = IL_NEXT_LIST_IDX(next_il_idx); 11506 } 11507 11508 arg_idx = GAP_FIRST_IDX(*ga_idx); 11509 11510 arg_idx--; /* Preset so we can add one at beginning of loop. */ 11511 11512 while (next_il_idx != NULL_IDX) { 11513 il_idx = next_il_idx; 11514 info_idx = IL_ARG_DESC_IDX(il_idx); 11515 next_il_idx = IL_NEXT_LIST_IDX(il_idx); 11516 11517 arg_idx++; 11518 11519 if (arg_info_list[info_idx].pgm_unit) { /* Actual is a procedure. */ 11520 11521 /* Enhance note - Should we look for this name in the global table? */ 11522 11523 GA_OBJ_CLASS(arg_idx) = Pgm_Unit; 11524 11525 /* Should we pick up info from IL_IDX(il_idx) */ 11526 } 11527 else { /* KAY */ 11528 11529 /* Play with this in the debugger. What if this is an expression? */ 11530 /* What if it is a parameter? What about intent checking? */ 11531 11532 if (IL_FLD(il_idx) == CN_Tbl_Idx) { /* Constant actual arg */ 11533 GA_OBJ_CLASS(arg_idx) = Data_Obj; 11534 GAD_CLASS(arg_idx) = Constant; 11535 /* 28Dec00[sos]: Wrong variable being referenced! (PV 810455) */ 11536 /* was: GAD_HOLLERITH(arg_idx) = CN_HOLLERITH_TYPE(IL_IDX(list_idx)); */ 11537 GAD_HOLLERITH(arg_idx) = CN_HOLLERITH_TYPE(IL_IDX(il_idx)); 11538 } 11539 else if (IL_FLD(il_idx) == AT_Tbl_Idx) { 11540 GA_OBJ_CLASS(arg_idx) = AT_OBJ_CLASS(IL_IDX(il_idx)); 11541 11542 if (AT_OBJ_CLASS(IL_IDX(il_idx)) == Data_Obj) { 11543 GAD_CLASS(arg_idx) = ATD_CLASS(IL_IDX(il_idx)); 11544 } 11545 } 11546 else { /* Will this happen */ 11547 GA_OBJ_CLASS(arg_idx) = Data_Obj; 11548 GAD_CLASS(arg_idx) = Dummy_Argument; 11549 } 11550 11551 if (GA_OBJ_CLASS(arg_idx) == Data_Obj) { 11552 GAD_RANK(arg_idx) = arg_info_list[info_idx].ed.rank; 11553 GAD_ARRAY_ELEMENT_REF(arg_idx)=arg_info_list[info_idx].ed.array_elt; 11554 11555 /* We do not need to carry anymore array info for a reference. */ 11556 11557 if (arg_info_list[info_idx].ed.type_idx != NULL_IDX) { 11558 11559 /* Enter the argument's type. */ 11560 11561 type_idx = 11562 ntr_global_type_tbl(arg_info_list[info_idx].ed.type_idx); 11563 GAD_TYPE_IDX(arg_idx) = type_idx; 11564 } 11565 else { /* Create a type from the info in the arg_info_list */ 11566 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 11567 TYP_TYPE(TYP_WORK_IDX) =arg_info_list[info_idx].ed.type; 11568 TYP_LINEAR(TYP_WORK_IDX) =arg_info_list[info_idx].ed.linear_type; 11569 11570 if (TYP_TYPE(TYP_WORK_IDX) == Character) { 11571 TYP_FLD(TYP_WORK_IDX) = OPND_FLD( 11572 arg_info_list[info_idx].ed.char_len); 11573 TYP_IDX(TYP_WORK_IDX) = OPND_IDX( 11574 arg_info_list[info_idx].ed.char_len); 11575 } 11576 } 11577 } 11578 } 11579 } /* End actual argument while */ 11580 11581 DONE: 11582 11583 TRACE (Func_Exit, "ntr_ref_in_global_tbl", NULL); 11584 11585 return; 11586 11587 } /* ntr_ref_in_global_tbl */ 11588 11589 /******************************************************************************\ 11590 |* *| 11591 |* Description: *| 11592 |* <description> *| 11593 |* *| 11594 |* Input parameters: *| 11595 |* NONE *| 11596 |* *| 11597 |* Output parameters: *| 11598 |* NONE *| 11599 |* *| 11600 |* Returns: *| 11601 |* NOTHING *| 11602 |* *| 11603 \******************************************************************************/ 11604 11605 static boolean check_elemental_conformance(int start_il_idx, 11606 expr_arg_type *res_exp_desc) 11607 11608 { 11609 int array_info_idx = NULL_IDX; 11610 int col; 11611 expr_arg_type exp_desc; 11612 int i; 11613 int info_idx; 11614 int line; 11615 int list_idx; 11616 boolean ok = TRUE; 11617 11618 TRACE (Func_Entry, "check_elemental_conformance", NULL); 11619 11620 list_idx = start_il_idx; 11621 11622 while (list_idx && ok) { 11623 info_idx = IL_ARG_DESC_IDX(list_idx); 11624 11625 # ifdef _DEBUG 11626 if (info_idx == NULL_IDX) { 11627 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 11628 "valid info_idx", "check_elemental_conformance"); 11629 } 11630 # endif 11631 11632 exp_desc = arg_info_list[info_idx].ed; 11633 11634 if (exp_desc.rank > 0) { 11635 if (array_info_idx == NULL_IDX) { 11636 array_info_idx = info_idx; 11637 res_exp_desc->rank = exp_desc.rank; 11638 COPY_SHAPE(res_exp_desc->shape, exp_desc.shape, exp_desc.rank); 11639 } 11640 else { 11641 if (exp_desc.rank != res_exp_desc->rank) { 11642 /* error, rank does not conform */ 11643 find_opnd_line_and_column(&IL_OPND(list_idx), 11644 &line, 11645 &col); 11646 PRINTMSG(line, 1311, Error, col); 11647 ok = FALSE; 11648 } 11649 else { 11650 for (i = 0; i < exp_desc.rank; i++) { 11651 11652 if (OPND_FLD(res_exp_desc->shape[i]) == CN_Tbl_Idx && 11653 OPND_FLD(exp_desc.shape[i]) == CN_Tbl_Idx) { 11654 11655 if (fold_relationals(OPND_IDX(res_exp_desc->shape[i]), 11656 OPND_IDX(exp_desc.shape[i]), 11657 Ne_Opr)) { 11658 11659 find_opnd_line_and_column(&IL_OPND(list_idx), 11660 &line, 11661 &col); 11662 PRINTMSG(line, 1311, Error, col); 11663 ok = FALSE; 11664 break; 11665 } 11666 } 11667 else if (SHAPE_FOLDABLE(exp_desc.shape[i])) { 11668 COPY_OPND(res_exp_desc->shape[i], exp_desc.shape[i]); 11669 } 11670 } 11671 } 11672 } 11673 } 11674 11675 list_idx = IL_NEXT_LIST_IDX(list_idx); 11676 } 11677 11678 TRACE (Func_Exit, "check_elemental_conformance", NULL); 11679 11680 return(ok); 11681 11682 } /* check_elemental_conformance */ 11683 11684 /******************************************************************************\ 11685 |* *| 11686 |* Description: *| 11687 |* <description> *| 11688 |* *| 11689 |* Input parameters: *| 11690 |* NONE *| 11691 |* *| 11692 |* Output parameters: *| 11693 |* NONE *| 11694 |* *| 11695 |* Returns: *| 11696 |* NOTHING *| 11697 |* *| 11698 \******************************************************************************/ 11699 11700 # if defined(GENERATE_WHIRL) 11701 static void set_inline_state(int ir_idx, 11702 int attr_idx) 11703 11704 { 11705 int ga_idx = NULL_IDX; 11706 int name_idx; 11707 11708 TRACE (Func_Entry, "set_inline_state", NULL); 11709 11710 if (srch_global_name_tbl(AT_OBJ_NAME_PTR(attr_idx), 11711 AT_NAME_LEN(attr_idx), 11712 &name_idx)) { 11713 11714 ga_idx = GN_ATTR_IDX(name_idx); 11715 } 11716 11717 if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit || 11718 IR_INLINE_STATE(ir_idx) != Not_Specified_Sgi) { 11719 /* intentionally blank */ 11720 } 11721 else if (ATP_SGI_LOCAL_INLINE(attr_idx)) { 11722 IR_INLINE_STATE(ir_idx) = Inline_Sgi; 11723 } 11724 else if (ATP_SGI_LOCAL_NOINLINE(attr_idx)) { 11725 IR_INLINE_STATE(ir_idx) = Noinline_Sgi; 11726 } 11727 else if (cdir_switches.inline_here_sgi) { 11728 IR_INLINE_STATE(ir_idx) = Inline_Sgi; 11729 } 11730 else if (cdir_switches.noinline_here_sgi) { 11731 IR_INLINE_STATE(ir_idx) = Noinline_Sgi; 11732 } 11733 else if (ATP_SGI_ROUTINE_INLINE(attr_idx)) { 11734 IR_INLINE_STATE(ir_idx) = Inline_Sgi; 11735 } 11736 else if (ATP_SGI_ROUTINE_NOINLINE(attr_idx)) { 11737 IR_INLINE_STATE(ir_idx) = Noinline_Sgi; 11738 } 11739 else if (SCP_INLINE_SGI(curr_scp_idx)) { 11740 IR_INLINE_STATE(ir_idx) = Inline_Sgi; 11741 } 11742 else if (SCP_NOINLINE_SGI(curr_scp_idx)) { 11743 IR_INLINE_STATE(ir_idx) = Noinline_Sgi; 11744 } 11745 else if (ATP_SGI_GLOBAL_INLINE(attr_idx)) { 11746 IR_INLINE_STATE(ir_idx) = Inline_Sgi; 11747 } 11748 else if (ATP_SGI_GLOBAL_NOINLINE(attr_idx)) { 11749 IR_INLINE_STATE(ir_idx) = Noinline_Sgi; 11750 } 11751 else if (ga_idx != NULL_IDX && 11752 GA_OBJ_CLASS(ga_idx) == Pgm_Unit && 11753 GAP_INLINE_STATE(ga_idx) == Inline_Sgi) { 11754 IR_INLINE_STATE(ir_idx) = Inline_Sgi; 11755 } 11756 else if (ga_idx != NULL_IDX && 11757 GA_OBJ_CLASS(ga_idx) == Pgm_Unit && 11758 GAP_INLINE_STATE(ga_idx) == Noinline_Sgi) { 11759 IR_INLINE_STATE(ir_idx) = Noinline_Sgi; 11760 } 11761 else if (inline_global_sgi) { 11762 IR_INLINE_STATE(ir_idx) = Inline_Sgi; 11763 } 11764 else if (noinline_global_sgi) { 11765 IR_INLINE_STATE(ir_idx) = Noinline_Sgi; 11766 } 11767 11768 11769 TRACE (Func_Exit, "set_inline_state", NULL); 11770 11771 return; 11772 11773 } /* set_inline_state */ 11774 # endif 11775 11776 /******************************************************************************\ 11777 |* *| 11778 |* Description: *| 11779 |* <description> *| 11780 |* *| 11781 |* Input parameters: *| 11782 |* NONE *| 11783 |* *| 11784 |* Output parameters: *| 11785 |* NONE *| 11786 |* *| 11787 |* Returns: *| 11788 |* NOTHING *| 11789 |* *| 11790 \******************************************************************************/ 11791 11792 static void check_for_constructors(opnd_type *top_opnd, 11793 expr_arg_type *exp_desc) 11794 11795 { 11796 int ir_idx; 11797 int list_idx; 11798 expr_arg_type loc_exp_desc; 11799 opnd_type opnd; 11800 11801 TRACE (Func_Entry, "check_for_constructors", NULL); 11802 11803 switch (OPND_FLD((*top_opnd))) { 11804 case IR_Tbl_Idx: 11805 ir_idx = OPND_IDX((*top_opnd)); 11806 11807 switch (IR_OPR(ir_idx)) { 11808 case Stmt_Expansion_Opr: 11809 case Call_Opr: 11810 break; 11811 11812 case Array_Construct_Opr : 11813 # if 0 11814 loc_exp_desc = arg_info_list[IR_IDX_L(ir_idx)].ed; 11815 create_runtime_array_constructor(top_opnd, &loc_exp_desc); 11816 if (exp_desc != NULL) { 11817 COPY_SHAPE((exp_desc->shape), 11818 loc_exp_desc.shape, loc_exp_desc.rank); 11819 } 11820 # endif 11821 break; 11822 11823 default: 11824 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 11825 check_for_constructors(&opnd, exp_desc); 11826 COPY_OPND(IR_OPND_L(ir_idx), opnd); 11827 11828 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 11829 check_for_constructors(&opnd, exp_desc); 11830 COPY_OPND(IR_OPND_R(ir_idx), opnd); 11831 break; 11832 } 11833 break; 11834 11835 case IL_Tbl_Idx: 11836 list_idx = OPND_IDX((*top_opnd)); 11837 while (list_idx) { 11838 COPY_OPND(opnd, IL_OPND(list_idx)); 11839 check_for_constructors(&opnd, exp_desc); 11840 COPY_OPND(IL_OPND(list_idx), opnd); 11841 list_idx = IL_NEXT_LIST_IDX(list_idx); 11842 } 11843 break; 11844 } 11845 11846 11847 TRACE (Func_Exit, "check_for_constructors", NULL); 11848 11849 return; 11850 11851 } /* check_for_constructors */ 11852 11853 /******************************************************************************\ 11854 |* *| 11855 |* Description: *| 11856 |* Compare an actual arg with its corresponding darg. *| 11857 |* *| 11858 |* Input parameters: *| 11859 |* arg_attr - *| 11860 |* info_idx - *| 11861 |* spec_count - *| 11862 |* *| 11863 |* Output parameters: *| 11864 |* NONE *| 11865 |* *| 11866 |* Returns: *| 11867 |* TRUE if they are the same. *| 11868 |* *| 11869 \******************************************************************************/ 11870 static boolean compare_darg_to_actual_arg(int gen_idx, 11871 int spec_idx, 11872 int arg_attr, 11873 opnd_type list_opnd, 11874 int info_idx, 11875 int spec_count) 11876 /* arg_attr is the darg */ 11877 11878 { 11879 int a_linear_type; 11880 int a_type; 11881 int a_type_idx; 11882 int aa_rank; 11883 int attr_idx; 11884 int da_rank; 11885 expr_arg_type exp_desc; 11886 int idx; 11887 opnd_type opnd; 11888 int opnd_line; 11889 int opnd_column; 11890 boolean pgm_unit; 11891 boolean pointer; 11892 boolean same = TRUE; 11893 int type_idx; 11894 char type_word1[40]; 11895 char type_word2[40]; 11896 11897 11898 TRACE (Func_Entry, "compare_darg_to_actual_arg", NULL); 11899 11900 # if defined(_DEBUG) 11901 11902 if (info_idx == NULL_IDX && OPND_FLD(list_opnd) != AT_Tbl_Idx) { 11903 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 11904 "IL_FLD to be AT_Tbl_Idx", 11905 "compare_darg_to_actual_arg"); 11906 } 11907 # endif 11908 11909 find_opnd_line_and_column((opnd_type *) &list_opnd, &opnd_line, 11910 &opnd_column); 11911 11912 attr_idx = OPND_IDX(list_opnd); /* Won't always be an attr */ 11913 11914 if (info_idx == NULL_IDX) { 11915 pgm_unit = (AT_OBJ_CLASS(attr_idx) == Pgm_Unit); 11916 } 11917 else { 11918 pgm_unit = arg_info_list[info_idx].pgm_unit; 11919 } 11920 11921 switch (AT_OBJ_CLASS(arg_attr)) { 11922 case Data_Obj: 11923 11924 if (pgm_unit) { 11925 same = FALSE; 11926 11927 if (spec_count == 0) { /* error .. expecting data obj */ 11928 PRINTMSG(opnd_line, 503, Error, opnd_column, 11929 AT_OBJ_NAME_PTR(attr_idx), 11930 "PROGRAM UNIT", 11931 AT_OBJ_NAME_PTR(arg_attr), 11932 "DATA OBJECT"); 11933 } 11934 break; 11935 } 11936 11937 if (ATD_IGNORE_TKR(arg_attr)) { 11938 11939 /* This dummy arg will match any rank, so skip the rank */ 11940 /* type checking below. - intentionally blank */ 11941 11942 } 11943 else if (OPND_FLD(list_opnd) == IR_Tbl_Idx && 11944 IR_OPR(OPND_IDX(list_opnd)) == Null_Intrinsic_Opr) { 11945 11946 /* intentionally blank */ 11947 /* Don't know type or rank yet, they come from darg */ 11948 } 11949 else if (!((strcmp(AT_OBJ_NAME_PTR(gen_idx), "EOSHIFT") == 0) && 11950 (strcmp(AT_OBJ_NAME_PTR(arg_attr), "BOUNDARY") == 0))) { 11951 11952 if (!(strcmp(AT_OBJ_NAME_PTR(gen_idx), "RESHAPE") == 0) || 11953 ((strcmp(AT_OBJ_NAME_PTR(arg_attr), "PAD") != 0) && 11954 (strcmp(AT_OBJ_NAME_PTR(arg_attr), "ORDER") != 0))) { 11955 11956 aa_rank = 0; 11957 da_rank = (ATD_ARRAY_IDX(arg_attr) ? 11958 BD_RANK(ATD_ARRAY_IDX(arg_attr)) : 0); 11959 11960 if (info_idx == NULL_IDX) { 11961 pointer = ATD_POINTER(attr_idx); 11962 11963 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 11964 aa_rank = BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11965 } 11966 } 11967 else { 11968 aa_rank = arg_info_list[info_idx].ed.rank; 11969 pointer = arg_info_list[info_idx].ed.pointer; 11970 } 11971 11972 if (!AT_ELEMENTAL_INTRIN(spec_idx) && 11973 !ATP_ELEMENTAL(spec_idx) && 11974 aa_rank != da_rank) { /* ranks are different */ 11975 11976 if (spec_count > 0) { 11977 11978 /* rank must match for generic resolution */ 11979 11980 same = FALSE; 11981 break; 11982 } 11983 11984 if (pointer && ATD_POINTER(arg_attr)) { 11985 PRINTMSG(opnd_line, 1091, Error, opnd_column, 11986 AT_OBJ_NAME_PTR(arg_attr)); 11987 same = FALSE; 11988 } 11989 else if (aa_rank == 0) { /* scalar to array */ 11990 11991 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(arg_attr)) == Assumed_Shape){ 11992 PRINTMSG(opnd_line, 434, Error, opnd_column, 11993 AT_OBJ_NAME_PTR(arg_attr)); 11994 same = FALSE; 11995 } 11996 else if (info_idx != NULL_IDX && 11997 arg_info_list[info_idx].ed.array_elt) { 11998 11999 /* this is ok, intentionally blank */ 12000 /* If info_idx is NULL, we do not */ 12001 /* have an expression. */ 12002 12003 } 12004 else { 12005 PRINTMSG(opnd_line, 435, Error, opnd_column, 12006 AT_OBJ_NAME_PTR(arg_attr)); 12007 same = FALSE; 12008 } 12009 } 12010 else if (da_rank == 0) { /* array to scalar */ 12011 same = FALSE; 12012 PRINTMSG(opnd_line, 436, Error, opnd_column, 12013 AT_OBJ_NAME_PTR(arg_attr)); 12014 } 12015 else { /* array to array, ranks don't match */ 12016 12017 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(arg_attr)) == Assumed_Shape){ 12018 PRINTMSG(opnd_line, 772, Error, opnd_column, 12019 AT_OBJ_NAME_PTR(arg_attr)); 12020 break; 12021 } 12022 } 12023 } 12024 } 12025 } 12026 12027 if (info_idx == NULL_IDX) { 12028 a_type_idx = ATD_TYPE_IDX(attr_idx); 12029 a_linear_type = TYP_LINEAR(a_type_idx); 12030 a_type = TYP_TYPE(a_type_idx); 12031 } 12032 else { 12033 a_type_idx = arg_info_list[info_idx].ed.type_idx; 12034 a_linear_type = arg_info_list[info_idx].ed.linear_type; 12035 a_type = arg_info_list[info_idx].ed.type; 12036 } 12037 12038 if (ATP_PROC(spec_idx) == Intrin_Proc) { 12039 12040 if (((1 << a_linear_type) & ATD_INTRIN_DARG_TYPE(arg_attr)) == 0) { 12041 same = FALSE; 12042 12043 if (spec_count == 0) { 12044 PRINTMSG(opnd_line, 334, Error, opnd_column); 12045 } 12046 break; 12047 } 12048 } 12049 else if (ATD_IGNORE_TKR(arg_attr)) { 12050 12051 /* intentionally blank */ 12052 /* This dummy arg will match any type, so skip */ 12053 /* the type and kind type checking below. */ 12054 } 12055 else if (OPND_FLD(list_opnd) == IR_Tbl_Idx && 12056 IR_OPR(OPND_IDX(list_opnd)) == Null_Intrinsic_Opr) { 12057 12058 /* intentionally blank */ 12059 /* Don't know type or rank yet, they come from dummy */ 12060 } 12061 else { 12062 type_idx = ATD_TYPE_IDX(arg_attr); 12063 12064 if (a_linear_type == Short_Typeless_Const && 12065 (TYP_TYPE(type_idx) == Integer || 12066 TYP_TYPE(type_idx) == Real || 12067 TYP_TYPE(type_idx) == Complex)) { 12068 12069 /* intentionally blank */ 12070 /* the constant will be converted to dummy type later */ 12071 } 12072 else if (a_type == Typeless && 12073 (TYP_TYPE(type_idx) == Integer || 12074 TYP_TYPE(type_idx) == Real) && 12075 num_host_wds[a_linear_type] == 12076 num_host_wds[TYP_LINEAR(type_idx)]) { 12077 12078 /* intentionally blank */ 12079 /* no conversion will be done */ 12080 } 12081 else if (a_linear_type == Short_Typeless_Const && 12082 (CN_HOLLERITH_TYPE(OPND_IDX(list_opnd)) == H_Hollerith || 12083 CN_HOLLERITH_TYPE(OPND_IDX(list_opnd)) == L_Hollerith) && 12084 TYP_TYPE(type_idx) == Character) { 12085 12086 /* intentionall blank */ 12087 /* this will be turned into a character constant later */ 12088 } 12089 else if (a_type != TYP_TYPE(type_idx)) { 12090 same = FALSE; 12091 12092 if (spec_count == 0) { 12093 type_word1[0] = '\0'; 12094 type_word2[0] = '\0'; 12095 strcat(type_word1,get_basic_type_str(type_idx)); 12096 strcat(type_word2,get_basic_type_str(a_type_idx)); 12097 PRINTMSG(opnd_line, 1108, Error, opnd_column, 12098 type_word2, 12099 type_word1); 12100 } 12101 } 12102 else if (TYP_TYPE(type_idx) == Structure && 12103 !compare_derived_types(type_idx, a_type_idx)) { 12104 same = FALSE; 12105 12106 if (spec_count == 0) { 12107 type_word1[0] = '\0'; 12108 type_word2[0] = '\0'; 12109 strcat(type_word1,get_basic_type_str(type_idx)); 12110 strcat(type_word2,get_basic_type_str(a_type_idx)); 12111 PRINTMSG(opnd_line, 1108, Error, opnd_column, 12112 type_word2, 12113 type_word1); 12114 } 12115 } 12116 else if (TYP_TYPE(type_idx) == Character) { 12117 12118 if (info_idx != NULL_IDX && TYP_FLD(type_idx) == CN_Tbl_Idx) { 12119 COPY_OPND(opnd, list_opnd); 12120 exp_desc = arg_info_list[info_idx].ed; 12121 same &= validate_char_len(&opnd, &exp_desc); 12122 arg_info_list[info_idx].ed = exp_desc; 12123 12124 if (TYP_FLD(exp_desc.type_idx) == CN_Tbl_Idx && 12125 fold_relationals(TYP_IDX(exp_desc.type_idx), 12126 TYP_IDX(type_idx), 12127 Lt_Opr)) { 12128 12129 if (OPND_FLD(list_opnd) == CN_Tbl_Idx) { 12130 PRINTMSG(opnd_line, 1305, Caution, opnd_column); 12131 PRINTMSG(opnd_line, 1306, Ansi, opnd_column); 12132 cast_to_type_idx(&opnd, 12133 &exp_desc, 12134 type_idx); 12135 arg_info_list[info_idx].ed = exp_desc; 12136 COPY_OPND(list_opnd, opnd); 12137 } 12138 } 12139 } 12140 } 12141 else if (TYP_TYPE(type_idx) != Structure && 12142 a_linear_type != TYP_LINEAR(type_idx)) { 12143 same = FALSE; 12144 12145 if (spec_count == 0) { /* error .. kinds don't match */ 12146 PRINTMSG(opnd_line, 1307, Error, opnd_column, 12147 storage_bit_kind_tbl[a_linear_type], 12148 storage_bit_kind_tbl[TYP_LINEAR(type_idx)]); 12149 } 12150 } 12151 } 12152 break; 12153 12154 12155 case Pgm_Unit : 12156 12157 if (!pgm_unit) { 12158 same = FALSE; 12159 12160 if (spec_count == 0) { /* error .. expecting pgm unit */ 12161 PRINTMSG(opnd_line, 502, Error, 12162 opnd_column, 12163 AT_OBJ_NAME_PTR(arg_attr)); 12164 } 12165 break; 12166 } 12167 else if (ATP_EXPL_ITRFC(attr_idx) && ATP_EXPL_ITRFC(arg_attr)) { 12168 12169 /* If a darg and an actual arg are both procedures and they */ 12170 /* both have explicit interfaces then they must match to be */ 12171 /* the same. This routine will recursively check them. */ 12172 12173 if (ATP_NUM_DARGS(attr_idx) == ATP_NUM_DARGS(arg_attr) && 12174 ATP_PGM_UNIT(attr_idx) == ATP_PGM_UNIT(arg_attr)) { 12175 12176 if (ATP_PGM_UNIT(attr_idx) == Function) { 12177 12178 if (info_idx != NULL_IDX) { 12179 12180 same = compare_func_result(arg_attr, 12181 arg_info_list[info_idx].ed.type_idx, 12182 arg_info_list[info_idx].ed.type, 12183 arg_info_list[info_idx].ed.linear_type, 12184 arg_info_list[info_idx].ed.rank, 12185 spec_count, 12186 opnd_line, 12187 opnd_column); 12188 } 12189 else { 12190 a_type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 12191 aa_rank = (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)) == NULL_IDX)? 12192 0 : BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))); 12193 12194 same = compare_func_result(arg_attr, 12195 a_type_idx, 12196 TYP_TYPE(a_type_idx), 12197 TYP_LINEAR(a_type_idx), 12198 aa_rank, 12199 spec_count, 12200 opnd_line, 12201 opnd_column); 12202 } 12203 12204 if (!same) { 12205 break; 12206 } 12207 } 12208 12209 /* Compare dummy arguments */ 12210 12211 for (idx = (ATP_EXTRA_DARG(arg_attr) ? 1:0); 12212 idx < ATP_NUM_DARGS(arg_attr); idx++) { 12213 12214 COPY_OPND(opnd, list_opnd); 12215 OPND_FLD(opnd) = AT_Tbl_Idx; 12216 OPND_IDX(opnd) = SN_ATTR_IDX(ATP_FIRST_IDX(attr_idx)+idx); 12217 12218 if (!compare_darg_to_actual_arg( 12219 gen_idx, 12220 spec_idx, 12221 SN_ATTR_IDX(ATP_FIRST_IDX(arg_attr)+idx), 12222 opnd, 12223 NULL_IDX, 12224 spec_count)) { 12225 12226 /* If messages are necessary, they will be */ 12227 /* issued from compare_darg_to_actual_arg. */ 12228 12229 same = FALSE; 12230 break; 12231 } 12232 } 12233 } 12234 else { 12235 12236 if (spec_count == 0) { 12237 PRINTMSG(opnd_line, 1635, Error, 12238 opnd_column, 12239 AT_OBJ_NAME_PTR(attr_idx), 12240 AT_OBJ_NAME_PTR(arg_attr)); 12241 } 12242 same = FALSE; 12243 } 12244 } 12245 else if (ATP_EXPL_ITRFC(arg_attr) && spec_count != 0) { 12246 12247 /* Interp 51 - We are looking for a specific with a dummy */ 12248 /* procedure argument. Interp 51, states that we cannot use */ 12249 /* whether it is a subroutine or a function to differentiate */ 12250 /* a specific if there is no explciit interface declared. */ 12251 12252 same = FALSE; 12253 } 12254 else if (ATP_PGM_UNIT(attr_idx) == Function) { 12255 12256 /* matches same type function, or */ 12257 /* a Pgm_Unknown with same impl type. */ 12258 12259 if (ATP_PGM_UNIT(arg_attr) == Function || 12260 ATP_PGM_UNIT(arg_attr) == Pgm_Unknown) { 12261 12262 if (info_idx != NULL_IDX) { 12263 same = compare_func_result(arg_attr, 12264 arg_info_list[info_idx].ed.type_idx, 12265 arg_info_list[info_idx].ed.type, 12266 arg_info_list[info_idx].ed.linear_type, 12267 arg_info_list[info_idx].ed.rank, 12268 spec_count, 12269 opnd_line, 12270 opnd_column); 12271 } 12272 else { 12273 a_type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 12274 aa_rank = (ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx)) == NULL_IDX)? 12275 0 : BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(attr_idx))); 12276 12277 same = compare_func_result(arg_attr, 12278 a_type_idx, 12279 TYP_TYPE(a_type_idx), 12280 TYP_LINEAR(a_type_idx), 12281 aa_rank, 12282 spec_count, 12283 opnd_line, 12284 opnd_column); 12285 } 12286 12287 if (!same) { 12288 12289 if (spec_count == 0) { 12290 12291 /* ok for specific check */ 12292 12293 } 12294 else { 12295 break; 12296 } 12297 } 12298 } 12299 else { /* error .. expected function got Subroutine */ 12300 same = FALSE; 12301 12302 if (spec_count == 0) { 12303 PRINTMSG(opnd_line, 503, Error, opnd_column, 12304 AT_OBJ_NAME_PTR(attr_idx), 12305 "FUNCTION", 12306 AT_OBJ_NAME_PTR(arg_attr), 12307 "SUBROUTINE"); 12308 } 12309 break; 12310 } 12311 } 12312 else if (ATP_PGM_UNIT(attr_idx) == Subroutine) { 12313 12314 /* matches Subroutine, or Pgm_Unknown */ 12315 12316 if (ATP_PGM_UNIT(arg_attr) != Subroutine && 12317 ATP_PGM_UNIT(arg_attr) != Pgm_Unknown) { 12318 same = FALSE; 12319 12320 if (spec_count == 0) { 12321 PRINTMSG(opnd_line, 503, Error, 12322 opnd_column, 12323 AT_OBJ_NAME_PTR(attr_idx), 12324 "SUBROUTINE", 12325 AT_OBJ_NAME_PTR(arg_attr), 12326 "FUNCTION"); 12327 } 12328 break; 12329 } 12330 } 12331 else if (ATP_PGM_UNIT(attr_idx) == Pgm_Unknown) { 12332 12333 /* matches Subroutine, or Pgm_Unknown or */ 12334 /* a function */ 12335 12336 if (ATP_PGM_UNIT(arg_attr) != Subroutine && 12337 ATP_PGM_UNIT(arg_attr) != Function && 12338 ATP_PGM_UNIT(arg_attr) != Pgm_Unknown) { 12339 12340 /* shouldn't be here, dummy arg should only be */ 12341 /* Function, Subroutine, or Pgm_Unknown */ 12342 12343 # ifdef _DEBUG 12344 print_at_all(arg_attr); 12345 # endif 12346 PRINTMSG(opnd_line, 972, Internal, opnd_column); 12347 } 12348 } 12349 12350 12351 break; 12352 12353 default : 12354 # ifdef _DEBUG 12355 print_at_all(arg_attr); 12356 # endif 12357 PRINTMSG(opnd_line, 972, Internal, opnd_column); 12358 break; 12359 12360 } /* end switch */ 12361 12362 TRACE (Func_Exit, "compare_darg_to_actual_arg", NULL); 12363 12364 return(same); 12365 12366 } /* compare_darg_to_actual_arg */ 12367 12368 /******************************************************************************\ 12369 |* *| 12370 |* Description: *| 12371 |* Compare an actual function result with its corresponding darg. *| 12372 |* *| 12373 |* Input parameters: *| 12374 |* arg_attr - *| 12375 |* info_idx - *| 12376 |* spec_count - *| 12377 |* *| 12378 |* Output parameters: *| 12379 |* NONE *| 12380 |* *| 12381 |* Returns: *| 12382 |* TRUE if they are the same. *| 12383 |* *| 12384 \******************************************************************************/ 12385 static boolean compare_func_result(int darg_attr, 12386 int a_type_idx, 12387 int a_type, 12388 int a_linear_type, 12389 int a_rank, 12390 int spec_count, 12391 int line, 12392 int column) 12393 12394 { 12395 boolean same = TRUE; 12396 int type_idx; 12397 char type_word1[40]; 12398 char type_word2[40]; 12399 12400 12401 TRACE (Func_Entry, "compare_func_result", NULL); 12402 12403 darg_attr = ATP_RSLT_IDX(darg_attr); 12404 12405 if (darg_attr == NULL_IDX) { /* have an INTRINSIC darg */ 12406 type_idx = a_type_idx; 12407 } 12408 else { 12409 type_idx = ATD_TYPE_IDX(darg_attr); 12410 } 12411 12412 if (a_type != TYP_TYPE(type_idx)){ 12413 same = FALSE; 12414 12415 if (spec_count == 0) { 12416 type_word1[0] = '\0'; 12417 type_word2[0] = '\0'; 12418 strcat(type_word1,get_basic_type_str(type_idx)); 12419 strcat(type_word2,get_basic_type_str(a_type_idx)); 12420 PRINTMSG(line, 1108, Error, column, type_word2, type_word1); 12421 } 12422 } 12423 else if (TYP_TYPE(type_idx) == Structure && 12424 !compare_derived_types(a_type_idx, type_idx)) { 12425 same = FALSE; 12426 12427 if (spec_count == 0) { 12428 type_word1[0] = '\0'; 12429 type_word2[0] = '\0'; 12430 strcat(type_word1, get_basic_type_str(type_idx)); 12431 strcat(type_word2, get_basic_type_str(a_type_idx)); 12432 PRINTMSG(line, 1108, Error, column, type_word2, type_word1); 12433 } 12434 } 12435 else if (TYP_TYPE(type_idx) != Structure && 12436 TYP_TYPE(type_idx) != Character && 12437 a_linear_type != TYP_LINEAR(type_idx)) { 12438 same = FALSE; 12439 12440 if (spec_count == 0) { /* error .. kinds don't match */ 12441 PRINTMSG(line, 1307, Error, column, 12442 storage_bit_kind_tbl[a_linear_type], 12443 storage_bit_kind_tbl[TYP_LINEAR(type_idx)]); 12444 } 12445 } 12446 else if (darg_attr != NULL_IDX && (a_rank != (ATD_ARRAY_IDX(darg_attr) ? 12447 BD_RANK(ATD_ARRAY_IDX(darg_attr)) : 0))) { 12448 12449 if (spec_count != 0) { /* ok for specific check */ 12450 same = FALSE; 12451 } 12452 } 12453 12454 TRACE (Func_Exit, "compare_func_result", NULL); 12455 12456 return(same); 12457 12458 } /* compare_func_result */ 12459 12460 /******************************************************************************\ 12461 |* *| 12462 |* Description: *| 12463 |* <description> *| 12464 |* *| 12465 |* Input parameters: *| 12466 |* NONE *| 12467 |* *| 12468 |* Output parameters: *| 12469 |* NONE *| 12470 |* *| 12471 |* Returns: *| 12472 |* NOTHING *| 12473 |* *| 12474 \******************************************************************************/ 12475 12476 static boolean check_arg_for_co_array(opnd_type *top_opnd) 12477 12478 { 12479 int col; 12480 int ir_idx; 12481 int line; 12482 int list_idx; 12483 boolean ok = TRUE; 12484 opnd_type opnd; 12485 12486 TRACE (Func_Entry, "check_arg_for_co_array", NULL); 12487 12488 if (OPND_FLD((*top_opnd)) == IR_Tbl_Idx) { 12489 ir_idx = OPND_IDX((*top_opnd)); 12490 12491 switch(IR_OPR(ir_idx)) { 12492 case Struct_Opr: 12493 case Dv_Deref_Opr: 12494 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 12495 ok &= check_arg_for_co_array(&opnd); 12496 break; 12497 12498 case Subscript_Opr: 12499 case Whole_Subscript_Opr: 12500 case Section_Subscript_Opr: 12501 list_idx = IR_IDX_R(ir_idx); 12502 while (list_idx) { 12503 if (IL_PE_SUBSCRIPT(list_idx)) { 12504 find_opnd_line_and_column(&IL_OPND(list_idx), &line, &col); 12505 PRINTMSG(line, 1366, Error, col); 12506 ok = FALSE; 12507 break; 12508 } 12509 list_idx = IL_NEXT_LIST_IDX(list_idx); 12510 } 12511 12512 /* intentionally falls through */ 12513 12514 12515 case Substring_Opr: 12516 case Whole_Substring_Opr: 12517 12518 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 12519 ok &= check_arg_for_co_array(&opnd); 12520 12521 list_idx = IR_IDX_R(ir_idx); 12522 while (list_idx) { 12523 COPY_OPND(opnd, IL_OPND(list_idx)); 12524 ok &= check_arg_for_co_array(&opnd); 12525 list_idx = IL_NEXT_LIST_IDX(list_idx); 12526 } 12527 break; 12528 12529 case Triplet_Opr: 12530 list_idx = IR_IDX_L(ir_idx); 12531 while (list_idx) { 12532 COPY_OPND(opnd, IL_OPND(list_idx)); 12533 ok &= check_arg_for_co_array(&opnd); 12534 list_idx = IL_NEXT_LIST_IDX(list_idx); 12535 } 12536 break; 12537 12538 } 12539 } 12540 12541 TRACE (Func_Exit, "check_arg_for_co_array", NULL); 12542 12543 return(ok); 12544 12545 } /* check_arg_for_co_array */ 12546 12547 /******************************************************************************\ 12548 |* *| 12549 |* Description: *| 12550 |* <description> *| 12551 |* *| 12552 |* Input parameters: *| 12553 |* NONE *| 12554 |* *| 12555 |* Output parameters: *| 12556 |* NONE *| 12557 |* *| 12558 |* Returns: *| 12559 |* NOTHING *| 12560 |* *| 12561 \******************************************************************************/ 12562 12563 static void update_components(opnd_type *opnd) 12564 12565 { 12566 int attr_idx; 12567 int il_idx; 12568 int ir_idx; 12569 int sn_idx; 12570 12571 12572 TRACE (Func_Entry, "update_components", NULL); 12573 12574 switch (OPND_FLD((*opnd))) { 12575 case IR_Tbl_Idx: 12576 12577 ir_idx = OPND_IDX((*opnd)); 12578 12579 if (IR_OPR(ir_idx) == Struct_Opr) { 12580 12581 /* Right is the component */ 12582 12583 if (IR_FLD_L(ir_idx) == AT_Tbl_Idx && 12584 AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Derived_Type) { 12585 12586 if (ATD_DERIVED_TYPE_IDX(IR_IDX_R(ir_idx)) != IR_IDX_L(ir_idx)) { 12587 12588 /* The derived type is out of sync with the component. */ 12589 /* Update the component attr index. */ 12590 12591 sn_idx = ATT_FIRST_CPNT_IDX(IR_IDX_L(ir_idx)); 12592 attr_idx = srch_linked_sn(AT_OBJ_NAME_PTR(IR_IDX_R(ir_idx)), 12593 AT_NAME_LEN(IR_IDX_R(ir_idx)), 12594 &sn_idx); 12595 12596 # ifdef _DEBUG 12597 if (attr_idx == NULL_IDX) { 12598 PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal, 12599 IR_COL_NUM(ir_idx), 12600 "component to be found", 12601 "update_components"); 12602 } 12603 # endif 12604 IR_IDX_R(ir_idx) = attr_idx; 12605 } /* Same - so don't need to update */ 12606 } 12607 else { 12608 12609 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) { 12610 12611 /* Nested structure reference. Derived */ 12612 /* type should be on this ir. */ 12613 12614 if (TYP_TYPE(IR_TYPE_IDX(IR_IDX_L(ir_idx))) == Structure && 12615 ATD_DERIVED_TYPE_IDX(IR_IDX_R(ir_idx)) != 12616 TYP_IDX(IR_TYPE_IDX(IR_IDX_L(ir_idx)))) { 12617 12618 /* The derived type is out of sync with the component. */ 12619 /* Update the component attr index. */ 12620 12621 sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX( 12622 IR_TYPE_IDX(IR_IDX_L(ir_idx)))); 12623 attr_idx = srch_linked_sn(AT_OBJ_NAME_PTR(IR_IDX_R(ir_idx)), 12624 AT_NAME_LEN(IR_IDX_R(ir_idx)), 12625 &sn_idx); 12626 12627 # ifdef _DEBUG 12628 if (attr_idx == NULL_IDX) { 12629 PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal, 12630 IR_COL_NUM(ir_idx), 12631 "component to be found", 12632 "update_components"); 12633 } 12634 # endif 12635 IR_IDX_R(ir_idx) = attr_idx; 12636 } /* Same - so don't need to update */ 12637 } 12638 update_components(&IR_OPND_L(ir_idx)); 12639 } 12640 } 12641 else { 12642 update_components(&IR_OPND_L(ir_idx)); 12643 update_components(&IR_OPND_R(ir_idx)); 12644 } 12645 12646 break; 12647 12648 case IL_Tbl_Idx: 12649 il_idx = OPND_IDX((*opnd)); 12650 12651 do { 12652 update_components(&IL_OPND(il_idx)); 12653 il_idx = IL_NEXT_LIST_IDX(il_idx); 12654 } 12655 while (il_idx != NULL_IDX); 12656 break; 12657 12658 case NO_Tbl_Idx: 12659 case SH_Tbl_Idx: 12660 case AT_Tbl_Idx: 12661 case CN_Tbl_Idx: 12662 case SB_Tbl_Idx: /* done - quit looking here */ 12663 break; 12664 12665 default: /* done - quit looking here */ 12666 break; 12667 } 12668 12669 TRACE (Func_Exit, "update_components", NULL); 12670 12671 return; 12672 12673 } /* update_components */
1.7.6.1 
