|
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_utils.c 5.12 10/19/99 17:14:30\n"; 00038 00039 00040 # include "defines.h" /* Machine dependent ifdefs */ 00041 00042 # include "host.m" /* Host machine dependent macros.*/ 00043 # include "host.h" /* Host machine dependent header.*/ 00044 # include "target.m" /* Target machine dependent macros.*/ 00045 # include "target.h" /* Target machine dependent header.*/ 00046 00047 # include "globals.m" 00048 # include "tokens.m" 00049 # include "sytb.m" 00050 # include "s_globals.m" 00051 # include "debug.m" 00052 # include "s_utils.m" 00053 00054 # include "globals.h" 00055 # include "tokens.h" 00056 # include "sytb.h" 00057 # include "s_globals.h" 00058 00059 # if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS) 00060 # include <fortran.h> 00061 # endif 00062 00063 00064 /*****************************************************************\ 00065 |* function prototypes of static functions declared in this file *| 00066 \*****************************************************************/ 00067 00068 static int opr_to_str(operator_type, char *); 00069 static int create_dv_type_code(int); 00070 static long64 create_imp_do_loops(opnd_type *); 00071 static void just_find_dope_and_rank(opnd_type *, int *, int *); 00072 static void compute_char_element_len(opnd_type *, 00073 opnd_type *, opnd_type *); 00074 static void gen_conform_check_call(opnd_type *, opnd_type *, int, int, int); 00075 static void gen_bounds_check_call(char *, opnd_type *, opnd_type *, 00076 opnd_type *, int, int, int); 00077 static void gen_rbounds_check_call(char *, opnd_type *, opnd_type *, 00078 opnd_type *, opnd_type *, 00079 opnd_type *, int, int, int); 00080 static void gen_sbounds_check_call(char *, opnd_type *, opnd_type *, 00081 opnd_type *, int, int); 00082 static void gen_ptr_chk_call(char *, int, opnd_type *, int, int); 00083 static int put_file_name_in_cn(int); 00084 static int put_c_str_in_cn(char *); 00085 static void gen_dv_def_loops(opnd_type *); 00086 static void gen_init_stmt(opnd_type *, int, sh_position_type); 00087 static void reshape_reference_subscripts(opnd_type *); 00088 static void gen_dv_stride_mult(opnd_type *, int, opnd_type *, 00089 expr_arg_type *, int, int, int); 00090 00091 00092 /******************************************************************************\ 00093 |* *| 00094 |* Description: *| 00095 |* resolve defined operators and assignment. *| 00096 |* *| 00097 |* Input parameters: *| 00098 |* opnd - sub tree of operator. *| 00099 |* *| 00100 |* Output parameters: *| 00101 |* *| 00102 |* Returns: *| 00103 |* TRUE - if operator resolved ok. *| 00104 |* *| 00105 \******************************************************************************/ 00106 00107 boolean resolve_ext_opr(opnd_type *opnd, 00108 boolean issue_msg, 00109 boolean save_in_call_list, 00110 boolean err_res, 00111 boolean *semantically_correct, 00112 expr_arg_type *exp_desc_l, 00113 expr_arg_type *exp_desc_r) 00114 00115 { 00116 opnd_type arg_1_opnd; 00117 opnd_type arg_2_opnd; 00118 int arg_idx; 00119 int attr_idx; 00120 int col; 00121 int darg_idx; 00122 00123 # if defined(GENERATE_WHIRL) 00124 int false_list_idx = NULL_IDX; 00125 # endif 00126 00127 boolean found = FALSE; 00128 int gen_idx = NULL_IDX; 00129 int i; 00130 int idx; 00131 int info_idx; 00132 int ir_idx; 00133 boolean is_function = TRUE; 00134 int len; 00135 int line; 00136 int list_idx; 00137 int list1_idx; 00138 int list2_idx; 00139 int loc_idx; 00140 int name_idx; 00141 int num_args; 00142 boolean ok = TRUE; 00143 int opnd_column; 00144 int opnd_line; 00145 int rslt_idx; 00146 int save_arg_info_list_base; 00147 int save_curr_stmt_sh_idx; 00148 int save_defer_stmt_expansion; 00149 int spec_idx = NULL_IDX; 00150 int sn_idx = NULL_IDX; 00151 char str_word[32]; 00152 opnd_type tmp_opnd; 00153 char type_str_l[45]; 00154 char type_str_r[45]; 00155 00156 00157 TRACE (Func_Entry, "resolve_ext_opr", NULL); 00158 00159 /* do memory management stuff to make sure the tables are big enough */ 00160 00161 if (max_call_list_size >= arg_list_size) { 00162 enlarge_call_list_tables(); 00163 } 00164 00165 save_arg_info_list_base = arg_info_list_base; 00166 arg_info_list_base = arg_info_list_top; 00167 arg_info_list_top = arg_info_list_base + 2; 00168 00169 if (arg_info_list_top >= arg_info_list_size) { 00170 enlarge_info_list_table(); 00171 } 00172 00173 ir_idx = OPND_IDX((*opnd)); 00174 line = IR_LINE_NUM(ir_idx); 00175 col = IR_COL_NUM(ir_idx); 00176 00177 if (IR_OPR(ir_idx) == Defined_Bin_Opr) { 00178 00179 gen_idx = IR_IDX_L(ir_idx); 00180 strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx)); 00181 str_word[AT_NAME_LEN(gen_idx)] = '\0'; 00182 num_args = 2; 00183 COPY_OPND(arg_1_opnd, IL_OPND(IR_IDX_R(ir_idx))); 00184 COPY_OPND(arg_2_opnd, IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)))); 00185 00186 if (cif_flags & XREF_RECS) { 00187 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference); 00188 } 00189 } 00190 else if (IR_OPR(ir_idx) == Defined_Un_Opr) { 00191 gen_idx = IR_IDX_L(ir_idx); 00192 strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx)); 00193 str_word[AT_NAME_LEN(gen_idx)] = '\0'; 00194 num_args = 1; 00195 COPY_OPND(arg_1_opnd, IR_OPND_R(ir_idx)); 00196 00197 if (cif_flags & XREF_RECS) { 00198 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference); 00199 } 00200 } 00201 else { 00202 len = opr_to_str(IR_OPR(ir_idx), str_word); 00203 gen_idx = srch_sym_tbl(str_word, len, &name_idx); 00204 00205 if (gen_idx == NULL_IDX) { 00206 gen_idx = srch_host_sym_tbl(str_word, len, &name_idx, TRUE); 00207 } 00208 00209 COPY_OPND(arg_1_opnd, IR_OPND_L(ir_idx)); 00210 00211 if (IR_FLD_R(ir_idx) == NO_Tbl_Idx) { 00212 num_args = 1; 00213 } 00214 else { 00215 num_args = 2; 00216 COPY_OPND(arg_2_opnd, IR_OPND_R(ir_idx)); 00217 } 00218 } 00219 00220 if (IR_OPR(ir_idx) == Asg_Opr) { 00221 is_function = FALSE; 00222 } 00223 00224 if (gen_idx == NULL_IDX || 00225 AT_OBJ_CLASS(gen_idx) != Interface) { 00226 gen_idx = NULL_IDX; 00227 goto EXIT; 00228 } 00229 00230 for (i = 0; i < ATI_NUM_SPECIFICS(gen_idx); i++) { 00231 00232 sn_idx = (sn_idx == NULL_IDX) ? ATI_FIRST_SPECIFIC_IDX(gen_idx) : 00233 SN_SIBLING_LINK(sn_idx); 00234 spec_idx = SN_ATTR_IDX(sn_idx); 00235 00236 /* check number, type etc. for match with arg list */ 00237 00238 if (ATP_EXTRA_DARG(spec_idx)) { 00239 00240 if (num_args != ATP_NUM_DARGS(spec_idx) - 1) { 00241 continue; 00242 } 00243 00244 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1); 00245 } 00246 else { 00247 00248 if (num_args != ATP_NUM_DARGS(spec_idx)) { 00249 continue; 00250 } 00251 00252 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx)); 00253 } 00254 00255 /* look at each actual arg for match */ 00256 00257 if (darg_idx == NULL_IDX) { 00258 continue; 00259 } 00260 00261 if (AT_OBJ_CLASS(darg_idx) == Data_Obj) { 00262 00263 if (ATD_IGNORE_TKR(darg_idx)) { 00264 /* intentionally blank */ 00265 /* This dummy arg will match any type, so skip */ 00266 /* the type and kind type checking below. */ 00267 } 00268 else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx && 00269 IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) { 00270 /* intentionally blank */ 00271 /* Don't know type or rank yet, they come from dummy */ 00272 } 00273 else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->type) { 00274 continue; 00275 } 00276 else if (exp_desc_l->type == Structure) { 00277 00278 if (!compare_derived_types(exp_desc_l->type_idx, 00279 ATD_TYPE_IDX(darg_idx))) { 00280 continue; 00281 } 00282 } 00283 else if (exp_desc_l->type != Character && 00284 TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->linear_type) { 00285 continue; 00286 } 00287 00288 if (ATD_IGNORE_TKR(darg_idx)) { 00289 /* intentionally blank */ 00290 /* This dummy arg will match any rank, so skip */ 00291 /* the rank checking below. */ 00292 } 00293 else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx && 00294 IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) { 00295 /* intentionally blank */ 00296 /* Don't know type or rank yet, they come from dummy */ 00297 } 00298 else if (ATP_ELEMENTAL(spec_idx)) { 00299 /* intentionally blank, don't check array conformance */ 00300 } 00301 else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) { 00302 00303 if (exp_desc_l->rank) { 00304 continue; 00305 } 00306 } 00307 else { 00308 00309 if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_l->rank) { 00310 continue; 00311 } 00312 } 00313 } 00314 else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) { 00315 /* not sure this is possible */ 00316 } 00317 00318 if (num_args == 2) { 00319 if (ATP_EXTRA_DARG(spec_idx)) { 00320 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 2); 00321 } 00322 else { 00323 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1); 00324 } 00325 /* look at each actual arg for match */ 00326 00327 if (darg_idx == NULL_IDX) { 00328 continue; 00329 } 00330 00331 if (AT_OBJ_CLASS(darg_idx) == Data_Obj) { 00332 00333 if (ATD_IGNORE_TKR(darg_idx)) { 00334 /* intentionally blank */ 00335 /* This dummy arg will match any type, so skip */ 00336 /* the type and kind type checking below. */ 00337 } 00338 else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx && 00339 IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) { 00340 /* intentionally blank */ 00341 /* Don't know type or rank yet, they come from dummy */ 00342 } 00343 else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->type) { 00344 continue; 00345 } 00346 else if (exp_desc_r->type == Structure) { 00347 00348 if (!compare_derived_types(exp_desc_r->type_idx, 00349 ATD_TYPE_IDX(darg_idx))) { 00350 continue; 00351 } 00352 } 00353 else if (exp_desc_r->type != Character && 00354 TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->linear_type) { 00355 continue; 00356 } 00357 00358 if (ATD_IGNORE_TKR(darg_idx)) { 00359 /* intentionally blank */ 00360 /* This dummy arg will match any rank, so skip */ 00361 /* the rank checking below. */ 00362 } 00363 else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx && 00364 IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) { 00365 /* intentionally blank */ 00366 /* Don't know type or rank yet, they come from dummy */ 00367 } 00368 else if (ATP_ELEMENTAL(spec_idx)) { 00369 /* intentionally blank, don't check array conformance */ 00370 } 00371 else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) { 00372 00373 if (exp_desc_r->rank) { 00374 continue; 00375 } 00376 } 00377 else { 00378 00379 if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_r->rank) { 00380 continue; 00381 } 00382 } 00383 } 00384 else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) { 00385 /* not sure this is possible */ 00386 } 00387 } 00388 00389 /* if still here, I found it */ 00390 00391 /* only issue usage rec here if overloaded intrinsic opr. */ 00392 /* user defined opers (.opr.) are handled earlier. */ 00393 00394 if (cif_flags & XREF_RECS && 00395 IR_OPR(ir_idx) != Defined_Bin_Opr && 00396 IR_OPR(ir_idx) != Defined_Un_Opr) { 00397 00398 cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference); 00399 } 00400 00401 if (ATP_SCP_IDX(spec_idx) != curr_scp_idx || AT_NOT_VISIBLE(spec_idx)) { 00402 00403 /* Not visible is checked, because a not visible procedure */ 00404 /* may be referenced via its interface name, even though */ 00405 /* it cannot be referenced via its own name. */ 00406 00407 attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(spec_idx), 00408 AT_NAME_LEN(spec_idx), 00409 &name_idx); 00410 00411 if (attr_idx != spec_idx) { 00412 00413 /* This attr is not in this scope. It is either host associated */ 00414 /* here, via the interface block, or it is USE_ASSOCIATED, but */ 00415 /* is not in the local symbol table. */ 00416 00417 ADD_ATTR_TO_LOCAL_LIST(spec_idx); 00418 } 00419 } 00420 00421 AT_REFERENCED(spec_idx) = Referenced; 00422 00423 if (exp_desc_l->reference && 00424 (cif_flags & XREF_RECS) != 0 && 00425 xref_state != CIF_No_Usage_Rec) { 00426 00427 COPY_OPND(tmp_opnd, arg_1_opnd); 00428 00429 while (OPND_FLD(tmp_opnd) == IR_Tbl_Idx && 00430 IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) { 00431 00432 COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd))); 00433 } 00434 00435 find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column); 00436 00437 cif_usage_rec(OPND_IDX(tmp_opnd), 00438 OPND_FLD(tmp_opnd), 00439 opnd_line, 00440 opnd_column, 00441 CIF_Symbol_Defined_Opr_Actual_Arg); 00442 } 00443 00444 NTR_IR_LIST_TBL(list1_idx); 00445 IL_ARG_DESC_VARIANT(list1_idx) = TRUE; 00446 COPY_OPND(IL_OPND(list1_idx), arg_1_opnd); 00447 00448 info_idx = arg_info_list_base + 1; 00449 arg_info_list[info_idx] = init_arg_info; 00450 arg_info_list[info_idx].ed = *exp_desc_l; 00451 arg_info_list[info_idx].maybe_modified = TRUE; 00452 IL_ARG_DESC_IDX(list1_idx) = info_idx; 00453 00454 if (num_args == 2) { 00455 00456 if (exp_desc_r->reference && 00457 (cif_flags & XREF_RECS) != 0 && 00458 xref_state != CIF_No_Usage_Rec) { 00459 00460 COPY_OPND(tmp_opnd, arg_2_opnd); 00461 00462 while (OPND_FLD(tmp_opnd) == IR_Tbl_Idx && 00463 IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) { 00464 00465 COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd))); 00466 } 00467 00468 find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column); 00469 00470 cif_usage_rec(OPND_IDX(tmp_opnd), 00471 OPND_FLD(tmp_opnd), 00472 opnd_line, 00473 opnd_column, 00474 CIF_Symbol_Defined_Opr_Actual_Arg); 00475 } 00476 00477 00478 NTR_IR_LIST_TBL(list2_idx); 00479 IL_ARG_DESC_VARIANT(list2_idx) = TRUE; 00480 COPY_OPND(IL_OPND(list2_idx), arg_2_opnd); 00481 IL_NEXT_LIST_IDX(list1_idx) = list2_idx; 00482 00483 info_idx++; 00484 00485 arg_info_list[info_idx] = init_arg_info; 00486 arg_info_list[info_idx].ed = *exp_desc_r; 00487 arg_info_list[info_idx].maybe_modified = TRUE; 00488 IL_ARG_DESC_IDX(list2_idx) = info_idx; 00489 } 00490 00491 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 00492 IR_IDX_L(ir_idx) = spec_idx; 00493 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 00494 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 00495 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 00496 IR_IDX_R(ir_idx) = list1_idx; 00497 IR_LIST_CNT_R(ir_idx) = num_args; 00498 IR_OPR(ir_idx) = Call_Opr; 00499 /* set the type to short typeless for now. */ 00500 /* will be changed later. */ 00501 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 00502 00503 if (defer_stmt_expansion) { 00504 number_of_functions++; 00505 } 00506 00507 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 00508 00509 SCP_HAS_CALLS(curr_scp_idx) = TRUE; 00510 00511 00512 /* If Usage records are not being generated, then don't produce a Call */ 00513 /* Site record either. Example: */ 00514 /* */ 00515 /* result = func(arg) */ 00516 /* */ 00517 /* where FUNC is a generic identifier pulled in from a module where */ 00518 /* the specific procedure being called is declared something like */ 00519 /* */ 00520 /* FUNCTION func(string) RESULT(char) */ 00521 /* */ 00522 /* where CHAR result depends on the value of an expression like */ 00523 /* */ 00524 /* CHARACTER(LEN=SIZE(string%content)) :: char */ 00525 /* */ 00526 /* As a part of evaluating FUNC, we don't want to see a Call Site */ 00527 /* record generated as a part of processing SIZE (it will also have */ 00528 /* line numbers from the module in its IR tree which are meaningless. */ 00529 /* See also the cif_call_site_rec call in s_call.c. */ 00530 00531 if ((cif_flags & MISC_RECS) != 0 && xref_state != CIF_No_Usage_Rec) { 00532 cif_call_site_rec(ir_idx, gen_idx); 00533 } 00534 00535 if (AT_OBJ_CLASS(spec_idx) == Pgm_Unit && 00536 ATP_SCP_ALIVE(spec_idx)) { 00537 00538 if (ATP_PGM_UNIT(spec_idx) == Function && 00539 !ATP_RSLT_NAME(spec_idx)) { 00540 PRINTMSG(IR_LINE_NUM(ir_idx), 344, Ansi, IR_COL_NUM(ir_idx)); 00541 } 00542 if (!ATP_RECURSIVE(spec_idx) && !AT_DCL_ERR(spec_idx) && 00543 !on_off_flags.recursive) { 00544 PRINTMSG(IR_LINE_NUM(ir_idx), 343, Error, IR_COL_NUM(ir_idx)); 00545 *semantically_correct = FALSE; 00546 } 00547 } 00548 00549 if (AT_DCL_ERR(spec_idx)) { 00550 /* don't do any further processing on this bad boy */ 00551 00552 *semantically_correct = FALSE; 00553 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00554 found = TRUE; 00555 goto EXIT; 00556 } 00557 00558 stmt_expansion_control_start(); 00559 save_defer_stmt_expansion = defer_stmt_expansion; 00560 defer_stmt_expansion = FALSE; 00561 00562 if (is_function) { 00563 00564 /* need to do temp and assign here */ 00565 00566 in_call_list = save_in_call_list; 00567 rslt_idx = ATP_RSLT_IDX(spec_idx); 00568 (*exp_desc_l) = init_exp_desc; 00569 00570 exp_desc_l->type_idx = ATD_TYPE_IDX(rslt_idx); 00571 exp_desc_l->type = TYP_TYPE(exp_desc_l->type_idx); 00572 exp_desc_l->linear_type = TYP_LINEAR(exp_desc_l->type_idx); 00573 exp_desc_l->pointer = ATD_POINTER(rslt_idx); 00574 exp_desc_l->target = ATD_TARGET(rslt_idx); 00575 exp_desc_l->allocatable = ATD_ALLOCATABLE(rslt_idx); 00576 exp_desc_l->dope_vector = ATD_IM_A_DOPE(rslt_idx); 00577 00578 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(rslt_idx); 00579 00580 if (ATD_ARRAY_IDX(ATP_RSLT_IDX(spec_idx))) { 00581 exp_desc_l->assumed_shape = 00582 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Shape); 00583 exp_desc_l->assumed_size = 00584 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Size); 00585 exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(rslt_idx)); 00586 } 00587 00588 00589 if (!no_func_expansion) { 00590 00591 00592 if (ATP_ELEMENTAL(spec_idx)) { 00593 00594 attr_idx = find_base_attr(opnd, &line, &col); 00595 exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx)); 00596 } 00597 00598 00599 /* Now that the types for the function result, etc. have been */ 00600 /* resolved, the Object record that represents the function */ 00601 /* result can now be output. */ 00602 00603 if ((cif_flags & MISC_RECS) != 0 && 00604 xref_state != CIF_No_Usage_Rec) { 00605 cif_object_rec_for_func_result(spec_idx); 00606 } 00607 00608 exp_desc_l->tmp_reference = TRUE; 00609 00610 if (exp_desc_l->type == Character || 00611 exp_desc_l->rank) { 00612 00613 attr_idx = find_base_attr(opnd, &line, &col); 00614 00615 if (exp_desc_l->type == Character) { 00616 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 00617 exp_desc_l->type_idx = ATD_TYPE_IDX(attr_idx); 00618 exp_desc_l->type = TYP_TYPE(exp_desc_l->type_idx); 00619 exp_desc_l->linear_type = TYP_LINEAR(exp_desc_l->type_idx); 00620 get_char_len(opnd, &(exp_desc_l->char_len)); 00621 } 00622 00623 if (exp_desc_l->rank) { 00624 get_shape_from_attr(exp_desc_l, 00625 attr_idx, 00626 exp_desc_l->rank, 00627 line, 00628 col); 00629 00630 exp_desc_l->contig_array = TRUE; 00631 } 00632 } 00633 } 00634 else { 00635 set_shape_for_deferred_funcs(exp_desc_l, ir_idx); 00636 } 00637 00638 IR_TYPE_IDX(ir_idx) = exp_desc_l->type_idx; 00639 IR_RANK(ir_idx) = exp_desc_l->rank; 00640 } 00641 00642 if (!no_func_expansion) { 00643 00644 if (! is_function) { 00645 /* this was done for functions under flatten_func_call */ 00646 00647 COPY_OPND(tmp_opnd, IR_OPND_R(ir_idx)); 00648 ok = final_arg_work(&tmp_opnd, spec_idx, num_args, NULL) && ok; 00649 COPY_OPND(IR_OPND_R(ir_idx), tmp_opnd); 00650 } 00651 00652 if (ATP_PROC(spec_idx) != Dummy_Proc && 00653 ATP_PROC(spec_idx) != Intrin_Proc && 00654 ! ATP_VFUNCTION(spec_idx) && 00655 (cmd_line_flags.runtime_argument || 00656 cmd_line_flags.runtime_arg_call)) { 00657 00658 # if defined(GENERATE_WHIRL) 00659 list1_idx = IR_IDX_R(ir_idx); 00660 list2_idx = NULL_IDX; 00661 00662 idx = 0; 00663 00664 while (list1_idx) { 00665 if (IL_FLD(list1_idx) == IR_Tbl_Idx && 00666 IR_OPR(IL_IDX(list1_idx)) == False_Parm_Opr) { 00667 00668 false_list_idx = list1_idx; 00669 00670 IL_NEXT_LIST_IDX(list2_idx) = NULL_IDX; 00671 break; 00672 } 00673 00674 list2_idx = list1_idx; 00675 list1_idx = IL_NEXT_LIST_IDX(list1_idx); 00676 idx++; 00677 } 00678 00679 IR_LIST_CNT_R(ir_idx) = idx; 00680 # endif 00681 00682 ATP_ARGCHCK_CALL(spec_idx) = TRUE; 00683 00684 NTR_IR_TBL(loc_idx); 00685 IR_OPR(loc_idx) = Aloc_Opr; 00686 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 00687 IR_LINE_NUM(loc_idx) = line; 00688 IR_COL_NUM(loc_idx) = col; 00689 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 00690 00691 OPND_FLD(tmp_opnd) = IR_Tbl_Idx; 00692 OPND_IDX(tmp_opnd) = ir_idx; 00693 idx = create_argchck_descriptor(&tmp_opnd); 00694 IR_IDX_L(loc_idx) = idx; 00695 IR_LINE_NUM_L(loc_idx) = line; 00696 IR_COL_NUM_L(loc_idx) = col; 00697 00698 NTR_IR_LIST_TBL(list2_idx); 00699 IL_ARG_DESC_VARIANT(list2_idx) = TRUE; 00700 IL_FLD(list2_idx) = IR_Tbl_Idx; 00701 IL_IDX(list2_idx) = loc_idx; 00702 00703 if (IR_LIST_CNT_R(ir_idx) == 0) { 00704 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 00705 IR_IDX_R(ir_idx) = list2_idx; 00706 IR_LIST_CNT_R(ir_idx) = 1; 00707 } 00708 else { 00709 list1_idx = IR_IDX_R(ir_idx); 00710 while (IL_NEXT_LIST_IDX(list1_idx)) { 00711 list1_idx = IL_NEXT_LIST_IDX(list1_idx); 00712 } 00713 00714 IL_NEXT_LIST_IDX(list1_idx) = list2_idx; 00715 (IR_LIST_CNT_R(ir_idx))++; 00716 } 00717 00718 # if defined(GENERATE_WHIRL) 00719 if (false_list_idx != NULL_IDX) { 00720 IL_NEXT_LIST_IDX(list2_idx) = false_list_idx; 00721 list1_idx = false_list_idx; 00722 while (list1_idx) { 00723 (IR_LIST_CNT_R(ir_idx))++; 00724 list1_idx = IL_NEXT_LIST_IDX(list1_idx); 00725 } 00726 } 00727 # endif 00728 } 00729 } 00730 00731 defer_stmt_expansion = save_defer_stmt_expansion; 00732 stmt_expansion_control_end(opnd); 00733 00734 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00735 00736 found = TRUE; 00737 break; 00738 } 00739 00740 EXIT: 00741 00742 if (ok && found && (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 00743 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) { 00744 00745 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))) { 00746 00747 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) { 00748 PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx), 00749 AT_OBJ_NAME_PTR(spec_idx), 00750 "pure or elemental", 00751 "pure"); 00752 00753 } 00754 } 00755 else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 00756 00757 if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) { 00758 PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx), 00759 AT_OBJ_NAME_PTR(spec_idx), 00760 "pure or elemental", 00761 "elemental"); 00762 00763 } 00764 } 00765 00766 /* Check to make sure that actual arguments are definable if */ 00767 /* the dummy arg has INTENT(out), INTENT(inout) or POINTER. */ 00768 00769 list_idx = IR_IDX_R(ir_idx); 00770 00771 if (ATP_EXTRA_DARG(spec_idx)) { 00772 arg_idx = ATP_FIRST_IDX(spec_idx) + 1; 00773 idx = ATP_NUM_DARGS(spec_idx) - 1; 00774 } 00775 else { 00776 arg_idx = ATP_FIRST_IDX(spec_idx); 00777 idx = ATP_NUM_DARGS(spec_idx); 00778 } 00779 for (;idx > 0; idx--) { 00780 00781 if (AT_OBJ_CLASS(SN_ATTR_IDX(arg_idx)) == Data_Obj && 00782 (ATD_POINTER(SN_ATTR_IDX(arg_idx)) || 00783 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Inout || 00784 ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Out)) { 00785 COPY_OPND(tmp_opnd, IL_OPND(list_idx)); 00786 attr_idx = find_left_attr(&tmp_opnd); 00787 00788 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)) { 00789 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 00790 &opnd_line, 00791 &opnd_column); 00792 PRINTMSG(opnd_line, 1273, Error, opnd_column, 00793 AT_OBJ_NAME_PTR(attr_idx), 00794 AT_OBJ_NAME_PTR(SN_ATTR_IDX(arg_idx)), 00795 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))?"pure":"elemental"); 00796 ok = FALSE; 00797 00798 00799 } 00800 } 00801 arg_idx++; 00802 list_idx = IL_NEXT_LIST_IDX(list_idx); 00803 } 00804 } 00805 00806 if (found) { 00807 00808 /* If spec is not equal to gen, that means the names are not the same. */ 00809 /* If the names are not the same, then we didn't actually specify the */ 00810 /* specific name, so we don't care if it is invisible. */ 00811 00812 if (spec_idx == gen_idx && AT_NOT_VISIBLE(spec_idx)) { 00813 PRINTMSG(IR_LINE_NUM(ir_idx), 486, Error, 00814 IR_COL_NUM(ir_idx), 00815 AT_OBJ_NAME_PTR(spec_idx), 00816 AT_OBJ_NAME_PTR(AT_MODULE_IDX((spec_idx)))); 00817 *semantically_correct = FALSE; 00818 } 00819 00820 switch (expr_mode) { 00821 case Restricted_Imp_Do_Expr: 00822 case Data_Stmt_Target_Expr: 00823 PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error, 00824 IR_COL_NUM(ir_idx), 00825 str_word); 00826 *semantically_correct = FALSE; 00827 break; 00828 00829 case Specification_Expr: 00830 PRINTMSG(IR_LINE_NUM(ir_idx), 880, Error, 00831 IR_COL_NUM(ir_idx), 00832 str_word); 00833 *semantically_correct = FALSE; 00834 break; 00835 00836 case Stmt_Func_Expr: 00837 PRINTMSG(IR_LINE_NUM(ir_idx), 757, Error, 00838 IR_COL_NUM(ir_idx), 00839 str_word); 00840 *semantically_correct = FALSE; 00841 break; 00842 } 00843 } 00844 else if (issue_msg ) { 00845 00846 if (gen_idx != NULL_IDX) { 00847 PRINTMSG(IR_LINE_NUM(ir_idx), 380, Error, 00848 IR_COL_NUM(ir_idx), str_word); 00849 *semantically_correct = FALSE; 00850 } 00851 else { 00852 00853 if (exp_desc_l->linear_type == Long_Typeless || 00854 (num_args == 2 && exp_desc_r->linear_type == Long_Typeless)) { 00855 00856 if (exp_desc_l->linear_type == Long_Typeless) { 00857 find_opnd_line_and_column((opnd_type *) &IR_OPND_L(ir_idx), 00858 &opnd_line, 00859 &opnd_column); 00860 PRINTMSG(opnd_line, 1133, Error, opnd_column); 00861 *semantically_correct = FALSE; 00862 } 00863 00864 if (num_args == 2 && 00865 exp_desc_r->linear_type == Long_Typeless) { 00866 find_opnd_line_and_column((opnd_type *) &IR_OPND_R(ir_idx), 00867 &opnd_line, 00868 &opnd_column); 00869 PRINTMSG(opnd_line, 1133, Error, opnd_column); 00870 *semantically_correct = FALSE; 00871 } 00872 } 00873 else if (! is_function) { /* assignment */ 00874 00875 if (exp_desc_r->rank != exp_desc_l->rank && exp_desc_r->rank != 0) { 00876 00877 /* rank error */ 00878 00879 PRINTMSG(IR_LINE_NUM(ir_idx), 324, Error, IR_COL_NUM(ir_idx), 00880 exp_desc_r->rank, exp_desc_l->rank); 00881 *semantically_correct = FALSE; 00882 } 00883 00884 if (err_res) { 00885 strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx)); 00886 strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx)); 00887 PRINTMSG(IR_LINE_NUM(ir_idx), 356, Error, 00888 IR_COL_NUM(ir_idx), 00889 type_str_r, 00890 type_str_l); 00891 *semantically_correct = FALSE; 00892 } 00893 } 00894 else if (expr_mode == Restricted_Imp_Do_Expr || 00895 expr_mode == Data_Stmt_Target_Expr) { 00896 00897 PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error, 00898 IR_COL_NUM(ir_idx), str_word); 00899 *semantically_correct = FALSE; 00900 } 00901 else if (num_args == 1) { /* unary operator */ 00902 00903 PRINTMSG(IR_LINE_NUM(ir_idx), 392, Error, 00904 IR_COL_NUM(ir_idx), 00905 get_basic_type_str(exp_desc_l->type_idx), 00906 str_word); 00907 *semantically_correct = FALSE; 00908 } 00909 else { 00910 /* binary operator */ 00911 00912 if (exp_desc_r->rank != exp_desc_l->rank && 00913 exp_desc_r->rank * exp_desc_l->rank != 0) { 00914 00915 /* rank error */ 00916 00917 PRINTMSG(IR_LINE_NUM(ir_idx), 302, Error, IR_COL_NUM(ir_idx), 00918 exp_desc_l->rank, exp_desc_r->rank, str_word); 00919 *semantically_correct = FALSE; 00920 } 00921 00922 if (err_res) { 00923 strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx)); 00924 strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx)); 00925 00926 PRINTMSG(IR_LINE_NUM(ir_idx), 303, Error, 00927 IR_COL_NUM(ir_idx), 00928 type_str_l, 00929 type_str_r, 00930 str_word); 00931 *semantically_correct = FALSE; 00932 } 00933 } 00934 } 00935 } 00936 00937 if (*semantically_correct && 00938 found && 00939 ATP_PROC(spec_idx) != Intrin_Proc) { 00940 00941 if (! ATP_PURE(spec_idx)) { 00942 if (within_forall_mask_expr) { 00943 PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx), 00944 AT_OBJ_NAME_PTR(spec_idx), 00945 "forall scalar-mask-expr"); 00946 *semantically_correct = FALSE; 00947 } 00948 else if (within_forall_construct) { 00949 PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx), 00950 AT_OBJ_NAME_PTR(spec_idx), 00951 "forall-body-construct"); 00952 *semantically_correct = FALSE; 00953 } 00954 } 00955 } 00956 00957 if (found) { 00958 PRINTMSG(IR_LINE_NUM(ir_idx), 399, Comment, IR_COL_NUM(ir_idx), 00959 str_word, AT_OBJ_NAME_PTR(spec_idx)); 00960 } 00961 00962 /* restore arg_info_list to previous "stack frame" */ 00963 00964 arg_info_list_top = arg_info_list_base; 00965 arg_info_list_base = save_arg_info_list_base; 00966 00967 TRACE (Func_Exit, "resolve_ext_opr", NULL); 00968 00969 return(found); 00970 00971 } /* resolve_ext_opr */ 00972 00973 /******************************************************************************\ 00974 |* *| 00975 |* Description: *| 00976 |* Return a string for any expression opr. *| 00977 |* *| 00978 |* Input parameters: *| 00979 |* opr - the operator. *| 00980 |* *| 00981 |* Output parameters: *| 00982 |* str - the string. *| 00983 |* *| 00984 |* Returns: *| 00985 |* length of str *| 00986 |* *| 00987 \******************************************************************************/ 00988 00989 static int opr_to_str(operator_type opr, 00990 char *str) 00991 00992 { 00993 int i; 00994 int len = 0; 00995 00996 TRACE (Func_Entry, "opr_to_str", NULL); 00997 00998 for (i = 0; i < 8; i++) { 00999 str[i] = '\0'; 01000 } 01001 01002 switch (opr) { 01003 case Uplus_Opr : 01004 strncpy(str, "+", 1); 01005 len = 1; 01006 break; 01007 case Uminus_Opr : 01008 strncpy(str, "-", 1); 01009 len = 1; 01010 break; 01011 case Power_Opr : 01012 strncpy(str, "**", 2); 01013 len = 2; 01014 break; 01015 case Mult_Opr : 01016 strncpy(str, "*", 1); 01017 len = 1; 01018 break; 01019 case Div_Opr : 01020 strncpy(str, "/", 1); 01021 len = 1; 01022 break; 01023 case Plus_Opr : 01024 strncpy(str, "+", 1); 01025 len = 1; 01026 break; 01027 case Minus_Opr : 01028 strncpy(str, "-", 1); 01029 len = 1; 01030 break; 01031 case Concat_Opr : 01032 strncpy(str, "//", 2); 01033 len = 2; 01034 break; 01035 case Eq_Opr : 01036 strncpy(str, "eq", 2); 01037 len = 2; 01038 break; 01039 case Ne_Opr : 01040 strncpy(str, "ne", 2); 01041 len = 2; 01042 break; 01043 case Lg_Opr : 01044 strncpy(str, "lg", 2); 01045 len = 2; 01046 break; 01047 case Lt_Opr : 01048 strncpy(str, "lt", 2); 01049 len = 2; 01050 break; 01051 case Le_Opr : 01052 strncpy(str, "le", 2); 01053 len = 2; 01054 break; 01055 case Gt_Opr : 01056 strncpy(str, "gt", 2); 01057 len = 2; 01058 break; 01059 case Ge_Opr : 01060 strncpy(str, "ge", 2); 01061 len = 2; 01062 break; 01063 case Not_Opr : 01064 strncpy(str, "not", 3); 01065 len = 3; 01066 break; 01067 case And_Opr : 01068 strncpy(str, "and", 3); 01069 len = 3; 01070 break; 01071 case Or_Opr : 01072 strncpy(str, "or", 2); 01073 len = 2; 01074 break; 01075 case Eqv_Opr : 01076 strncpy(str, "eqv", 3); 01077 len = 3; 01078 break; 01079 case Neqv_Opr : 01080 strncpy(str, "neqv", 4); 01081 len = 4; 01082 break; 01083 case Asg_Opr : 01084 strncpy(str, "=", 1); 01085 len = 1; 01086 break; 01087 } 01088 01089 TRACE (Func_Exit, "opr_to_str", NULL); 01090 01091 return(len); 01092 01093 } /* opr_to_str */ 01094 01095 /******************************************************************************\ 01096 |* *| 01097 |* Description: *| 01098 |* finds the base attr pointer from reference tree. *| 01099 |* The difference between find_base_attr and find_left_attr is: *| 01100 |* *| 01101 |* a%b%c(1:10)(1:3) *| 01102 |* *| 01103 |* find_base_attr finds 'c' *| 01104 |* find_left_attr finds 'a' *| 01105 |* *| 01106 |* Input parameters: *| 01107 |* NONE *| 01108 |* *| 01109 |* Output parameters: *| 01110 |* NONE *| 01111 |* *| 01112 |* Returns: *| 01113 |* NOTHING *| 01114 |* *| 01115 \******************************************************************************/ 01116 01117 int find_base_attr(opnd_type *root_opnd, 01118 int *line, 01119 int *col) 01120 01121 { 01122 int attr_idx = NULL_IDX; 01123 opnd_type opnd; 01124 01125 TRACE (Func_Entry, "find_base_attr", NULL); 01126 01127 *line = 0; 01128 *col = 0; 01129 01130 COPY_OPND(opnd, (*root_opnd)); 01131 01132 while (attr_idx == NULL_IDX) { 01133 switch (OPND_FLD(opnd)) { 01134 case AT_Tbl_Idx : 01135 attr_idx = OPND_IDX(opnd); 01136 *line = OPND_LINE_NUM(opnd); 01137 *col = OPND_COL_NUM(opnd); 01138 goto EXIT; 01139 01140 case IR_Tbl_Idx : 01141 01142 if (IR_OPR(OPND_IDX(opnd)) == Struct_Opr) { 01143 COPY_OPND(opnd, IR_OPND_R(OPND_IDX(opnd))); 01144 } 01145 else { 01146 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 01147 } 01148 break; 01149 01150 case CN_Tbl_Idx : 01151 *line = OPND_LINE_NUM(opnd); 01152 *col = OPND_COL_NUM(opnd); 01153 goto EXIT; 01154 01155 default : 01156 goto EXIT; 01157 } 01158 } 01159 01160 EXIT: 01161 01162 TRACE (Func_Exit, "find_base_attr", ((attr_idx == NULL_IDX) ? NULL : 01163 AT_OBJ_NAME_PTR(attr_idx))); 01164 01165 return(attr_idx); 01166 01167 } /* find_base_attr */ 01168 01169 /******************************************************************************\ 01170 |* *| 01171 |* Description: *| 01172 |* Find the left most attr in a reference tree. *| 01173 |* *| 01174 |* The difference between find_base_attr and find_left_attr is: *| 01175 |* *| 01176 |* a%b%c(1:10)(1:3) *| 01177 |* *| 01178 |* find_base_attr finds 'c' *| 01179 |* find_left_attr finds 'a' *| 01180 |* *| 01181 |* Input parameters: *| 01182 |* NONE *| 01183 |* *| 01184 |* Output parameters: *| 01185 |* NONE *| 01186 |* *| 01187 |* Returns: *| 01188 |* NOTHING *| 01189 |* *| 01190 \******************************************************************************/ 01191 01192 int find_left_attr(opnd_type *root_opnd) 01193 01194 { 01195 int attr_idx = NULL_IDX; 01196 opnd_type opnd; 01197 01198 01199 TRACE (Func_Entry, "find_left_attr", NULL); 01200 01201 COPY_OPND(opnd, (*root_opnd)); 01202 01203 while (attr_idx == NULL_IDX) { 01204 switch (OPND_FLD(opnd)) { 01205 case AT_Tbl_Idx : 01206 attr_idx = OPND_IDX(opnd); 01207 goto EXIT; 01208 01209 case IR_Tbl_Idx : 01210 01211 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 01212 break; 01213 01214 default : 01215 goto EXIT; 01216 } 01217 } 01218 01219 EXIT: 01220 01221 TRACE (Func_Exit, "find_left_attr", NULL); 01222 01223 return(attr_idx); 01224 01225 } /* find_left_attr */ 01226 01227 /******************************************************************************\ 01228 |* *| 01229 |* Description: *| 01230 |* Compares reference subtrees to see if they reference the same object. *| 01231 |* *| 01232 |* Input parameters: *| 01233 |* opnd1, opnd2 - the roots of the two trees. *| 01234 |* *| 01235 |* Output parameters: *| 01236 |* NONE *| 01237 |* *| 01238 |* Returns: *| 01239 |* TRUE for match. *| 01240 |* *| 01241 \******************************************************************************/ 01242 01243 boolean cmp_ref_trees(opnd_type *opnd1, 01244 opnd_type *opnd2) 01245 01246 { 01247 int column; 01248 int line; 01249 int list1_idx; 01250 int list2_idx; 01251 boolean match = TRUE; 01252 01253 01254 TRACE (Func_Entry, "cmp_ref_trees", NULL); 01255 01256 if (OPND_FLD((*opnd1)) != OPND_FLD((*opnd2))) { 01257 match = FALSE; 01258 } 01259 else { 01260 switch(OPND_FLD((*opnd1))) { 01261 case NO_Tbl_Idx : 01262 match = TRUE; 01263 break; 01264 01265 case CN_Tbl_Idx : 01266 case AT_Tbl_Idx : 01267 01268 if (OPND_IDX((*opnd1)) == OPND_IDX((*opnd2))) { 01269 match = TRUE; 01270 } 01271 else { 01272 match = FALSE; 01273 } 01274 break; 01275 01276 case IL_Tbl_Idx : 01277 01278 if (OPND_LIST_CNT((*opnd1)) == OPND_LIST_CNT((*opnd2))) { 01279 list1_idx = OPND_IDX((*opnd1)); 01280 list2_idx = OPND_IDX((*opnd2)); 01281 01282 while (list1_idx != NULL_IDX && match) { 01283 match = cmp_ref_trees((opnd_type *)&IL_OPND(list1_idx), 01284 (opnd_type *)&IL_OPND(list2_idx)); 01285 list1_idx = IL_NEXT_LIST_IDX(list1_idx); 01286 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 01287 } 01288 } 01289 else { 01290 match = FALSE; 01291 } 01292 break; 01293 01294 case SH_Tbl_Idx : 01295 find_opnd_line_and_column(opnd1, &line, &column); 01296 PRINTMSG(line, 963, Internal, column); 01297 break; 01298 01299 case IR_Tbl_Idx : 01300 01301 if (IR_OPR(OPND_IDX((*opnd1))) == IR_OPR(OPND_IDX((*opnd2)))) { 01302 match = cmp_ref_trees((opnd_type*)&IR_OPND_L(OPND_IDX((*opnd1))), 01303 (opnd_type*)&IR_OPND_L(OPND_IDX((*opnd2)))); 01304 match = match && 01305 cmp_ref_trees((opnd_type *)&IR_OPND_R(OPND_IDX((*opnd1))), 01306 (opnd_type *)&IR_OPND_R(OPND_IDX((*opnd2)))); 01307 } 01308 else { 01309 match = FALSE; 01310 } 01311 break; 01312 } 01313 } 01314 01315 TRACE (Func_Exit, "cmp_ref_trees", NULL); 01316 01317 return(match); 01318 01319 } /* cmp_ref_trees */ 01320 01321 /******************************************************************************\ 01322 |* *| 01323 |* Description: *| 01324 |* malloc or realloc the call list arrays. *| 01325 |* *| 01326 |* Input parameters: *| 01327 |* NONE *| 01328 |* *| 01329 |* Output parameters: *| 01330 |* NONE *| 01331 |* *| 01332 |* Returns: *| 01333 |* NOTHING *| 01334 |* *| 01335 \******************************************************************************/ 01336 01337 void enlarge_call_list_tables(void) 01338 01339 { 01340 int new_size; 01341 01342 TRACE (Func_Entry, "enlarge_call_list_tables", NULL); 01343 01344 /* CALL_LIST_TBL_INC defined in s_utils.m */ 01345 new_size = ((max_call_list_size/CALL_LIST_TBL_INC) + 1) 01346 * CALL_LIST_TBL_INC; 01347 01348 if (arg_list_size == 0) { 01349 01350 /* must do original malloc */ 01351 01352 MEM_ALLOC(arg_list, int, new_size); 01353 01354 } 01355 else { /* do realloc */ 01356 01357 MEM_REALLOC(arg_list, int, new_size); 01358 01359 } 01360 01361 arg_list_size = new_size; 01362 01363 TRACE (Func_Exit, "enlarge_call_list_tables", NULL); 01364 01365 return; 01366 01367 } /* enlarge_call_list_tables */ 01368 01369 /******************************************************************************\ 01370 |* *| 01371 |* Description: *| 01372 |* Table manager for arg_info_list table. *| 01373 |* *| 01374 |* Input parameters: *| 01375 |* NONE *| 01376 |* *| 01377 |* Output parameters: *| 01378 |* NONE *| 01379 |* *| 01380 |* Returns: *| 01381 |* NOTHING *| 01382 |* *| 01383 \******************************************************************************/ 01384 01385 void enlarge_info_list_table(void) 01386 01387 { 01388 int new_size; 01389 01390 TRACE (Func_Entry, "enlarge_info_list_table", NULL); 01391 01392 /* CALL_LIST_TBL_INC defined in s_utils.m */ 01393 new_size = arg_info_list_size + ((max_call_list_size/CALL_LIST_TBL_INC) + 1) 01394 * CALL_LIST_TBL_INC; 01395 01396 if (arg_info_list_size == 0) { 01397 01398 /* must do original malloc */ 01399 01400 MEM_ALLOC(arg_info_list, arg_strct_type, new_size); 01401 01402 } 01403 else { /* do realloc */ 01404 01405 MEM_REALLOC(arg_info_list, arg_strct_type, new_size); 01406 01407 } 01408 01409 arg_info_list_size = new_size; 01410 01411 TRACE (Func_Exit, "enlarge_info_list_table", NULL); 01412 01413 return; 01414 01415 } /* enlarge_info_list_table */ 01416 01417 /******************************************************************************\ 01418 |* *| 01419 |* Description: *| 01420 |* Creates all the dope vector assignments for a ptr assign from a target*| 01421 |* *| 01422 |* Input parameters: *| 01423 |* NONE *| 01424 |* *| 01425 |* Output parameters: *| 01426 |* NONE *| 01427 |* *| 01428 |* Returns: *| 01429 |* NOTHING *| 01430 |* *| 01431 \******************************************************************************/ 01432 01433 void dope_vector_setup(opnd_type *r_opnd, 01434 expr_arg_type *exp_desc, 01435 opnd_type *l_opnd, 01436 boolean ptr_assign) 01437 01438 { 01439 act_arg_type a_type; 01440 int attr_idx = NULL_IDX; 01441 opnd_type base_opnd; 01442 int col; 01443 int dim = 1; 01444 int dope_idx = NULL_IDX; 01445 int dv_idx; 01446 int dv2_idx; 01447 int i; 01448 int line; 01449 int list_idx; 01450 int loc_idx; 01451 int max_idx; 01452 int mult_idx; 01453 opnd_type opnd; 01454 int opnd_column; 01455 int opnd_line; 01456 opnd_type r_dv_opnd; 01457 int rank_idx = NULL_IDX; 01458 int stride_idx; 01459 opnd_type stride_opnd; 01460 int subscript_idx; 01461 boolean whole_array; 01462 01463 01464 TRACE (Func_Entry, "dope_vector_setup", NULL); 01465 01466 /* This routine expects the left operand to be a dope vector */ 01467 /* reference. Either an attr or a Struct_Opr */ 01468 01469 find_opnd_line_and_column(l_opnd, &opnd_line, &opnd_column); 01470 01471 # ifdef _DEBUG 01472 01473 if (OPND_FLD((*l_opnd)) != AT_Tbl_Idx && 01474 (OPND_FLD((*l_opnd)) != IR_Tbl_Idx || 01475 IR_OPR(OPND_IDX((*l_opnd))) != Struct_Opr)) { 01476 PRINTMSG(opnd_line, 624, Internal, opnd_column); 01477 } 01478 # endif 01479 /********************\ 01480 |* set BASE address *| 01481 \********************/ 01482 01483 01484 if (! ptr_assign) { 01485 NTR_IR_TBL(dv_idx); 01486 IR_OPR(dv_idx) = Dv_Set_Base_Addr; 01487 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01488 IR_LINE_NUM(dv_idx) = opnd_line; 01489 IR_COL_NUM(dv_idx) = opnd_column; 01490 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01491 NTR_IR_TBL(loc_idx); 01492 IR_OPR(loc_idx) = Loc_Opr; 01493 01494 if (exp_desc->type == Character) { 01495 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 01496 } 01497 else { 01498 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 01499 } 01500 01501 IR_LINE_NUM(loc_idx) = opnd_line; 01502 IR_COL_NUM(loc_idx) = opnd_column; 01503 01504 IR_FLD_R(dv_idx) = IR_Tbl_Idx; 01505 IR_IDX_R(dv_idx) = loc_idx; 01506 01507 if (exp_desc->rank == 0) { 01508 COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd)); 01509 just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx); 01510 } 01511 else { 01512 make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx); 01513 COPY_OPND(IR_OPND_L(loc_idx), base_opnd); 01514 } 01515 01516 # ifdef _TRANSFORM_CHAR_SEQUENCE 01517 # ifdef _TARGET_OS_UNICOS 01518 if (exp_desc->type == Structure && 01519 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) { 01520 01521 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 01522 COPY_OPND(opnd, IR_OPND_L(loc_idx)); 01523 transform_char_sequence_ref(&opnd, exp_desc->type_idx); 01524 COPY_OPND(IR_OPND_L(loc_idx), opnd); 01525 } 01526 # endif 01527 # endif 01528 01529 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01530 FALSE, FALSE, TRUE); 01531 01532 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01533 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01534 01535 } 01536 else { 01537 just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx); 01538 } 01539 01540 01541 /*************************\ 01542 |* check for whole array *| 01543 \*************************/ 01544 01545 if (rank_idx != NULL_IDX) { 01546 attr_idx = find_base_attr(&IR_OPND_L(rank_idx), &line, &col); 01547 01548 if (ATD_IM_A_DOPE(attr_idx)) { 01549 COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx))); 01550 } 01551 subscript_idx = IR_IDX_R(rank_idx); 01552 } 01553 else if (exp_desc->rank != 0) { 01554 attr_idx = find_base_attr(r_opnd, &line, &col); 01555 01556 if (ATD_IM_A_DOPE(attr_idx)) { 01557 COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd)))); 01558 } 01559 } 01560 else { 01561 find_opnd_line_and_column(r_opnd, &line, &col); 01562 } 01563 01564 if (exp_desc->rank > 0 && 01565 ! exp_desc->section) { 01566 01567 whole_array = TRUE; 01568 } 01569 else { 01570 whole_array = FALSE; 01571 } 01572 01573 /*************************\ 01574 |* set the a_contig flag *| 01575 \*************************/ 01576 01577 a_type = get_act_arg_type(exp_desc); 01578 01579 if (a_type == Array_Ptr || 01580 a_type == Array_Tmp_Ptr || 01581 a_type == Whole_Ass_Shape || 01582 a_type == Dv_Contig_Section) { 01583 01584 NTR_IR_TBL(dv_idx); 01585 IR_OPR(dv_idx) = Dv_Set_A_Contig; 01586 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01587 IR_LINE_NUM(dv_idx) = opnd_line; 01588 IR_COL_NUM(dv_idx) = opnd_column; 01589 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01590 01591 NTR_IR_TBL(dv2_idx); 01592 IR_OPR(dv2_idx) = Dv_Access_A_Contig; 01593 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE; 01594 IR_LINE_NUM(dv2_idx) = opnd_line; 01595 IR_COL_NUM(dv2_idx) = opnd_column; 01596 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 01597 IR_FLD_R(dv_idx) = IR_Tbl_Idx; 01598 IR_IDX_R(dv_idx) = dv2_idx; 01599 01600 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01601 FALSE, FALSE, TRUE); 01602 01603 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01604 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01605 01606 } 01607 else if (a_type == Whole_Allocatable || 01608 a_type == Whole_Tmp_Allocatable || 01609 a_type == Whole_Sequence || 01610 a_type == Whole_Tmp_Sequence || 01611 a_type == Whole_Array_Constant || 01612 a_type == Contig_Section) { 01613 01614 NTR_IR_TBL(dv_idx); 01615 IR_OPR(dv_idx) = Dv_Set_A_Contig; 01616 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01617 IR_LINE_NUM(dv_idx) = opnd_line; 01618 IR_COL_NUM(dv_idx) = opnd_column; 01619 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01620 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 01621 IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX; 01622 IR_LINE_NUM_R(dv_idx) = opnd_line; 01623 IR_COL_NUM_R(dv_idx) = opnd_column; 01624 01625 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01626 FALSE, FALSE, TRUE); 01627 01628 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01629 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01630 } 01631 else { 01632 NTR_IR_TBL(dv_idx); 01633 IR_OPR(dv_idx) = Dv_Set_A_Contig; 01634 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01635 IR_LINE_NUM(dv_idx) = opnd_line; 01636 IR_COL_NUM(dv_idx) = opnd_column; 01637 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01638 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 01639 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX; 01640 IR_LINE_NUM_R(dv_idx) = opnd_line; 01641 IR_COL_NUM_R(dv_idx) = opnd_column; 01642 01643 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01644 FALSE, FALSE, TRUE); 01645 01646 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01647 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01648 } 01649 01650 /******************\ 01651 |* set ASSOC flag *| 01652 \******************/ 01653 01654 NTR_IR_TBL(dv_idx); 01655 IR_OPR(dv_idx) = Dv_Set_Assoc; 01656 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01657 IR_LINE_NUM(dv_idx) = opnd_line; 01658 IR_COL_NUM(dv_idx) = opnd_column; 01659 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01660 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 01661 IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX; 01662 IR_LINE_NUM_R(dv_idx) = opnd_line; 01663 IR_COL_NUM_R(dv_idx) = opnd_column; 01664 01665 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01666 FALSE, FALSE, TRUE); 01667 01668 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01669 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01670 01671 01672 for (i = 1; i <= exp_desc->rank; i++) { 01673 01674 /************************************\ 01675 |* set LOW_BOUND for each dimension *| 01676 \************************************/ 01677 01678 NTR_IR_TBL(dv_idx); 01679 IR_OPR(dv_idx) = Dv_Set_Low_Bound; 01680 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01681 IR_LINE_NUM(dv_idx) = opnd_line; 01682 IR_COL_NUM(dv_idx) = opnd_column; 01683 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01684 01685 if (whole_array) { 01686 /* need arrays low bound */ 01687 if (ATD_IM_A_DOPE(attr_idx) && 01688 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Assumed_Shape) { 01689 NTR_IR_TBL(dv2_idx); 01690 IR_OPR(dv2_idx) = Dv_Access_Low_Bound; 01691 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE; 01692 IR_LINE_NUM(dv2_idx) = opnd_line; 01693 IR_COL_NUM(dv2_idx) = opnd_column; 01694 COPY_OPND(IR_OPND_L(dv2_idx), r_dv_opnd); 01695 IR_DV_DIM(dv2_idx) = i; 01696 IR_FLD_R(dv_idx) = IR_Tbl_Idx; 01697 IR_IDX_R(dv_idx) = dv2_idx; 01698 } 01699 else { 01700 IR_FLD_R(dv_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i); 01701 IR_IDX_R(dv_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i); 01702 IR_LINE_NUM_R(dv_idx) = opnd_line; 01703 IR_COL_NUM_R(dv_idx) = opnd_column; 01704 01705 if (IR_FLD_R(dv_idx) == AT_Tbl_Idx) { 01706 ADD_TMP_TO_SHARED_LIST(IR_IDX_R(dv_idx)); 01707 } 01708 } 01709 } 01710 else { 01711 /* set to one */ 01712 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 01713 IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX; 01714 IR_LINE_NUM_R(dv_idx) = opnd_line; 01715 IR_COL_NUM_R(dv_idx) = opnd_column; 01716 } 01717 01718 IR_DV_DIM(dv_idx) = i; 01719 01720 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01721 FALSE, FALSE, TRUE); 01722 01723 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01724 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01725 01726 01727 /*********************************\ 01728 |* set EXTENT for each dimension *| 01729 \*********************************/ 01730 01731 NTR_IR_TBL(dv_idx); 01732 IR_OPR(dv_idx) = Dv_Set_Extent; 01733 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01734 IR_LINE_NUM(dv_idx) = opnd_line; 01735 IR_COL_NUM(dv_idx) = opnd_column; 01736 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01737 01738 NTR_IR_TBL(max_idx); 01739 IR_OPR(max_idx) = Max_Opr; 01740 IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE; 01741 IR_LINE_NUM(max_idx) = opnd_line; 01742 IR_COL_NUM(max_idx) = opnd_column; 01743 01744 NTR_IR_LIST_TBL(list_idx); 01745 IR_FLD_L(max_idx) = IL_Tbl_Idx; 01746 IR_LIST_CNT_L(max_idx) = 2; 01747 IR_IDX_L(max_idx) = list_idx; 01748 01749 IL_FLD(list_idx) = CN_Tbl_Idx; 01750 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 01751 IL_LINE_NUM(list_idx) = opnd_line; 01752 IL_COL_NUM(list_idx) = opnd_column; 01753 01754 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01755 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01756 list_idx = IL_NEXT_LIST_IDX(list_idx); 01757 01758 COPY_OPND(IL_OPND(list_idx), exp_desc->shape[i-1]); 01759 IL_LINE_NUM(list_idx) = opnd_line; 01760 IL_COL_NUM(list_idx) = opnd_column; 01761 01762 IR_FLD_R(dv_idx) = IR_Tbl_Idx; 01763 IR_IDX_R(dv_idx) = max_idx; 01764 01765 IR_DV_DIM(dv_idx) = i; 01766 01767 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01768 FALSE, FALSE, TRUE); 01769 01770 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01771 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01772 01773 /**************************************\ 01774 |* set STRIDE_MULT for each dimension *| 01775 \**************************************/ 01776 01777 NTR_IR_TBL(dv_idx); 01778 IR_OPR(dv_idx) = Dv_Set_Stride_Mult; 01779 IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE; 01780 IR_LINE_NUM(dv_idx) = opnd_line; 01781 IR_COL_NUM(dv_idx) = opnd_column; 01782 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01783 01784 if (whole_array) { 01785 01786 gen_dv_stride_mult(&stride_opnd, 01787 attr_idx, 01788 &r_dv_opnd, 01789 exp_desc, 01790 i, 01791 opnd_line, 01792 opnd_column); 01793 01794 COPY_OPND(IR_OPND_R(dv_idx), stride_opnd); 01795 } 01796 else { 01797 while (IL_FLD(subscript_idx) != IR_Tbl_Idx || 01798 IR_OPR(IL_IDX(subscript_idx)) != Triplet_Opr) { 01799 subscript_idx = IL_NEXT_LIST_IDX(subscript_idx); 01800 dim++; 01801 } 01802 01803 gen_dv_stride_mult(&stride_opnd, 01804 attr_idx, 01805 &r_dv_opnd, 01806 exp_desc, 01807 dim, 01808 opnd_line, 01809 opnd_column); 01810 01811 stride_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L( 01812 IL_IDX(subscript_idx)))); 01813 mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd), 01814 Mult_Opr, CG_INTEGER_DEFAULT_TYPE, opnd_line, opnd_column, 01815 IL_FLD(stride_idx), IL_IDX(stride_idx)); 01816 01817 IR_FLD_R(dv_idx) = IR_Tbl_Idx;; 01818 IR_IDX_R(dv_idx) = mult_idx; 01819 01820 subscript_idx = IL_NEXT_LIST_IDX(subscript_idx); 01821 dim++; 01822 } 01823 01824 IR_DV_DIM(dv_idx) = i; 01825 01826 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01827 FALSE, FALSE, TRUE); 01828 01829 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01830 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01831 01832 } 01833 01834 /*******************\ 01835 |* clear PTR_ALLOC *| 01836 \*******************/ 01837 01838 NTR_IR_TBL(dv_idx); 01839 IR_OPR(dv_idx) = Dv_Set_Ptr_Alloc; 01840 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01841 IR_LINE_NUM(dv_idx) = opnd_line; 01842 IR_COL_NUM(dv_idx) = opnd_column; 01843 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01844 01845 if (dope_idx != NULL_IDX) { 01846 NTR_IR_TBL(dv2_idx); 01847 IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc; 01848 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE; 01849 IR_LINE_NUM(dv2_idx) = opnd_line; 01850 IR_COL_NUM(dv2_idx) = opnd_column; 01851 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 01852 IR_FLD_R(dv_idx) = IR_Tbl_Idx; 01853 IR_IDX_R(dv_idx) = dv2_idx; 01854 } 01855 else { 01856 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 01857 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX; 01858 IR_LINE_NUM_R(dv_idx) = opnd_line; 01859 IR_COL_NUM_R(dv_idx) = opnd_column; 01860 } 01861 01862 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01863 FALSE, FALSE, TRUE); 01864 01865 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01866 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01867 01868 /*******************\ 01869 |* clear ORIG_BASE *| 01870 \*******************/ 01871 01872 NTR_IR_TBL(dv_idx); 01873 IR_OPR(dv_idx) = Dv_Set_Orig_Base; 01874 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01875 IR_LINE_NUM(dv_idx) = opnd_line; 01876 IR_COL_NUM(dv_idx) = opnd_column; 01877 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01878 01879 if (dope_idx != NULL_IDX) { 01880 NTR_IR_TBL(dv2_idx); 01881 IR_OPR(dv2_idx) = Dv_Access_Orig_Base; 01882 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE; 01883 IR_LINE_NUM(dv2_idx) = opnd_line; 01884 IR_COL_NUM(dv2_idx) = opnd_column; 01885 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 01886 IR_FLD_R(dv_idx) = IR_Tbl_Idx; 01887 IR_IDX_R(dv_idx) = dv2_idx; 01888 } 01889 else { 01890 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 01891 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX; 01892 IR_LINE_NUM_R(dv_idx) = opnd_line; 01893 IR_COL_NUM_R(dv_idx) = opnd_column; 01894 } 01895 01896 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01897 FALSE, FALSE, TRUE); 01898 01899 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01900 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01901 01902 /*******************\ 01903 |* clear ORIG_SIZE *| 01904 \*******************/ 01905 01906 NTR_IR_TBL(dv_idx); 01907 IR_OPR(dv_idx) = Dv_Set_Orig_Size; 01908 IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE; 01909 IR_LINE_NUM(dv_idx) = opnd_line; 01910 IR_COL_NUM(dv_idx) = opnd_column; 01911 COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd)); 01912 01913 if (dope_idx != NULL_IDX) { 01914 NTR_IR_TBL(dv2_idx); 01915 IR_OPR(dv2_idx) = Dv_Access_Orig_Size; 01916 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE; 01917 IR_LINE_NUM(dv2_idx) = opnd_line; 01918 IR_COL_NUM(dv2_idx) = opnd_column; 01919 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 01920 IR_FLD_R(dv_idx) = IR_Tbl_Idx; 01921 IR_IDX_R(dv_idx) = dv2_idx; 01922 } 01923 else { 01924 IR_FLD_R(dv_idx) = CN_Tbl_Idx; 01925 IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX; 01926 IR_LINE_NUM_R(dv_idx) = opnd_line; 01927 IR_COL_NUM_R(dv_idx) = opnd_column; 01928 } 01929 01930 gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col, 01931 FALSE, FALSE, TRUE); 01932 01933 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx; 01934 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01935 01936 TRACE (Func_Exit, "dope_vector_setup", NULL); 01937 01938 return; 01939 01940 } /* dope_vector_setup */ 01941 01942 /******************************************************************************\ 01943 |* *| 01944 |* Description: *| 01945 |* Given the input type, an io type code is assembled. *| 01946 |* *| 01947 |* Input parameters: *| 01948 |* type_idx - index into type table *| 01949 |* *| 01950 |* Output parameters: *| 01951 |* value - pointer to either a long or a 2 word array of longs. *| 01952 |* *| 01953 |* Returns: *| 01954 |* NOTHING *| 01955 |* *| 01956 \******************************************************************************/ 01957 01958 void make_io_type_code(int type_idx, /* BRIANJ */ 01959 long_type *value) 01960 01961 { 01962 long_type dec_len = 0; 01963 int dp_flag = 0; 01964 int dv_type; 01965 long_type int_len = 0; 01966 int kind_star = 0; 01967 01968 f90_type_t *type_code; 01969 01970 01971 TRACE (Func_Entry, "make_io_type_code", NULL); 01972 01973 switch(TYP_DESC(type_idx)) { 01974 case Default_Typed: 01975 kind_star = DV_DEFAULT_TYPED; 01976 break; 01977 01978 case Star_Typed: 01979 kind_star = DV_STAR_TYPED; 01980 break; 01981 01982 case Kind_Typed: 01983 if (TYP_TYPE(type_idx) == Real && 01984 TYP_KIND_DOUBLE(type_idx)) { 01985 kind_star = DV_KIND_DOUBLE; 01986 } 01987 else if (TYP_KIND_CONST(type_idx)) { 01988 kind_star = DV_KIND_CONST; 01989 } 01990 else { 01991 kind_star = DV_KIND_TYPED; 01992 } 01993 break; 01994 } 01995 01996 # ifndef _TARGET_OS_MAX 01997 if (TYP_DECLARED_DBL(type_idx) && 01998 kind_star == DV_DEFAULT_TYPED) { 01999 02000 dp_flag = 1; 02001 } 02002 # endif 02003 02004 switch (TYP_TYPE(type_idx)) { 02005 case Typeless: 02006 02007 /* BRIANJ - These could be long64 type */ 02008 02009 dec_len = (long) TYP_BIT_LEN(type_idx) / TARGET_BYTES_PER_WORD; 02010 int_len = (long) TYP_BIT_LEN(type_idx); 02011 dv_type = DV_TYPELESS; 02012 02013 break; 02014 02015 case Integer: 02016 02017 dec_len = (long) TYP_DCL_VALUE(type_idx); 02018 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 02019 dv_type = DV_INTEGER; 02020 02021 break; 02022 02023 case Logical: 02024 02025 dec_len = (long) TYP_DCL_VALUE(type_idx); 02026 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 02027 dv_type = DV_LOGICAL; 02028 02029 break; 02030 02031 case Real: 02032 02033 dec_len = (long) TYP_DCL_VALUE(type_idx); 02034 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 02035 dv_type = DV_REAL; 02036 02037 break; 02038 02039 case Complex: 02040 02041 dec_len = (long) TYP_DCL_VALUE(type_idx); 02042 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 02043 dv_type = DV_COMPLEX; 02044 02045 break; 02046 02047 case Character: 02048 02049 if (kind_star == DV_DEFAULT_TYPED) { 02050 dec_len = 0; 02051 } 02052 else { 02053 dec_len = 1; 02054 } 02055 int_len = 8; 02056 dv_type = DV_ASCII_CHAR; 02057 02058 break; 02059 02060 case Structure: 02061 02062 if (ATT_CHAR_SEQ(TYP_IDX(type_idx))) { 02063 dv_type = DV_ASCII_CHAR_SEQUENCE_STRUCT; 02064 } 02065 else { 02066 dv_type = DV_STRUCT; 02067 } 02068 02069 break; 02070 02071 case CRI_Ptr: 02072 case CRI_Ch_Ptr: 02073 02074 int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 02075 dv_type = DV_INTEGER; 02076 02077 break; 02078 } 02079 02080 # ifdef _TYPE_CODE_64_BIT 02081 type_code = (f90_type_t *)value; 02082 02083 type_code->unused = 0; 02084 type_code->type = dv_type; 02085 type_code->dpflag = dp_flag; 02086 type_code->kind_or_star = kind_star; 02087 type_code->int_len = int_len; 02088 type_code->dec_len = dec_len; 02089 # else 02090 02091 *value = ((dv_type << DV_TYPE_SHIFT) | 02092 (dp_flag << DV_DP_SHIFT) | 02093 (kind_star << DV_KIND_STAR_SHIFT) | 02094 (int_len << DV_INT_LEN_SHIFT) | 02095 (dec_len << DV_DEC_LEN_SHIFT)); 02096 # endif 02097 02098 TRACE (Func_Exit, "make_io_type_code", NULL); 02099 02100 return; 02101 02102 } /* make_io_type_code */ 02103 02104 /******************************************************************************\ 02105 |* *| 02106 |* Description: *| 02107 |* This routine creates a constant table entry for a dope vector type *| 02108 |* code. *| 02109 |* *| 02110 |* Input parameters: *| 02111 |* attr_idx - index for attr. *| 02112 |* *| 02113 |* Output parameters: *| 02114 |* NONE *| 02115 |* *| 02116 |* Returns: *| 02117 |* constant table idx for type code. *| 02118 |* *| 02119 \******************************************************************************/ 02120 02121 static int create_dv_type_code(int attr_idx) 02122 02123 { 02124 int constant_idx = NULL_IDX; 02125 long_type constant[2]; 02126 02127 TRACE (Func_Entry, "create_dv_type_code", NULL); 02128 02129 make_io_type_code(ATD_TYPE_IDX(attr_idx), constant); 02130 02131 constant_idx = ntr_const_tbl(IO_TYPE_CODE_TYPE, FALSE, constant); 02132 02133 TRACE (Func_Exit, "create_dv_type_code", NULL); 02134 02135 return(constant_idx); 02136 02137 } /* create_dv_type_code */ 02138 02139 /******************************************************************************\ 02140 |* *| 02141 |* Description: *| 02142 |* <description> *| 02143 |* *| 02144 |* Input parameters: *| 02145 |* NONE *| 02146 |* *| 02147 |* Output parameters: *| 02148 |* NONE *| 02149 |* *| 02150 |* Returns: *| 02151 |* NOTHING *| 02152 |* *| 02153 \******************************************************************************/ 02154 02155 void gen_common_dv_init(opnd_type *dv_opnd, 02156 int dv_attr_idx, 02157 sh_position_type position) 02158 02159 { 02160 int col; 02161 int ir_idx; 02162 size_offset_type length; 02163 int line; 02164 int mult_idx; 02165 size_offset_type result; 02166 int type_idx; 02167 02168 02169 TRACE (Func_Entry, "gen_common_dv_init", NULL); 02170 02171 find_opnd_line_and_column(dv_opnd, &line, &col); 02172 02173 /*************\ 02174 |* BASE ADDR *| 02175 \*************/ 02176 02177 /* Do not set */ 02178 02179 /*************\ 02180 |* EL_LEN *| 02181 \*************/ 02182 02183 NTR_IR_TBL(ir_idx); 02184 IR_OPR(ir_idx) = Dv_Set_El_Len; 02185 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 02186 IR_LINE_NUM(ir_idx) = line; 02187 IR_COL_NUM(ir_idx) = col; 02188 02189 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd)); 02190 02191 type_idx = ATD_TYPE_IDX(dv_attr_idx); 02192 02193 if (TYP_TYPE(type_idx) == Structure) { 02194 IR_FLD_R(ir_idx) = (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 02195 IR_IDX_R(ir_idx) = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 02196 IR_LINE_NUM_R(ir_idx) = line; 02197 IR_COL_NUM_R(ir_idx) = col; 02198 } 02199 else if (TYP_TYPE(type_idx) == Character) { 02200 02201 IR_FLD_R(ir_idx) = TYP_FLD(type_idx); 02202 IR_IDX_R(ir_idx) = TYP_IDX(type_idx); 02203 IR_LINE_NUM_R(ir_idx) = line; 02204 IR_COL_NUM_R(ir_idx) = col; 02205 02206 if (IR_FLD_R(ir_idx) == AT_Tbl_Idx) { 02207 ADD_TMP_TO_SHARED_LIST(IR_IDX_R(ir_idx)); 02208 } 02209 02210 if (! char_len_in_bytes) { 02211 02212 /* Len is in bytes on solaris */ 02213 /* Len is in bits for everyone else */ 02214 02215 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 02216 result.fld = CN_Tbl_Idx; 02217 result.idx = CN_INTEGER_CHAR_BIT_IDX; 02218 length.fld = TYP_FLD(type_idx); 02219 length.idx = TYP_IDX(type_idx); 02220 02221 size_offset_binary_calc(&length, 02222 &result, 02223 Mult_Opr, 02224 &result); 02225 02226 if (result.fld == NO_Tbl_Idx) { 02227 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 02228 IR_IDX_R(ir_idx) = ntr_const_tbl(result.type_idx, 02229 FALSE, 02230 result.constant); 02231 } 02232 else { 02233 IR_FLD_R(ir_idx) = result.fld; 02234 IR_IDX_R(ir_idx) = result.idx; 02235 } 02236 02237 IR_LINE_NUM_R(ir_idx) = line; 02238 IR_COL_NUM_R(ir_idx) = col; 02239 } 02240 else { 02241 NTR_IR_TBL(mult_idx); 02242 IR_OPR(mult_idx) = Mult_Opr; 02243 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 02244 IR_LINE_NUM(mult_idx) = line; 02245 IR_COL_NUM(mult_idx) = col; 02246 IR_FLD_L(mult_idx) = CN_Tbl_Idx; 02247 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8); 02248 IR_LINE_NUM_L(mult_idx) = line; 02249 IR_COL_NUM_L(mult_idx) = col; 02250 02251 IR_FLD_R(mult_idx) = TYP_FLD(type_idx); 02252 IR_IDX_R(mult_idx) = TYP_IDX(type_idx); 02253 IR_LINE_NUM_R(mult_idx) = line; 02254 IR_COL_NUM_R(mult_idx) = col; 02255 02256 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 02257 IR_IDX_R(ir_idx) = mult_idx; 02258 } 02259 } 02260 } 02261 else { 02262 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 02263 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 02264 storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 02265 IR_LINE_NUM_R(ir_idx) = line; 02266 IR_COL_NUM_R(ir_idx) = col; 02267 } 02268 02269 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 02270 02271 if (position == After) { 02272 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02273 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02274 } 02275 else { 02276 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 02277 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02278 } 02279 02280 02281 02282 /*************\ 02283 |* ASSOC *| 02284 \*************/ 02285 02286 /* Do not set */ 02287 02288 /*************\ 02289 |* PTR_ALLOC *| 02290 \*************/ 02291 02292 /* Do not set */ 02293 02294 /*************\ 02295 |* P_OR_A *| 02296 \*************/ 02297 02298 NTR_IR_TBL(ir_idx); 02299 IR_OPR(ir_idx) = Dv_Set_P_Or_A; 02300 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 02301 IR_LINE_NUM(ir_idx) = line; 02302 IR_COL_NUM(ir_idx) = col; 02303 02304 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd)); 02305 02306 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 02307 02308 if (ATD_ALLOCATABLE(dv_attr_idx)) { 02309 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2); 02310 } 02311 else if (ATD_POINTER(dv_attr_idx)) { 02312 IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX; 02313 } 02314 else { 02315 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 02316 } 02317 IR_LINE_NUM_R(ir_idx) = line; 02318 IR_COL_NUM_R(ir_idx) = col; 02319 02320 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 02321 02322 if (position == After) { 02323 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02324 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02325 } 02326 else { 02327 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 02328 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02329 } 02330 02331 02332 /*************\ 02333 |* A_CONTIG *| 02334 \*************/ 02335 02336 /* if it is in common block, this bit is left untouched */ 02337 if (!ATD_IN_COMMON(dv_attr_idx)) 02338 { 02339 NTR_IR_TBL(ir_idx); 02340 IR_OPR(ir_idx) = Dv_Set_A_Contig; 02341 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 02342 IR_LINE_NUM(ir_idx) = line; 02343 IR_COL_NUM(ir_idx) = col; 02344 02345 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd)); 02346 02347 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 02348 02349 if (ATD_ALLOCATABLE(dv_attr_idx)) { 02350 IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX; 02351 } 02352 else { 02353 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 02354 } 02355 IR_LINE_NUM_R(ir_idx) = line; 02356 IR_COL_NUM_R(ir_idx) = col; 02357 02358 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 02359 02360 if (position == After) { 02361 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02362 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02363 } 02364 else { 02365 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 02366 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02367 } 02368 } 02369 02370 02371 /*************\ 02372 |* N_DIM *| 02373 \*************/ 02374 02375 NTR_IR_TBL(ir_idx); 02376 IR_OPR(ir_idx) =Dv_Set_N_Dim ; 02377 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 02378 IR_LINE_NUM(ir_idx) = line; 02379 IR_COL_NUM(ir_idx) = col; 02380 02381 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd)); 02382 02383 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 02384 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 02385 (ATD_ARRAY_IDX(dv_attr_idx) ? 02386 BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0)); 02387 IR_LINE_NUM_R(ir_idx) = line; 02388 IR_COL_NUM_R(ir_idx) = col; 02389 02390 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 02391 02392 if (position == After) { 02393 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02394 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02395 } 02396 else { 02397 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 02398 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02399 } 02400 02401 02402 /*************\ 02403 |* TYPE_CODE *| 02404 \*************/ 02405 02406 NTR_IR_TBL(ir_idx); 02407 IR_OPR(ir_idx) = Dv_Set_Typ_Code; 02408 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 02409 IR_LINE_NUM(ir_idx) = line; 02410 IR_COL_NUM(ir_idx) = col; 02411 02412 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd)); 02413 02414 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 02415 IR_IDX_R(ir_idx) = create_dv_type_code(dv_attr_idx); 02416 IR_LINE_NUM_R(ir_idx) = line; 02417 IR_COL_NUM_R(ir_idx) = col; 02418 02419 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 02420 02421 if (position == After) { 02422 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02423 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02424 } 02425 else { 02426 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 02427 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02428 } 02429 02430 02431 /*************\ 02432 |* ORIG_BASE *| 02433 \*************/ 02434 02435 /* Do not set */ 02436 02437 /*************\ 02438 |* ORIG_SIZE *| 02439 \*************/ 02440 02441 /* Do not set */ 02442 02443 TRACE (Func_Exit, "gen_common_dv_init", NULL); 02444 02445 return; 02446 02447 } /* gen_common_dv_init */ 02448 02449 /******************************************************************************\ 02450 |* *| 02451 |* Description: *| 02452 |* Create a whole def of a dope vector that is in a module block. *| 02453 |* *| 02454 |* Input parameters: *| 02455 |* NONE *| 02456 |* *| 02457 |* Output parameters: *| 02458 |* NONE *| 02459 |* *| 02460 |* Returns: *| 02461 |* NOTHING *| 02462 |* *| 02463 \******************************************************************************/ 02464 02465 void gen_static_dv_whole_def(opnd_type *dv_opnd, 02466 int attr_idx, 02467 sh_position_type position) 02468 02469 { 02470 int col; 02471 long_type constant[2]; 02472 int const_idx; 02473 ext_dope_type *dv_ptr; 02474 int ir_idx; 02475 int i; 02476 int line; 02477 int mult_idx; 02478 int num_words; 02479 long_type rank; /* BRIANJ */ 02480 int type_idx; 02481 02482 02483 TRACE (Func_Entry, "gen_static_dv_whole_def", NULL); 02484 02485 find_opnd_line_and_column(dv_opnd, &line, &col); 02486 02487 rank = (ATD_ARRAY_IDX(attr_idx) ? (long)BD_RANK(ATD_ARRAY_IDX(attr_idx)) :0); 02488 02489 num_words = DV_HD_WORD_SIZE + (rank * DV_DIM_WORD_SIZE); 02490 02491 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 02492 TYP_TYPE(TYP_WORK_IDX) = Typeless; 02493 TYP_BIT_LEN(TYP_WORK_IDX) = num_words * TARGET_BITS_PER_WORD; 02494 type_idx = ntr_type_tbl(); 02495 02496 const_idx = ntr_const_tbl(type_idx, FALSE, NULL); 02497 02498 /* NULL() intrinsic */ 02499 if (ATD_CLASS(attr_idx) == Compiler_Tmp) { 02500 ATD_FLD(attr_idx) = CN_Tbl_Idx; 02501 ATD_TMP_IDX(attr_idx) = const_idx; 02502 ATD_TMP_INIT_NOT_DONE(attr_idx) = TRUE; 02503 } 02504 else { 02505 gen_init_stmt(dv_opnd, 02506 const_idx, 02507 position); 02508 } 02509 02510 dv_ptr = (ext_dope_type *)&CN_CONST(const_idx); 02511 type_idx = ATD_TYPE_IDX(attr_idx); 02512 02513 /* the entire constant is initialized to 0's */ 02514 /* so just fill in the non zero parts. */ 02515 02516 /*************\ 02517 |* EL_LEN *| 02518 \*************/ 02519 02520 if (TYP_TYPE(type_idx) == Structure) { 02521 02522 if (compare_cn_and_value(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)), 02523 MAX_DV_EL_LEN, 02524 Ge_Opr)) { 02525 PRINTMSG(line, 1174, Error, col, 02526 CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))), 02527 MAX_DV_EL_LEN); 02528 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN); 02529 } 02530 else { /* BRIANJ */ 02531 DV_SET_EL_LEN(*dv_ptr, 02532 CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)))); 02533 } 02534 } 02535 else if (TYP_TYPE(type_idx) == Character) { 02536 02537 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 02538 02539 if (char_len_in_bytes) { 02540 02541 if (compare_cn_and_value(TYP_IDX(type_idx), 02542 MAX_DV_EL_LEN, 02543 Ge_Opr)) { 02544 PRINTMSG(line, 1174, Error, col, 02545 CN_INT_TO_C(TYP_IDX(type_idx)), 02546 MAX_DV_EL_LEN); 02547 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN); 02548 } 02549 else { /* BRIANJ */ 02550 DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx))); 02551 } 02552 } 02553 else { 02554 02555 if (compare_cn_and_value(TYP_IDX(type_idx), 02556 MAX_DV_EL_LEN/8, 02557 Ge_Opr)) { 02558 PRINTMSG(line, 1174, Error, col, 02559 CN_INT_TO_C(TYP_IDX(type_idx)), 02560 MAX_DV_EL_LEN/8); 02561 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN); 02562 } 02563 else { /* BRIANJ */ 02564 DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx)) * 8); 02565 } 02566 } 02567 } 02568 else { 02569 /* We are here only for variable length char pointers */ 02570 /* They cannot be inside a derived type, so just generate */ 02571 /* an assignment statement to fill in the length at runtime. */ 02572 02573 NTR_IR_TBL(ir_idx); 02574 IR_OPR(ir_idx) = Dv_Set_El_Len; 02575 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 02576 IR_LINE_NUM(ir_idx) = line; 02577 IR_COL_NUM(ir_idx) = col; 02578 02579 COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd)); 02580 02581 if (char_len_in_bytes) { 02582 02583 /* Len is in bytes for solaris */ 02584 IR_FLD_R(ir_idx) = TYP_FLD(type_idx); 02585 IR_IDX_R(ir_idx) = TYP_IDX(type_idx); 02586 IR_LINE_NUM_R(ir_idx) = line; 02587 IR_COL_NUM_R(ir_idx) = col; 02588 } 02589 else { 02590 NTR_IR_TBL(mult_idx); 02591 IR_OPR(mult_idx) = Mult_Opr; 02592 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 02593 IR_LINE_NUM(mult_idx) = line; 02594 IR_COL_NUM(mult_idx) = col; 02595 IR_FLD_L(mult_idx) = CN_Tbl_Idx; 02596 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8); 02597 IR_LINE_NUM_L(mult_idx) = line; 02598 IR_COL_NUM_L(mult_idx) = col; 02599 02600 IR_FLD_R(mult_idx) = TYP_FLD(type_idx); 02601 IR_IDX_R(mult_idx) = TYP_IDX(type_idx); 02602 IR_LINE_NUM_R(mult_idx) = line; 02603 IR_COL_NUM_R(mult_idx) = col; 02604 02605 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 02606 IR_IDX_R(ir_idx) = mult_idx; 02607 } 02608 02609 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 02610 02611 if (position == After) { 02612 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02613 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02614 } 02615 else { 02616 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 02617 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02618 } 02619 } 02620 } 02621 else { 02622 DV_SET_EL_LEN(*dv_ptr, storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 02623 } 02624 02625 /*************\ 02626 |* P_OR_A *| 02627 \*************/ 02628 02629 if (ATD_ALLOCATABLE(attr_idx)) { 02630 DV_SET_P_OR_A(*dv_ptr, 2); 02631 } 02632 else if (ATD_POINTER(attr_idx)) { 02633 DV_SET_P_OR_A(*dv_ptr, 1); 02634 } 02635 02636 /*************\ 02637 |* N_DIM *| 02638 \*************/ 02639 02640 DV_SET_NUM_DIMS(*dv_ptr, rank); 02641 02642 /*************\ 02643 |* TYPE_CODE *| 02644 \*************/ 02645 02646 make_io_type_code(type_idx, constant); 02647 # ifdef _TYPE_CODE_64_BIT 02648 DV_SET_TYPE_CODE(*dv_ptr, *(f90_type_t *)constant); 02649 # else 02650 DV_SET_TYPE_CODE(*dv_ptr, *constant); 02651 # endif 02652 02653 if (cmd_line_flags.runtime_bounds && 02654 ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 02655 02656 for (i = 0; i < BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) { 02657 02658 /************************************\ 02659 |* set LOW_BOUND for each dimension *| 02660 \************************************/ 02661 02662 DV_SET_LOW_BOUND(*dv_ptr, i, 1); 02663 02664 /*********************************\ 02665 |* set EXTENT for each dimension *| 02666 \*********************************/ 02667 02668 /* leave as zero */ 02669 02670 /**************************************\ 02671 |* set STRIDE_MULT for each dimension *| 02672 \**************************************/ 02673 02674 DV_SET_STRIDE_MULT(*dv_ptr, i, 1); 02675 02676 } 02677 } 02678 02679 TRACE (Func_Exit, "gen_static_dv_whole_def", NULL); 02680 02681 return; 02682 02683 } /* gen_static_dv_whole_def */ 02684 02685 /******************************************************************************\ 02686 |* *| 02687 |* Description: *| 02688 |* <description> *| 02689 |* *| 02690 |* Input parameters: *| 02691 |* NONE *| 02692 |* *| 02693 |* Output parameters: *| 02694 |* NONE *| 02695 |* *| 02696 |* Returns: *| 02697 |* NOTHING *| 02698 |* *| 02699 \******************************************************************************/ 02700 02701 static long64 create_imp_do_loops(opnd_type *top_opnd) 02702 02703 { 02704 02705 int col; 02706 long64 count = 1; 02707 long64 end; 02708 int i; 02709 int imp_idx; 02710 int line; 02711 int list_idx; 02712 opnd_type opnd; 02713 long64 start; 02714 int tmp_idx; 02715 int trip_list_idx; 02716 02717 02718 TRACE (Func_Entry, "create_imp_do_loops", NULL); 02719 02720 COPY_OPND(opnd, (*top_opnd)); 02721 find_opnd_line_and_column(&opnd, &line, &col); 02722 02723 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 02724 02725 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) { 02726 02727 trip_list_idx = IR_IDX_R(OPND_IDX(opnd)); 02728 02729 for (i = 0; i < IR_LIST_CNT_R(OPND_IDX(opnd)); i++) { 02730 02731 NTR_IR_TBL(imp_idx); 02732 IR_OPR(imp_idx) = Implied_Do_Opr; 02733 IR_TYPE_IDX(imp_idx) = TYPELESS_DEFAULT_TYPE; 02734 IR_LINE_NUM(imp_idx) = line; 02735 IR_COL_NUM(imp_idx) = col; 02736 02737 NTR_IR_LIST_TBL(list_idx); 02738 IR_FLD_L(imp_idx) = IL_Tbl_Idx; 02739 IR_LIST_CNT_L(imp_idx) = 1; 02740 IR_IDX_L(imp_idx) = list_idx; 02741 02742 COPY_OPND(IL_OPND(list_idx), (*top_opnd)); 02743 OPND_FLD((*top_opnd)) = IR_Tbl_Idx; 02744 OPND_IDX((*top_opnd)) = imp_idx; 02745 02746 /* create the tmp implied do control variable. */ 02747 02748 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 02749 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 02750 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 02751 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 02752 ATD_IMP_DO_LCV(tmp_idx) = TRUE; 02753 ATD_LCV_IS_CONST(tmp_idx) = TRUE; 02754 02755 /* hook in control var. */ 02756 02757 NTR_IR_LIST_TBL(list_idx); 02758 IR_FLD_R(imp_idx) = IL_Tbl_Idx; 02759 IR_LIST_CNT_R(imp_idx) = 4; 02760 IR_IDX_R(imp_idx) = list_idx; 02761 02762 IL_FLD(list_idx) = AT_Tbl_Idx; 02763 IL_IDX(list_idx) = tmp_idx; 02764 IL_LINE_NUM(list_idx) = line; 02765 IL_COL_NUM(list_idx) = col; 02766 02767 /* second is start opnd */ 02768 02769 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02770 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02771 list_idx = IL_NEXT_LIST_IDX(list_idx); 02772 02773 COPY_OPND(IL_OPND(list_idx), 02774 IL_OPND(IR_IDX_L(IL_IDX(trip_list_idx)))); 02775 02776 start = CN_INT_TO_C(IL_IDX(list_idx)); 02777 02778 /* third is end opnd */ 02779 02780 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02781 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02782 list_idx = IL_NEXT_LIST_IDX(list_idx); 02783 02784 COPY_OPND(IL_OPND(list_idx), 02785 IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L( 02786 IL_IDX(trip_list_idx))))); 02787 02788 end = CN_INT_TO_C(IL_IDX(list_idx)); 02789 02790 count = count * ((end - start) + 1); 02791 02792 /* fourth is stride opnd */ 02793 02794 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02795 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02796 list_idx = IL_NEXT_LIST_IDX(list_idx); 02797 02798 COPY_OPND(IL_OPND(list_idx), 02799 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX( 02800 IR_IDX_L(IL_IDX(trip_list_idx)))))); 02801 02802 02803 /* replace triplet with tmp control variable */ 02804 02805 IL_FLD(trip_list_idx) = AT_Tbl_Idx; 02806 IL_IDX(trip_list_idx) = tmp_idx; 02807 IL_LINE_NUM(trip_list_idx) = line; 02808 IL_COL_NUM(trip_list_idx) = col; 02809 02810 trip_list_idx = IL_NEXT_LIST_IDX(trip_list_idx); 02811 } 02812 } 02813 02814 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 02815 } 02816 02817 02818 TRACE (Func_Exit, "create_imp_do_loops", NULL); 02819 02820 return(count); 02821 02822 } /* create_imp_do_loops */ 02823 02824 /******************************************************************************\ 02825 |* *| 02826 |* Description: *| 02827 |* This routine creates a chain of stmts to initialize a dope vector *| 02828 |* or a structure with pointers. *| 02829 |* *| 02830 |* Input parameters: *| 02831 |* attr_idx - idx of variable to process. *| 02832 |* *| 02833 |* Output parameters: *| 02834 |* exit_sh_idx - exit code chain if needed. *| 02835 |* *| 02836 |* Returns: *| 02837 |* NOTHING *| 02838 |* *| 02839 \******************************************************************************/ 02840 02841 void gen_entry_dope_code(int attr_idx) 02842 02843 { 02844 expr_arg_type exp_desc; 02845 void (*func)(); 02846 opnd_type opnd; 02847 int opr; 02848 02849 02850 TRACE (Func_Entry, "gen_entry_dope_code", NULL); 02851 02852 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 02853 func = gen_static_dv_whole_def; 02854 opr = Init_Opr; 02855 } 02856 else if (ATD_AUTOMATIC(attr_idx) || 02857 ATD_CLASS(attr_idx) == Function_Result) { 02858 func = gen_dv_whole_def_init; 02859 opr = Asg_Opr; 02860 } 02861 else if (ATD_IN_COMMON(attr_idx)) { 02862 02863 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 02864 func = gen_common_dv_init; 02865 opr = Init_Opr; 02866 # else 02867 func = gen_static_dv_whole_def; 02868 opr = Init_Opr; 02869 # endif 02870 } 02871 else if (ATD_SAVED(attr_idx) || 02872 ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx))) { 02873 func = gen_static_dv_whole_def; 02874 opr = Init_Opr; 02875 } 02876 else { 02877 func = gen_dv_whole_def_init; 02878 opr = Asg_Opr; 02879 } 02880 02881 if (AT_DCL_ERR(attr_idx)) { 02882 goto EXIT; 02883 } 02884 02885 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 02886 02887 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 02888 ATD_IN_COMMON(attr_idx)) { 02889 02890 /* intentionally blank. We can't initialize common block */ 02891 /* dope vectors from multiple .o's on solaris. */ 02892 } 02893 else 02894 # endif 02895 02896 02897 if (ATD_IM_A_DOPE(attr_idx)) { 02898 OPND_FLD(opnd) = AT_Tbl_Idx; 02899 OPND_IDX(opnd) = attr_idx; 02900 OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx); 02901 OPND_COL_NUM(opnd) = SH_COL_NUM(curr_stmt_sh_idx); 02902 (*func)(&opnd, attr_idx, After); 02903 } 02904 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 02905 (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) || 02906 ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) && 02907 ! AT_DCL_ERR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) { 02908 02909 OPND_FLD(opnd) = AT_Tbl_Idx; 02910 OPND_IDX(opnd) = attr_idx; 02911 OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx); 02912 OPND_COL_NUM(opnd) = SH_COL_NUM(curr_stmt_sh_idx); 02913 02914 # if defined(_TARGET_OS_MAX) 02915 if (ATD_ARRAY_IDX(attr_idx) || 02916 ATD_PE_ARRAY_IDX(attr_idx)) 02917 # else 02918 if (ATD_ARRAY_IDX(attr_idx)) 02919 # endif 02920 { 02921 gen_whole_subscript(&opnd, &exp_desc); 02922 } 02923 02924 process_cpnt_inits(&opnd, 02925 TYP_IDX(ATD_TYPE_IDX(attr_idx)), 02926 func, 02927 opr, 02928 After); 02929 } 02930 02931 02932 EXIT: 02933 02934 TRACE (Func_Exit, "gen_entry_dope_code", NULL); 02935 02936 return; 02937 02938 } /* gen_entry_dope_code */ 02939 02940 /******************************************************************************\ 02941 |* *| 02942 |* Description: *| 02943 |* recursively go through all components of a structure to look for *| 02944 |* pointers. Then call the supplied routine func for processing. *| 02945 |* *| 02946 |* Input parameters: *| 02947 |* left_opnd - current base of sub-object reference. *| 02948 |* type_idx - defined type attr. *| 02949 |* func - function to call for processing. *| 02950 |* *| 02951 |* Output parameters: *| 02952 |* NONE *| 02953 |* *| 02954 |* Returns: *| 02955 |* NOTHING *| 02956 |* *| 02957 \******************************************************************************/ 02958 02959 02960 void process_cpnt_inits(opnd_type *left_opnd, 02961 int type_idx, 02962 void (*func)(), 02963 int opr, 02964 sh_position_type position) 02965 02966 { 02967 int attr_idx; 02968 opnd_type cn_opnd; 02969 int col; 02970 int const_idx; 02971 expr_arg_type exp_desc; 02972 int i; 02973 int init_idx; 02974 int ir_idx; 02975 int line; 02976 int list_idx; 02977 boolean need_loops = FALSE; 02978 opnd_type opnd; 02979 int placeholder_sh_idx = NULL_IDX; 02980 int save_curr_stmt_sh_idx; 02981 int save_target_array_idx; 02982 int sub_idx; 02983 int sn_idx; 02984 int tmp_idx; 02985 opnd_type tmp_opnd; 02986 02987 TRACE (Func_Entry, "process_cpnt_inits", NULL); 02988 02989 find_opnd_line_and_column(left_opnd, &line, &col); 02990 02991 # ifdef _DEBUG 02992 if (opr != Asg_Opr && 02993 opr != Init_Opr) { 02994 PRINTMSG(line, 626, Internal, col, 02995 "Asg_Opr or Init_Opr", "process_cpnt_inits"); 02996 } 02997 # endif 02998 02999 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 03000 03001 if (position == After) { 03002 save_curr_stmt_sh_idx = SH_NEXT_IDX(save_curr_stmt_sh_idx); 03003 } 03004 03005 # if defined(_GEN_LOOPS_FOR_DV_WHOLE_DEF) 03006 if (func == (void (*)())gen_dv_whole_def_init || 03007 func == (void (*)())gen_dv_whole_def || 03008 func == (void (*)())gen_sf_dv_whole_def) { 03009 03010 need_loops = TRUE; 03011 } 03012 # endif 03013 03014 if (ATT_DEFAULT_INITIALIZED(type_idx) && 03015 opr == Asg_Opr) { 03016 need_loops = TRUE; 03017 } 03018 03019 if (need_loops) { 03020 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 03021 03022 if (position == Before) { 03023 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 03024 } 03025 placeholder_sh_idx = curr_stmt_sh_idx; 03026 03027 gen_dv_def_loops(left_opnd); 03028 03029 # ifdef _DEBUG 03030 if (placeholder_sh_idx != curr_stmt_sh_idx) { 03031 PRINTMSG(line, 626, Internal, col, 03032 "placeholder_sh_idx == curr_stmt_sh_idx", 03033 "process_cpnt_inits"); 03034 } 03035 # endif 03036 } 03037 03038 sn_idx = ATT_FIRST_CPNT_IDX(type_idx); 03039 03040 while (sn_idx != NULL_IDX) { 03041 attr_idx = SN_ATTR_IDX(sn_idx); 03042 03043 if (ATD_POINTER(attr_idx)) { 03044 NTR_IR_TBL(ir_idx); 03045 IR_OPR(ir_idx) = Struct_Opr; 03046 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 03047 IR_LINE_NUM(ir_idx) = line; 03048 IR_COL_NUM(ir_idx) = col; 03049 COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd)); 03050 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 03051 IR_IDX_R(ir_idx) = attr_idx; 03052 IR_LINE_NUM_R(ir_idx) = line; 03053 IR_COL_NUM_R(ir_idx) = col; 03054 OPND_FLD(opnd) = IR_Tbl_Idx; 03055 OPND_IDX(opnd) = ir_idx; 03056 03057 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) { 03058 IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx)); 03059 } 03060 03061 (*func)(&opnd, attr_idx, position); 03062 } 03063 else if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) { 03064 03065 NTR_IR_TBL(ir_idx); 03066 03067 IR_OPR(ir_idx) = Struct_Opr; 03068 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 03069 IR_LINE_NUM(ir_idx) = line; 03070 IR_COL_NUM(ir_idx) = col; 03071 03072 COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd)); 03073 03074 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 03075 IR_IDX_R(ir_idx) = attr_idx; 03076 IR_LINE_NUM_R(ir_idx) = line; 03077 IR_COL_NUM_R(ir_idx) = col; 03078 03079 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) { 03080 IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx)); 03081 } 03082 03083 gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, line, col); 03084 03085 if (opr == Asg_Opr) { 03086 03087 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 03088 exp_desc = init_exp_desc; 03089 gen_whole_subscript(&opnd, &exp_desc); 03090 } 03091 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 03092 gen_whole_substring(&opnd, 0); 03093 } 03094 03095 NTR_IR_TBL(init_idx); 03096 03097 IR_OPR(init_idx) = Asg_Opr; 03098 IR_LINE_NUM(init_idx) = line; 03099 IR_COL_NUM(init_idx) = col; 03100 IR_TYPE_IDX(init_idx) = ATD_TYPE_IDX(attr_idx); 03101 COPY_OPND(IR_OPND_L(init_idx), opnd); 03102 IR_LINE_NUM_L(init_idx)= line; 03103 IR_COL_NUM_L(init_idx) = col; 03104 03105 03106 IR_IDX_R(init_idx) = ATD_CPNT_INIT_IDX(attr_idx); 03107 IR_FLD_R(init_idx) = (fld_type) ATD_FLD(attr_idx); 03108 IR_LINE_NUM_R(init_idx) = line; 03109 IR_COL_NUM_R(init_idx) = col; 03110 03111 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 03112 03113 if (position == After) { 03114 SH_IR_IDX(curr_stmt_sh_idx) = init_idx; 03115 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 03116 } 03117 else { 03118 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx; 03119 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 03120 } 03121 } 03122 else { 03123 /* Init_Opr */ 03124 03125 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 03126 NTR_IR_TBL(sub_idx); 03127 IR_OPR(sub_idx) = Subscript_Opr; 03128 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx); 03129 IR_LINE_NUM(sub_idx) = line; 03130 IR_COL_NUM(sub_idx) = col; 03131 03132 COPY_OPND(IR_OPND_L(sub_idx), opnd); 03133 03134 NTR_IR_LIST_TBL(list_idx); 03135 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 03136 IR_IDX_R(sub_idx) = list_idx; 03137 IR_LIST_CNT_R(sub_idx) = 1; 03138 03139 IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),1); 03140 IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),1); 03141 IL_LINE_NUM(list_idx) = line; 03142 IL_COL_NUM(list_idx) = col; 03143 03144 for (i = 2; i<= BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) { 03145 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03146 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03147 list_idx = IL_NEXT_LIST_IDX(list_idx); 03148 03149 IR_LIST_CNT_R(sub_idx) += 1; 03150 03151 IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),i); 03152 IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),i); 03153 IL_LINE_NUM(list_idx) = line; 03154 IL_COL_NUM(list_idx) = col; 03155 } 03156 03157 gen_opnd(&opnd, sub_idx, IR_Tbl_Idx, line, col); 03158 } 03159 03160 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 03161 gen_whole_substring(&opnd, 0); 03162 } 03163 03164 if (ATD_FLD(attr_idx) != CN_Tbl_Idx) { 03165 03166 gen_opnd(&tmp_opnd, ATD_CPNT_INIT_IDX(attr_idx), 03167 (fld_type) ATD_FLD(attr_idx), line, col); 03168 03169 tmp_idx = find_left_attr(&tmp_opnd); 03170 03171 if (ATD_FLD(tmp_idx) == CN_Tbl_Idx) { 03172 const_idx = ATD_TMP_IDX(tmp_idx); 03173 } 03174 else if (ATD_FLD(tmp_idx) == IR_Tbl_Idx && 03175 IR_OPR(ATD_TMP_IDX(tmp_idx)) == Mult_Opr) { 03176 03177 /* this is a scalar broadcast */ 03178 /* so broadcast it now. */ 03179 03180 const_idx = IR_IDX_R(ATD_TMP_IDX(tmp_idx)); 03181 03182 save_target_array_idx = target_array_idx; 03183 target_array_idx = ATD_ARRAY_IDX(attr_idx); 03184 03185 exp_desc = init_exp_desc; 03186 exp_desc.type_idx = CN_TYPE_IDX(const_idx); 03187 exp_desc.type = TYP_TYPE(exp_desc.type_idx); 03188 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx); 03189 exp_desc.constant = TRUE; 03190 exp_desc.foldable = TRUE; 03191 03192 gen_opnd(&cn_opnd, const_idx, CN_Tbl_Idx, line, col); 03193 fold_aggragate_expression(&cn_opnd, 03194 &exp_desc, 03195 TRUE); /* return constant */ 03196 target_array_idx = save_target_array_idx; 03197 03198 const_idx = OPND_IDX(cn_opnd); 03199 } 03200 } 03201 else { 03202 const_idx = ATD_CPNT_INIT_IDX(attr_idx); 03203 } 03204 03205 gen_init_stmt(&opnd, 03206 const_idx, 03207 position); 03208 } 03209 } 03210 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 03211 (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) || 03212 ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))))) { 03213 03214 NTR_IR_TBL(ir_idx); 03215 IR_OPR(ir_idx) = Struct_Opr; 03216 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 03217 IR_LINE_NUM(ir_idx) = line; 03218 IR_COL_NUM(ir_idx) = col; 03219 COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd)); 03220 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 03221 IR_IDX_R(ir_idx) = attr_idx; 03222 IR_LINE_NUM_R(ir_idx) = line; 03223 IR_COL_NUM_R(ir_idx) = col; 03224 OPND_FLD(opnd) = IR_Tbl_Idx; 03225 OPND_IDX(opnd) = ir_idx; 03226 03227 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) { 03228 IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx)); 03229 } 03230 03231 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 03232 exp_desc = init_exp_desc; 03233 gen_whole_subscript(&opnd, &exp_desc); 03234 } 03235 03236 process_cpnt_inits(&opnd, 03237 TYP_IDX(ATD_TYPE_IDX(attr_idx)), 03238 func, 03239 opr, 03240 position); 03241 03242 } 03243 03244 sn_idx = SN_SIBLING_LINK(sn_idx); 03245 } 03246 03247 /* remove placeholder_sh_idx */ 03248 03249 if (placeholder_sh_idx != NULL_IDX) { 03250 remove_sh(placeholder_sh_idx); 03251 FREE_SH_NODE(placeholder_sh_idx); 03252 } 03253 03254 if (position == Before) { 03255 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 03256 } 03257 else { 03258 if (save_curr_stmt_sh_idx != NULL_IDX) { 03259 curr_stmt_sh_idx = SH_PREV_IDX(save_curr_stmt_sh_idx); 03260 } 03261 else { 03262 /* find end of stmts */ 03263 while (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) { 03264 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 03265 } 03266 } 03267 } 03268 03269 TRACE (Func_Exit, "process_cpnt_inits", NULL); 03270 03271 return; 03272 03273 } /* process_cpnt_inits */ 03274 03275 /******************************************************************************\ 03276 |* *| 03277 |* Description: *| 03278 |* <description> *| 03279 |* *| 03280 |* Input parameters: *| 03281 |* NONE *| 03282 |* *| 03283 |* Output parameters: *| 03284 |* NONE *| 03285 |* *| 03286 |* Returns: *| 03287 |* NOTHING *| 03288 |* *| 03289 \******************************************************************************/ 03290 03291 static void gen_init_stmt(opnd_type *left_opnd, 03292 int const_idx, 03293 sh_position_type position) 03294 03295 { 03296 int array_attr_idx; 03297 opnd_type base_opnd; 03298 int bd_idx; 03299 int col; 03300 long64 count = 0; 03301 int init_idx; 03302 int line; 03303 int list_idx; 03304 int mult_idx; 03305 int num_loops = 0; 03306 opnd_type opnd; 03307 int rank_idx = NULL_IDX; 03308 long_type result[MAX_WORDS_FOR_INTEGER]; 03309 long64 sm_bits; 03310 int type_idx; 03311 int unused = NULL_IDX; 03312 int unused2; 03313 long_type the_constant[MAX_WORDS_FOR_INTEGER]; 03314 03315 03316 TRACE (Func_Entry, "gen_init_stmt", NULL); 03317 03318 find_opnd_line_and_column(left_opnd, &line, &col); 03319 03320 NTR_IR_TBL(init_idx); 03321 IR_OPR(init_idx) = Init_Opr; 03322 IR_TYPE_IDX(init_idx) = TYPELESS_DEFAULT_TYPE; 03323 IR_LINE_NUM(init_idx) = line; 03324 IR_COL_NUM(init_idx) = col; 03325 03326 COPY_OPND(IR_OPND_L(init_idx), (*left_opnd)); 03327 03328 COPY_OPND(opnd, (*left_opnd)); 03329 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 03330 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) { 03331 num_loops++; 03332 } 03333 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 03334 } 03335 03336 if (num_loops > 0) { 03337 03338 if (num_loops == 1) { 03339 /* set up as a single init with rep count and stride */ 03340 COPY_OPND(opnd, (*left_opnd)); 03341 make_base_subtree(&opnd, &base_opnd, &rank_idx, &unused); 03342 03343 # ifdef _DEBUG 03344 if (rank_idx == NULL_IDX) { 03345 PRINTMSG(line, 626, Internal, col, 03346 "whole array subscript", 03347 "gen_init_stmt"); 03348 } 03349 # endif 03350 array_attr_idx = find_base_attr(&IR_OPND_L(rank_idx), 03351 &unused, 03352 &unused2); 03353 03354 bd_idx = ATD_ARRAY_IDX(array_attr_idx); 03355 03356 COPY_OPND(IR_OPND_L(init_idx), base_opnd); 03357 03358 NTR_IR_LIST_TBL(list_idx); 03359 IR_FLD_R(init_idx) = IL_Tbl_Idx; 03360 IR_IDX_R(init_idx) = list_idx; 03361 IR_LIST_CNT_R(init_idx) = 3; 03362 03363 /* value */ 03364 03365 IL_FLD(list_idx) = CN_Tbl_Idx; 03366 IL_IDX(list_idx) = const_idx; 03367 IL_LINE_NUM(list_idx) = line; 03368 IL_COL_NUM(list_idx) = col; 03369 03370 /* rep count */ 03371 03372 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03373 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03374 list_idx = IL_NEXT_LIST_IDX(list_idx); 03375 03376 # ifdef _DEBUG 03377 if (BD_LEN_FLD(bd_idx) != CN_Tbl_Idx) { 03378 PRINTMSG(line, 626, Internal, col, 03379 "constant array length", 03380 "gen_init_stmt"); 03381 } 03382 # endif 03383 IL_FLD(list_idx) = CN_Tbl_Idx; 03384 IL_IDX(list_idx) = BD_LEN_IDX(bd_idx); 03385 IL_LINE_NUM(list_idx) = line; 03386 IL_COL_NUM(list_idx) = col; 03387 03388 /* stride in bits */ 03389 03390 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03391 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03392 list_idx = IL_NEXT_LIST_IDX(list_idx); 03393 03394 # ifdef _SM_UNIT_IS_ELEMENT 03395 sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx)); 03396 C_TO_F_INT(the_constant, sm_bits, Integer_8); 03397 # else 03398 if (TYP_TYPE(ATD_TYPE_IDX(array_attr_idx)) == Structure && 03399 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(array_attr_idx)))) { 03400 C_TO_F_INT(the_constant, 8, CG_INTEGER_DEFAULT_TYPE); 03401 } 03402 else { 03403 sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx)); 03404 C_TO_F_INT(the_constant, sm_bits, Integer_8); 03405 } 03406 # endif 03407 03408 type_idx = (CG_INTEGER_DEFAULT_TYPE > 03409 TYP_LINEAR(CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1))) ? 03410 CG_INTEGER_DEFAULT_TYPE : 03411 CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1))); 03412 03413 03414 if (folder_driver((char *)&CN_CONST(BD_SM_IDX(bd_idx, 1)), 03415 CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1)), 03416 (char *) the_constant, 03417 CG_INTEGER_DEFAULT_TYPE, 03418 result, 03419 &type_idx, 03420 line, 03421 col, 03422 2, 03423 Mult_Opr)) { 03424 03425 IL_FLD(list_idx) = CN_Tbl_Idx; 03426 IL_IDX(list_idx) = ntr_const_tbl(type_idx, 03427 FALSE, 03428 result); 03429 IL_LINE_NUM(list_idx) = line; 03430 IL_COL_NUM(list_idx) = col; 03431 } 03432 } 03433 else { 03434 /* must be all implied do loops */ 03435 03436 copy_subtree(left_opnd, &opnd); 03437 count = create_imp_do_loops(&opnd); 03438 COPY_OPND(IR_OPND_L(init_idx), opnd); 03439 03440 NTR_IR_LIST_TBL(list_idx); 03441 IR_FLD_R(init_idx) = IL_Tbl_Idx; 03442 IR_IDX_R(init_idx) = list_idx; 03443 IR_LIST_CNT_R(init_idx) = 1; 03444 03445 NTR_IR_TBL(mult_idx); 03446 IR_OPR(mult_idx) = Mult_Opr; 03447 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 03448 IR_LINE_NUM(mult_idx) = line; 03449 IR_COL_NUM(mult_idx) = col; 03450 IR_FLD_L(mult_idx) = CN_Tbl_Idx; 03451 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, count); 03452 03453 IR_LINE_NUM_L(mult_idx) = line; 03454 IR_COL_NUM_L(mult_idx) = col; 03455 IR_FLD_R(mult_idx) = CN_Tbl_Idx; 03456 IR_IDX_R(mult_idx) = const_idx; 03457 IR_LINE_NUM_R(mult_idx) = line; 03458 IR_COL_NUM_R(mult_idx) = col; 03459 03460 IL_FLD(list_idx) = IR_Tbl_Idx; 03461 IL_IDX(list_idx) = mult_idx; 03462 } 03463 } 03464 else { 03465 03466 NTR_IR_LIST_TBL(list_idx); 03467 IR_FLD_R(init_idx) = IL_Tbl_Idx; 03468 IR_IDX_R(init_idx) = list_idx; 03469 IR_LIST_CNT_R(init_idx) = 3; 03470 03471 IL_FLD(list_idx) = CN_Tbl_Idx; 03472 IL_IDX(list_idx) = const_idx; 03473 IL_LINE_NUM(list_idx) = line; 03474 IL_COL_NUM(list_idx) = col; 03475 03476 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03477 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03478 list_idx = IL_NEXT_LIST_IDX(list_idx); 03479 03480 IL_FLD(list_idx) = CN_Tbl_Idx; 03481 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 03482 IL_LINE_NUM(list_idx) = line; 03483 IL_COL_NUM(list_idx) = col; 03484 03485 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03486 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03487 list_idx = IL_NEXT_LIST_IDX(list_idx); 03488 03489 IL_FLD(list_idx) = CN_Tbl_Idx; 03490 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 03491 IL_LINE_NUM(list_idx) = line; 03492 IL_COL_NUM(list_idx) = col; 03493 } 03494 03495 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 03496 03497 if (position == After) { 03498 SH_IR_IDX(curr_stmt_sh_idx) = init_idx; 03499 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 03500 } 03501 else { 03502 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx; 03503 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 03504 } 03505 03506 03507 TRACE (Func_Exit, "gen_init_stmt", NULL); 03508 03509 return; 03510 03511 } /* gen_init_stmt */ 03512 03513 /******************************************************************************\ 03514 |* *| 03515 |* Description: *| 03516 |* Gen the dv_whole_def_opr to set a dope vector in one operation. *| 03517 |* *| 03518 |* Input parameters: *| 03519 |* NONE *| 03520 |* *| 03521 |* Output parameters: *| 03522 |* NONE *| 03523 |* *| 03524 |* Returns: *| 03525 |* NOTHING *| 03526 |* *| 03527 \******************************************************************************/ 03528 03529 void gen_dv_whole_def(opnd_type *dv_opnd, 03530 opnd_type *r_opnd, 03531 expr_arg_type *exp_desc) 03532 03533 { 03534 act_arg_type a_type; 03535 int asg_idx; 03536 int attr_idx; 03537 opnd_type base_opnd; 03538 int col; 03539 int dim = 1; 03540 int dope_idx = NULL_IDX; 03541 int dv_attr_idx; 03542 int dv2_idx; 03543 int i; 03544 int ir_idx; 03545 opnd_type len_opnd; 03546 int line; 03547 int list_idx; 03548 int list2_idx; 03549 int loc_idx; 03550 int max_idx; 03551 int mult_idx; 03552 opnd_type opnd; 03553 long rank; 03554 int rank_idx = NULL_IDX; 03555 opnd_type r_dv_opnd; 03556 int stride_idx; 03557 opnd_type stride_opnd; 03558 int subscript_idx; 03559 int type_idx; 03560 boolean whole_array; 03561 03562 03563 TRACE (Func_Entry, "gen_dv_whole_def", NULL); 03564 03565 dv_attr_idx = find_base_attr(dv_opnd, &line, &col); 03566 03567 NTR_IR_TBL(asg_idx); 03568 IR_OPR(asg_idx) = Dv_Def_Asg_Opr; 03569 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 03570 IR_LINE_NUM(asg_idx) = line; 03571 IR_COL_NUM(asg_idx) = col; 03572 03573 NTR_IR_TBL(ir_idx); 03574 IR_OPR(ir_idx) = Dv_Whole_Def_Opr; 03575 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 03576 IR_LINE_NUM(ir_idx) = line; 03577 IR_COL_NUM(ir_idx) = col; 03578 03579 COPY_OPND(IR_OPND_L(asg_idx), (*dv_opnd)); 03580 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 03581 IR_IDX_R(asg_idx) = ir_idx; 03582 03583 NTR_IR_LIST_TBL(list_idx); 03584 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 03585 IR_IDX_L(ir_idx) = list_idx; 03586 03587 rank = (ATD_ARRAY_IDX(dv_attr_idx) ? 03588 (long) BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0); 03589 IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank); 03590 IR_DV_DIM(ir_idx) = rank; 03591 03592 /*************\ 03593 |* BASE ADDR *| 03594 \*************/ 03595 03596 NTR_IR_TBL(loc_idx); 03597 IR_OPR(loc_idx) = Loc_Opr; 03598 IR_LINE_NUM(loc_idx) = line; 03599 IR_COL_NUM(loc_idx) = col; 03600 03601 if (exp_desc->type == Character) { 03602 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 03603 } 03604 else { 03605 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 03606 } 03607 03608 IL_FLD(list_idx) = IR_Tbl_Idx; 03609 IL_IDX(list_idx) = loc_idx; 03610 03611 if (exp_desc->rank == 0) { 03612 COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd)); 03613 just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx); 03614 } 03615 else { 03616 make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx); 03617 COPY_OPND(IR_OPND_L(loc_idx), base_opnd); 03618 } 03619 03620 # ifdef _TRANSFORM_CHAR_SEQUENCE 03621 # ifdef _TARGET_OS_UNICOS 03622 if (exp_desc->type == Structure && 03623 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) { 03624 03625 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 03626 COPY_OPND(opnd, IR_OPND_L(loc_idx)); 03627 transform_char_sequence_ref(&opnd, exp_desc->type_idx); 03628 COPY_OPND(IR_OPND_L(loc_idx), opnd); 03629 } 03630 # endif 03631 # endif 03632 03633 03634 /*************************\ 03635 |* check for whole array *| 03636 \*************************/ 03637 03638 if (rank_idx != NULL_IDX) { 03639 attr_idx = find_base_attr(&IR_OPND_L(rank_idx), &line, &col); 03640 03641 if (ATD_IM_A_DOPE(attr_idx)) { 03642 COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx))); 03643 } 03644 subscript_idx = IR_IDX_R(rank_idx); 03645 } 03646 else if (exp_desc->rank != 0) { 03647 attr_idx = find_base_attr(r_opnd, &line, &col); 03648 03649 if (ATD_IM_A_DOPE(attr_idx)) { 03650 COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd)))); 03651 } 03652 } 03653 else { 03654 find_opnd_line_and_column(r_opnd, &line, &col); 03655 } 03656 03657 if (exp_desc->rank > 0 && 03658 ! exp_desc->section) { 03659 03660 whole_array = TRUE; 03661 } 03662 else { 03663 whole_array = FALSE; 03664 } 03665 03666 /*************\ 03667 |* EL_LEN *| 03668 \*************/ 03669 03670 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03671 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03672 list_idx = IL_NEXT_LIST_IDX(list_idx); 03673 type_idx = ATD_TYPE_IDX(dv_attr_idx); 03674 03675 if (TYP_TYPE(type_idx) == Structure) { 03676 IL_FLD(list_idx) = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 03677 IL_IDX(list_idx) = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 03678 IL_LINE_NUM(list_idx) = line; 03679 IL_COL_NUM(list_idx) = col; 03680 } 03681 else if (TYP_TYPE(type_idx) == Character) { 03682 03683 COPY_OPND(opnd, exp_desc->char_len); 03684 OPND_LINE_NUM(opnd) = line; 03685 OPND_COL_NUM(opnd) = col; 03686 compute_char_element_len(&opnd, r_opnd, &len_opnd); 03687 03688 COPY_OPND(IL_OPND(list_idx), len_opnd); 03689 IL_LINE_NUM(list_idx) = line; 03690 IL_COL_NUM(list_idx) = col; 03691 } 03692 else { 03693 IL_FLD(list_idx) = CN_Tbl_Idx; 03694 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 03695 storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 03696 IL_LINE_NUM(list_idx) = line; 03697 IL_COL_NUM(list_idx) = col; 03698 } 03699 03700 /*************\ 03701 |* ASSOC *| 03702 \*************/ 03703 03704 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03705 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03706 list_idx = IL_NEXT_LIST_IDX(list_idx); 03707 03708 IL_FLD(list_idx) = CN_Tbl_Idx; 03709 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 03710 IL_LINE_NUM(list_idx) = line; 03711 IL_COL_NUM(list_idx) = col; 03712 03713 /*************\ 03714 |* PTR_ALLOC *| 03715 \*************/ 03716 03717 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03718 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03719 list_idx = IL_NEXT_LIST_IDX(list_idx); 03720 03721 if (dope_idx != NULL_IDX) { 03722 03723 NTR_IR_TBL(dv2_idx); 03724 IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc; 03725 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE; 03726 IR_LINE_NUM(dv2_idx) = line; 03727 IR_COL_NUM(dv2_idx) = col; 03728 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 03729 IL_FLD(list_idx) = IR_Tbl_Idx; 03730 IL_IDX(list_idx) = dv2_idx; 03731 } 03732 else { 03733 IL_FLD(list_idx) = CN_Tbl_Idx; 03734 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 03735 IL_LINE_NUM(list_idx) = line; 03736 IL_COL_NUM(list_idx) = col; 03737 } 03738 03739 03740 /*************\ 03741 |* P_OR_A *| 03742 \*************/ 03743 03744 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03745 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03746 list_idx = IL_NEXT_LIST_IDX(list_idx); 03747 03748 IL_FLD(list_idx) = CN_Tbl_Idx; 03749 03750 if (ATD_ALLOCATABLE(dv_attr_idx)) { 03751 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2); 03752 } 03753 else if (ATD_POINTER(dv_attr_idx)) { 03754 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 03755 } 03756 else { 03757 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 03758 } 03759 IL_LINE_NUM(list_idx) = line; 03760 IL_COL_NUM(list_idx) = col; 03761 03762 03763 03764 /*************\ 03765 |* A_CONTIG *| 03766 \*************/ 03767 03768 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03769 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03770 list_idx = IL_NEXT_LIST_IDX(list_idx); 03771 03772 a_type = get_act_arg_type(exp_desc); 03773 03774 if (a_type == Array_Ptr || 03775 a_type == Array_Tmp_Ptr || 03776 a_type == Whole_Ass_Shape || 03777 a_type == Dv_Contig_Section) { 03778 03779 NTR_IR_TBL(dv2_idx); 03780 IR_OPR(dv2_idx) = Dv_Access_A_Contig; 03781 IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE; 03782 IR_LINE_NUM(dv2_idx) = line; 03783 IR_COL_NUM(dv2_idx) = col; 03784 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 03785 IL_FLD(list_idx) = IR_Tbl_Idx; 03786 IL_IDX(list_idx) = dv2_idx; 03787 03788 } 03789 else if (a_type == Whole_Allocatable || 03790 a_type == Whole_Tmp_Allocatable || 03791 a_type == Whole_Sequence || 03792 a_type == Whole_Tmp_Sequence || 03793 a_type == Whole_Array_Constant || 03794 a_type == Contig_Section) { 03795 03796 IL_FLD(list_idx) = CN_Tbl_Idx; 03797 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 03798 IL_LINE_NUM(list_idx) = line; 03799 IL_COL_NUM(list_idx) = col; 03800 } 03801 else { 03802 IL_FLD(list_idx) = CN_Tbl_Idx; 03803 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 03804 IL_LINE_NUM(list_idx) = line; 03805 IL_COL_NUM(list_idx) = col; 03806 } 03807 03808 03809 /*************\ 03810 |* N_DIM *| 03811 \*************/ 03812 03813 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03814 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03815 list_idx = IL_NEXT_LIST_IDX(list_idx); 03816 03817 IL_FLD(list_idx) = CN_Tbl_Idx; 03818 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank); 03819 IL_LINE_NUM(list_idx) = line; 03820 IL_COL_NUM(list_idx) = col; 03821 03822 03823 /*************\ 03824 |* TYPE_CODE *| 03825 \*************/ 03826 03827 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03828 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03829 list_idx = IL_NEXT_LIST_IDX(list_idx); 03830 03831 IL_FLD(list_idx) = CN_Tbl_Idx; 03832 IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx); 03833 IL_LINE_NUM(list_idx) = line; 03834 IL_COL_NUM(list_idx) = col; 03835 03836 /*************\ 03837 |* ORIG_BASE *| 03838 \*************/ 03839 03840 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03841 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03842 list_idx = IL_NEXT_LIST_IDX(list_idx); 03843 03844 if (dope_idx != NULL_IDX) { 03845 03846 NTR_IR_TBL(dv2_idx); 03847 IR_OPR(dv2_idx) = Dv_Access_Orig_Base; 03848 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE; 03849 IR_LINE_NUM(dv2_idx) = line; 03850 IR_COL_NUM(dv2_idx) = col; 03851 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 03852 IL_FLD(list_idx) = IR_Tbl_Idx; 03853 IL_IDX(list_idx) = dv2_idx; 03854 } 03855 else { 03856 IL_FLD(list_idx) = CN_Tbl_Idx; 03857 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 03858 IL_LINE_NUM(list_idx) = line; 03859 IL_COL_NUM(list_idx) = col; 03860 } 03861 03862 03863 /*************\ 03864 |* ORIG_SIZE *| 03865 \*************/ 03866 03867 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03868 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03869 list_idx = IL_NEXT_LIST_IDX(list_idx); 03870 03871 if (dope_idx != NULL_IDX) { 03872 03873 NTR_IR_TBL(dv2_idx); 03874 IR_OPR(dv2_idx) = Dv_Access_Orig_Size; 03875 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE; 03876 IR_LINE_NUM(dv2_idx) = line; 03877 IR_COL_NUM(dv2_idx) = col; 03878 COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx)); 03879 IL_FLD(list_idx) = IR_Tbl_Idx; 03880 IL_IDX(list_idx) = dv2_idx; 03881 } 03882 else { 03883 IL_FLD(list_idx) = CN_Tbl_Idx; 03884 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 03885 IL_LINE_NUM(list_idx) = line; 03886 IL_COL_NUM(list_idx) = col; 03887 } 03888 03889 03890 for (i = 1; i <= rank; i++) { 03891 03892 /*************\ 03893 |* DIM i LB *| 03894 \*************/ 03895 03896 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03897 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03898 list_idx = IL_NEXT_LIST_IDX(list_idx); 03899 03900 if (whole_array) { 03901 /* need arrays low bound */ 03902 if (ATD_IM_A_DOPE(attr_idx) && 03903 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Assumed_Shape) { 03904 NTR_IR_TBL(dv2_idx); 03905 IR_OPR(dv2_idx) = Dv_Access_Low_Bound; 03906 IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE; 03907 IR_LINE_NUM(dv2_idx) = line; 03908 IR_COL_NUM(dv2_idx) = col; 03909 COPY_OPND(IR_OPND_L(dv2_idx), r_dv_opnd); 03910 IR_DV_DIM(dv2_idx) = i; 03911 IL_FLD(list_idx) = IR_Tbl_Idx; 03912 IL_IDX(list_idx) = dv2_idx; 03913 } 03914 else { 03915 IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i); 03916 IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i); 03917 IL_LINE_NUM(list_idx) = line; 03918 IL_COL_NUM(list_idx) = col; 03919 03920 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 03921 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 03922 } 03923 } 03924 } 03925 else { 03926 /* set to one */ 03927 IL_FLD(list_idx) = CN_Tbl_Idx; 03928 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 03929 IL_LINE_NUM(list_idx) = line; 03930 IL_COL_NUM(list_idx) = col; 03931 } 03932 03933 03934 /*************\ 03935 |* DIM i EX *| 03936 \*************/ 03937 03938 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03939 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03940 list_idx = IL_NEXT_LIST_IDX(list_idx); 03941 03942 NTR_IR_TBL(max_idx); 03943 IR_OPR(max_idx) = Max_Opr; 03944 IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE; 03945 IR_LINE_NUM(max_idx) = line; 03946 IR_COL_NUM(max_idx) = col; 03947 03948 NTR_IR_LIST_TBL(list2_idx); 03949 IR_FLD_L(max_idx) = IL_Tbl_Idx; 03950 IR_LIST_CNT_L(max_idx) = 2; 03951 IR_IDX_L(max_idx) = list2_idx; 03952 03953 IL_FLD(list2_idx) = CN_Tbl_Idx; 03954 IL_IDX(list2_idx) = CN_INTEGER_ZERO_IDX; 03955 IL_LINE_NUM(list2_idx) = line; 03956 IL_COL_NUM(list2_idx) = col; 03957 03958 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 03959 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx; 03960 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 03961 03962 COPY_OPND(IL_OPND(list2_idx), exp_desc->shape[i-1]); 03963 IL_LINE_NUM(list2_idx) = line; 03964 IL_COL_NUM(list2_idx) = col; 03965 03966 IL_FLD(list_idx) = IR_Tbl_Idx; 03967 IL_IDX(list_idx) = max_idx; 03968 03969 /*************\ 03970 |* DIM i SM *| 03971 \*************/ 03972 03973 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03974 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03975 list_idx = IL_NEXT_LIST_IDX(list_idx); 03976 03977 if (whole_array) { 03978 03979 gen_dv_stride_mult(&stride_opnd, 03980 attr_idx, 03981 &r_dv_opnd, 03982 exp_desc, 03983 i, 03984 line, 03985 col); 03986 03987 COPY_OPND(IL_OPND(list_idx), stride_opnd); 03988 03989 } 03990 else { 03991 while (IL_FLD(subscript_idx) != IR_Tbl_Idx || 03992 IR_OPR(IL_IDX(subscript_idx)) != Triplet_Opr) { 03993 subscript_idx = IL_NEXT_LIST_IDX(subscript_idx); 03994 dim++; 03995 } 03996 03997 gen_dv_stride_mult(&stride_opnd, 03998 attr_idx, 03999 &r_dv_opnd, 04000 exp_desc, 04001 dim, 04002 line, 04003 col); 04004 04005 stride_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L( 04006 IL_IDX(subscript_idx)))); 04007 04008 mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd), 04009 Mult_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 04010 IL_FLD(stride_idx), IL_IDX(stride_idx)); 04011 04012 IL_FLD(list_idx) = IR_Tbl_Idx; 04013 IL_IDX(list_idx) = mult_idx; 04014 04015 subscript_idx = IL_NEXT_LIST_IDX(subscript_idx); 04016 dim++; 04017 } 04018 } 04019 04020 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 04021 04022 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 04023 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 04024 04025 TRACE (Func_Exit, "gen_dv_whole_def", NULL); 04026 04027 return; 04028 04029 } /* gen_dv_whole_def */ 04030 04031 /******************************************************************************\ 04032 |* *| 04033 |* Description: *| 04034 |* <description> *| 04035 |* *| 04036 |* Input parameters: *| 04037 |* NONE *| 04038 |* *| 04039 |* Output parameters: *| 04040 |* NONE *| 04041 |* *| 04042 |* Returns: *| 04043 |* NOTHING *| 04044 |* *| 04045 \******************************************************************************/ 04046 04047 static void gen_dv_stride_mult(opnd_type *stride_opnd, 04048 int attr_idx, 04049 opnd_type *r_dv_opnd, 04050 expr_arg_type *exp_desc, 04051 int dim, 04052 int line, 04053 int col) 04054 04055 { 04056 # if defined(_EXTENDED_CRI_CHAR_POINTER) 04057 int clen_idx; 04058 # endif 04059 04060 int cn_idx; 04061 int dv_idx; 04062 int ir_idx; 04063 long64 res_sm_unit_in_bits; 04064 long64 src_sm_unit_in_bits; 04065 04066 04067 TRACE (Func_Entry, "gen_dv_stride_mult", NULL); 04068 04069 /* res_sm_unit_in_bits describes the sm unit for the result dv */ 04070 04071 if (exp_desc->type == Structure && 04072 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) { 04073 res_sm_unit_in_bits = sm_unit_in_bits(Character_1); 04074 } 04075 else { 04076 res_sm_unit_in_bits = sm_unit_in_bits(exp_desc->type_idx); 04077 # ifdef _WHIRL_HOST64_TARGET64 04078 if (res_sm_unit_in_bits > 32) 04079 res_sm_unit_in_bits = 32; 04080 # endif /* _WHIRL_HOST64_TARGET64 */ 04081 } 04082 04083 /* src_sm_unit_in_bits describes the sm unit for the arrays bd entry */ 04084 04085 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 04086 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) { 04087 src_sm_unit_in_bits = sm_unit_in_bits(Character_1); 04088 } 04089 else { 04090 src_sm_unit_in_bits = sm_unit_in_bits(ATD_TYPE_IDX(attr_idx)); 04091 } 04092 04093 # ifdef _DEBUG 04094 if (res_sm_unit_in_bits == 0 || src_sm_unit_in_bits == 0) { 04095 PRINTMSG(line, 626, Internal, col, 04096 "stride_mult_unit_in_bits", 04097 "gen_dv_stride_mult"); 04098 } 04099 # endif 04100 04101 04102 if (ATD_IM_A_DOPE(attr_idx)) { 04103 NTR_IR_TBL(dv_idx); 04104 IR_OPR(dv_idx) = Dv_Access_Stride_Mult; 04105 IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE; 04106 IR_LINE_NUM(dv_idx) = line; 04107 IR_COL_NUM(dv_idx) = col; 04108 COPY_OPND(IR_OPND_L(dv_idx), (*r_dv_opnd)); 04109 IR_DV_DIM(dv_idx) = dim; 04110 04111 OPND_FLD((*stride_opnd)) = IR_Tbl_Idx; 04112 OPND_IDX((*stride_opnd)) = dv_idx; 04113 04114 } 04115 else { 04116 OPND_FLD((*stride_opnd)) = BD_SM_FLD(ATD_ARRAY_IDX(attr_idx), dim); 04117 OPND_IDX((*stride_opnd)) = BD_SM_IDX(ATD_ARRAY_IDX(attr_idx), dim); 04118 OPND_LINE_NUM((*stride_opnd)) = line; 04119 OPND_COL_NUM((*stride_opnd)) = col; 04120 04121 if (OPND_FLD((*stride_opnd)) == AT_Tbl_Idx) { 04122 ADD_TMP_TO_SHARED_LIST(OPND_IDX((*stride_opnd))); 04123 } 04124 04125 # if defined(_EXTENDED_CRI_CHAR_POINTER) 04126 if (ATD_CLASS(attr_idx) == CRI__Pointee && 04127 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 04128 04129 NTR_IR_TBL(ir_idx); 04130 IR_OPR(ir_idx) = Mult_Opr; 04131 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 04132 IR_LINE_NUM(ir_idx) = line; 04133 IR_COL_NUM(ir_idx) = col; 04134 04135 COPY_OPND(IR_OPND_L(ir_idx), (*stride_opnd)); 04136 04137 NTR_IR_TBL(clen_idx); 04138 IR_OPR(clen_idx) = Clen_Opr; 04139 IR_TYPE_IDX(clen_idx) = CG_INTEGER_DEFAULT_TYPE; 04140 IR_LINE_NUM(clen_idx) = line; 04141 IR_COL_NUM(clen_idx) = col; 04142 IR_FLD_L(clen_idx) = AT_Tbl_Idx; 04143 IR_IDX_L(clen_idx) = attr_idx; 04144 IR_LINE_NUM_L(clen_idx) = line; 04145 IR_COL_NUM_L(clen_idx) = col; 04146 04147 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 04148 IR_IDX_R(ir_idx) = clen_idx; 04149 04150 OPND_FLD((*stride_opnd)) = IR_Tbl_Idx; 04151 OPND_IDX((*stride_opnd)) = ir_idx; 04152 } 04153 # endif 04154 } 04155 04156 # ifndef _SM_UNIT_IS_ELEMENT 04157 if (src_sm_unit_in_bits != res_sm_unit_in_bits) { 04158 04159 /* BRIANJ - C_INT_TO_CN has the capability of switching this to */ 04160 /* Integer_8 automatically. See me KAY */ 04161 04162 04163 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 04164 (src_sm_unit_in_bits / res_sm_unit_in_bits)); 04165 04166 ir_idx = gen_ir(OPND_FLD((*stride_opnd)), 04167 OPND_IDX((*stride_opnd)), 04168 Mult_Opr, 04169 CG_INTEGER_DEFAULT_TYPE, 04170 line, 04171 col, 04172 CN_Tbl_Idx, 04173 cn_idx); 04174 04175 OPND_FLD((*stride_opnd)) = IR_Tbl_Idx; 04176 OPND_IDX((*stride_opnd)) = ir_idx; 04177 } 04178 # endif 04179 04180 04181 TRACE (Func_Exit, "gen_dv_stride_mult", NULL); 04182 04183 return; 04184 04185 } /* gen_dv_stride_mult */ 04186 04187 /******************************************************************************\ 04188 |* *| 04189 |* Description: *| 04190 |* <description> *| 04191 |* *| 04192 |* Input parameters: *| 04193 |* NONE *| 04194 |* *| 04195 |* Output parameters: *| 04196 |* NONE *| 04197 |* *| 04198 |* Returns: *| 04199 |* NOTHING *| 04200 |* *| 04201 \******************************************************************************/ 04202 04203 static void gen_dv_def_loops(opnd_type *dv_opnd) 04204 04205 { 04206 int col; 04207 int line; 04208 int list_idx; 04209 int list_idx2; 04210 opnd_type opnd; 04211 opnd_type start_opnd; 04212 opnd_type end_opnd; 04213 opnd_type stride_opnd; 04214 int tmp_idx; 04215 04216 TRACE (Func_Entry, "gen_dv_def_loops", NULL); 04217 04218 find_opnd_line_and_column(dv_opnd, &line, &col); 04219 04220 COPY_OPND(opnd, (*dv_opnd)); 04221 04222 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 04223 04224 if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr || 04225 IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr) { 04226 04227 IR_OPR(OPND_IDX(opnd)) = Subscript_Opr; 04228 04229 list_idx = IR_IDX_R(OPND_IDX(opnd)); 04230 04231 while (list_idx != NULL_IDX) { 04232 04233 if (IL_FLD(list_idx) == IR_Tbl_Idx && 04234 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) { 04235 04236 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 04237 04238 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 04239 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 04240 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 04241 04242 list_idx2 = IR_IDX_L(IL_IDX(list_idx)); 04243 04244 COPY_OPND(start_opnd, IL_OPND(list_idx2)); 04245 04246 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 04247 COPY_OPND(end_opnd, IL_OPND(list_idx2)); 04248 04249 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 04250 COPY_OPND(stride_opnd, IL_OPND(list_idx2)); 04251 04252 create_loop_stmts(tmp_idx, &start_opnd, &end_opnd, &stride_opnd, 04253 curr_stmt_sh_idx, /* body start sh idx */ 04254 curr_stmt_sh_idx); /* body end sh idx */ 04255 04256 IL_FLD(list_idx) = AT_Tbl_Idx; 04257 IL_IDX(list_idx) = tmp_idx; 04258 IL_LINE_NUM(list_idx) = line; 04259 IL_COL_NUM(list_idx) = col; 04260 } 04261 04262 list_idx = IL_NEXT_LIST_IDX(list_idx); 04263 } 04264 } 04265 04266 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 04267 } 04268 04269 TRACE (Func_Exit, "gen_dv_def_loops", NULL); 04270 04271 return; 04272 04273 } /* gen_dv_def_loops */ 04274 04275 /******************************************************************************\ 04276 |* *| 04277 |* Description: *| 04278 |* Gen the dv_whole_def_opr to set a dope vector in one operation. *| 04279 |* *| 04280 |* Input parameters: *| 04281 |* NONE *| 04282 |* *| 04283 |* Output parameters: *| 04284 |* NONE *| 04285 |* *| 04286 |* Returns: *| 04287 |* NOTHING *| 04288 |* *| 04289 \******************************************************************************/ 04290 04291 void gen_dv_whole_def_init(opnd_type *dv_opnd, 04292 int dv_attr_idx, 04293 sh_position_type position) 04294 04295 { 04296 int asg_idx; 04297 int col; 04298 int i; 04299 int ir_idx; 04300 size_offset_type length; 04301 int line; 04302 int list_idx; 04303 int mult_idx; 04304 long rank; 04305 size_offset_type result; 04306 int type_idx; 04307 04308 04309 TRACE (Func_Entry, "gen_dv_whole_def_init", NULL); 04310 04311 find_opnd_line_and_column(dv_opnd, &line, &col); 04312 04313 NTR_IR_TBL(asg_idx); 04314 IR_OPR(asg_idx) = Dv_Def_Asg_Opr; 04315 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 04316 IR_LINE_NUM(asg_idx) = line; 04317 IR_COL_NUM(asg_idx) = col; 04318 04319 NTR_IR_TBL(ir_idx); 04320 IR_OPR(ir_idx) = Dv_Whole_Def_Opr; 04321 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 04322 IR_LINE_NUM(ir_idx) = line; 04323 IR_COL_NUM(ir_idx) = col; 04324 04325 COPY_OPND(IR_OPND_L(asg_idx), (*dv_opnd)); 04326 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 04327 IR_IDX_R(asg_idx) = ir_idx; 04328 04329 NTR_IR_LIST_TBL(list_idx); 04330 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 04331 IR_IDX_L(ir_idx) = list_idx; 04332 04333 rank = ATD_ARRAY_IDX(dv_attr_idx) ? 04334 (long) BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0; 04335 IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank); 04336 IR_DV_DIM(ir_idx) = rank; 04337 04338 /*************\ 04339 |* BASE ADDR *| 04340 \*************/ 04341 04342 /* leave as null ops */ 04343 04344 /*************\ 04345 |* EL_LEN *| 04346 \*************/ 04347 04348 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04349 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04350 list_idx = IL_NEXT_LIST_IDX(list_idx); 04351 type_idx = ATD_TYPE_IDX(dv_attr_idx); 04352 04353 if (TYP_TYPE(type_idx) == Structure) { 04354 IL_FLD(list_idx) = (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 04355 IL_IDX(list_idx) = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 04356 IL_LINE_NUM(list_idx) = line; 04357 IL_COL_NUM(list_idx) = col; 04358 } 04359 else if (TYP_TYPE(type_idx) == Character) { 04360 04361 IL_FLD(list_idx) = TYP_FLD(type_idx); 04362 IL_IDX(list_idx) = TYP_IDX(type_idx); 04363 IL_LINE_NUM(list_idx) = line; 04364 IL_COL_NUM(list_idx) = col; 04365 04366 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 04367 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 04368 } 04369 04370 if (! char_len_in_bytes) { 04371 /* Len is in bytes on solaris */ 04372 /* Len is in bits for everyone else */ 04373 04374 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 04375 result.fld = CN_Tbl_Idx; 04376 result.idx = CN_INTEGER_CHAR_BIT_IDX; 04377 length.fld = TYP_FLD(type_idx); 04378 length.idx = TYP_IDX(type_idx); 04379 04380 size_offset_binary_calc(&length, 04381 &result, 04382 Mult_Opr, 04383 &result); 04384 04385 if (result.fld == NO_Tbl_Idx) { 04386 IL_FLD(list_idx) = CN_Tbl_Idx; 04387 IL_IDX(list_idx) = ntr_const_tbl(result.type_idx, 04388 FALSE, 04389 result.constant); 04390 } 04391 else { 04392 IL_FLD(list_idx) = result.fld; 04393 IL_IDX(list_idx) = result.idx; 04394 } 04395 04396 IL_LINE_NUM(list_idx) = line; 04397 IL_COL_NUM(list_idx) = col; 04398 } 04399 else { 04400 NTR_IR_TBL(mult_idx); 04401 IR_OPR(mult_idx) = Mult_Opr; 04402 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 04403 IR_LINE_NUM(mult_idx) = line; 04404 IR_COL_NUM(mult_idx) = col; 04405 IR_FLD_L(mult_idx) = CN_Tbl_Idx; 04406 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8); 04407 IR_LINE_NUM_L(mult_idx) = line; 04408 IR_COL_NUM_L(mult_idx) = col; 04409 04410 IR_FLD_R(mult_idx) = TYP_FLD(type_idx); 04411 IR_IDX_R(mult_idx) = TYP_IDX(type_idx); 04412 IR_LINE_NUM_R(mult_idx) = line; 04413 IR_COL_NUM_R(mult_idx) = col; 04414 04415 IL_FLD(list_idx) = IR_Tbl_Idx; 04416 IL_IDX(list_idx) = mult_idx; 04417 } 04418 } 04419 } 04420 else { 04421 IL_FLD(list_idx) = CN_Tbl_Idx; 04422 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 04423 storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 04424 IL_LINE_NUM(list_idx) = line; 04425 IL_COL_NUM(list_idx) = col; 04426 } 04427 04428 /*************\ 04429 |* ASSOC *| 04430 \*************/ 04431 04432 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04433 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04434 list_idx = IL_NEXT_LIST_IDX(list_idx); 04435 04436 IL_FLD(list_idx) = CN_Tbl_Idx; 04437 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 04438 IL_LINE_NUM(list_idx) = line; 04439 IL_COL_NUM(list_idx) = col; 04440 04441 /*************\ 04442 |* PTR_ALLOC *| 04443 \*************/ 04444 04445 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04446 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04447 list_idx = IL_NEXT_LIST_IDX(list_idx); 04448 04449 IL_FLD(list_idx) = CN_Tbl_Idx; 04450 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 04451 IL_LINE_NUM(list_idx) = line; 04452 IL_COL_NUM(list_idx) = col; 04453 04454 04455 /*************\ 04456 |* P_OR_A *| 04457 \*************/ 04458 04459 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04460 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04461 list_idx = IL_NEXT_LIST_IDX(list_idx); 04462 04463 IL_FLD(list_idx) = CN_Tbl_Idx; 04464 04465 if (ATD_ALLOCATABLE(dv_attr_idx)) { 04466 IL_IDX(list_idx) = CN_INTEGER_TWO_IDX; 04467 } 04468 else if (ATD_POINTER(dv_attr_idx)) { 04469 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 04470 } 04471 else { 04472 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 04473 } 04474 IL_LINE_NUM(list_idx) = line; 04475 IL_COL_NUM(list_idx) = col; 04476 04477 04478 04479 /*************\ 04480 |* A_CONTIG *| 04481 \*************/ 04482 04483 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04484 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04485 list_idx = IL_NEXT_LIST_IDX(list_idx); 04486 04487 IL_FLD(list_idx) = CN_Tbl_Idx; 04488 04489 if (ATD_ALLOCATABLE(dv_attr_idx)) { 04490 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 04491 } 04492 else { 04493 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 04494 } 04495 IL_LINE_NUM(list_idx) = line; 04496 IL_COL_NUM(list_idx) = col; 04497 04498 04499 /*************\ 04500 |* N_DIM *| 04501 \*************/ 04502 04503 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04504 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04505 list_idx = IL_NEXT_LIST_IDX(list_idx); 04506 04507 IL_FLD(list_idx) = CN_Tbl_Idx; 04508 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank); 04509 IL_LINE_NUM(list_idx) = line; 04510 IL_COL_NUM(list_idx) = col; 04511 04512 04513 /*************\ 04514 |* TYPE_CODE *| 04515 \*************/ 04516 04517 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04518 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04519 list_idx = IL_NEXT_LIST_IDX(list_idx); 04520 04521 IL_FLD(list_idx) = CN_Tbl_Idx; 04522 IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx); 04523 IL_LINE_NUM(list_idx) = line; 04524 IL_COL_NUM(list_idx) = col; 04525 04526 /*************\ 04527 |* ORIG_BASE *| 04528 \*************/ 04529 04530 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04531 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04532 list_idx = IL_NEXT_LIST_IDX(list_idx); 04533 04534 IL_FLD(list_idx) = CN_Tbl_Idx; 04535 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 04536 IL_LINE_NUM(list_idx) = line; 04537 IL_COL_NUM(list_idx) = col; 04538 04539 /*************\ 04540 |* ORIG_SIZE *| 04541 \*************/ 04542 04543 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04544 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04545 list_idx = IL_NEXT_LIST_IDX(list_idx); 04546 04547 IL_FLD(list_idx) = CN_Tbl_Idx; 04548 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 04549 IL_LINE_NUM(list_idx) = line; 04550 IL_COL_NUM(list_idx) = col; 04551 04552 04553 for (i = 1; i <= rank; i++) { 04554 04555 /*************\ 04556 |* DIM i LB *| 04557 \*************/ 04558 04559 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04560 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04561 list_idx = IL_NEXT_LIST_IDX(list_idx); 04562 04563 if (cmd_line_flags.runtime_bounds) { 04564 IL_FLD(list_idx) = CN_Tbl_Idx; 04565 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 04566 IL_LINE_NUM(list_idx) = line; 04567 IL_COL_NUM(list_idx) = col; 04568 } 04569 04570 /*************\ 04571 |* DIM i EX *| 04572 \*************/ 04573 04574 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04575 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04576 list_idx = IL_NEXT_LIST_IDX(list_idx); 04577 04578 if (cmd_line_flags.runtime_bounds) { 04579 IL_FLD(list_idx) = CN_Tbl_Idx; 04580 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 04581 IL_LINE_NUM(list_idx) = line; 04582 IL_COL_NUM(list_idx) = col; 04583 } 04584 04585 /*************\ 04586 |* DIM i SM *| 04587 \*************/ 04588 04589 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04590 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04591 list_idx = IL_NEXT_LIST_IDX(list_idx); 04592 04593 if (cmd_line_flags.runtime_bounds) { 04594 IL_FLD(list_idx) = CN_Tbl_Idx; 04595 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 04596 IL_LINE_NUM(list_idx) = line; 04597 IL_COL_NUM(list_idx) = col; 04598 } 04599 } 04600 04601 gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 04602 04603 if (position == After) { 04604 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 04605 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04606 } 04607 else { 04608 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 04609 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 04610 } 04611 04612 TRACE (Func_Exit, "gen_dv_whole_def_init", NULL); 04613 04614 return; 04615 04616 } /* gen_dv_whole_def_init */ 04617 04618 /******************************************************************************\ 04619 |* *| 04620 |* Description: *| 04621 |* Make a copy of a reference subtree where sections are replace by *| 04622 |* the start value (or lower bound). This is to get the base address *| 04623 |* of an array section. *| 04624 |* *| 04625 |* Input parameters: *| 04626 |* old_opnd - root of original tree. *| 04627 |* *| 04628 |* Output parameters: *| 04629 |* new_opnd - root of copy. *| 04630 |* rank_idx - ir idx to subscript opr that creates the rank. *| 04631 |* dope_idx - idx to dv_deref_opr if there is one. *| 04632 |* *| 04633 |* Returns: *| 04634 |* NOTHING *| 04635 |* *| 04636 \******************************************************************************/ 04637 04638 void make_base_subtree(opnd_type *old_opnd, 04639 opnd_type *new_opnd, 04640 int *rank_idx, 04641 int *dope_idx) 04642 04643 { 04644 int col; 04645 int dummy_idx; 04646 fld_type fld; 04647 int idx; 04648 int line; 04649 int list_idx; 04650 int list2_idx; 04651 int new_root = NULL_IDX; 04652 opnd_type n_opnd; 04653 opnd_type o_opnd; 04654 04655 04656 TRACE (Func_Entry, "make_base_subtree", NULL); 04657 04658 find_opnd_line_and_column(old_opnd, &line, &col); 04659 04660 OPND_FLD((*new_opnd)) = OPND_FLD((*old_opnd)); 04661 idx = OPND_IDX((*old_opnd)); 04662 fld = OPND_FLD((*old_opnd)); 04663 04664 04665 if (idx != NULL_IDX) { 04666 04667 switch(fld) { 04668 04669 case NO_Tbl_Idx : 04670 break; 04671 04672 case IR_Tbl_Idx : 04673 04674 if (IR_OPR(idx) == Triplet_Opr) { 04675 COPY_OPND(o_opnd, IL_OPND(IR_IDX_L(idx))); 04676 make_base_subtree(&o_opnd, new_opnd, rank_idx, &dummy_idx); 04677 goto SKIP; 04678 } 04679 else if (IR_OPR(idx) == Call_Opr) { 04680 /* don't process a call and it's arguments. This means that */ 04681 /* make_base_subtree was called before deferred function */ 04682 /* flattening occured. */ 04683 04684 new_root = idx; 04685 } 04686 else { 04687 04688 NTR_IR_TBL(new_root); 04689 04690 COPY_TBL_NTRY(ir_tbl, new_root, idx); 04691 04692 /* assume that all ir is now scalar */ 04693 IR_RANK(new_root) = 0; 04694 04695 if (IR_OPR(new_root) == Whole_Subscript_Opr || 04696 IR_OPR(new_root) == Section_Subscript_Opr) { 04697 04698 if (*rank_idx != NULL_IDX) { 04699 PRINTMSG(IR_LINE_NUM(idx), 545, Internal, IR_COL_NUM(idx)); 04700 } 04701 *rank_idx = idx; 04702 04703 IR_OPR(new_root) = Subscript_Opr; 04704 } 04705 else if (IR_OPR(idx) == Dv_Deref_Opr && 04706 *dope_idx == NULL_IDX) { 04707 *dope_idx = idx; 04708 } 04709 04710 COPY_OPND(o_opnd, IR_OPND_L(idx)); 04711 make_base_subtree(&o_opnd, &n_opnd, rank_idx, dope_idx); 04712 COPY_OPND(IR_OPND_L(new_root), n_opnd); 04713 04714 COPY_OPND(o_opnd, IR_OPND_R(idx)); 04715 make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx); 04716 COPY_OPND(IR_OPND_R(new_root), n_opnd); 04717 } 04718 04719 break; 04720 04721 case AT_Tbl_Idx : 04722 case CN_Tbl_Idx : 04723 04724 new_root = idx; 04725 OPND_LINE_NUM((*new_opnd)) = line; 04726 OPND_COL_NUM((*new_opnd)) = col; 04727 break; 04728 04729 case IL_Tbl_Idx : 04730 04731 NTR_IR_LIST_TBL(new_root); 04732 COPY_TBL_NTRY(ir_list_tbl, new_root, idx); 04733 OPND_LIST_CNT((*new_opnd)) = OPND_LIST_CNT((*old_opnd)); 04734 COPY_OPND(o_opnd, IL_OPND(idx)); 04735 make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx); 04736 COPY_OPND(IL_OPND(new_root), n_opnd); 04737 list2_idx = new_root; 04738 idx = IL_NEXT_LIST_IDX(idx); 04739 04740 while (idx != NULL_IDX) { 04741 NTR_IR_LIST_TBL(list_idx); 04742 COPY_TBL_NTRY(ir_list_tbl, list_idx, idx); 04743 04744 if (! IL_ARG_DESC_VARIANT(list_idx)) { 04745 IL_PREV_LIST_IDX(list_idx) = list2_idx; 04746 } 04747 IL_NEXT_LIST_IDX(list2_idx) = list_idx; 04748 list2_idx = list_idx; 04749 04750 COPY_OPND(o_opnd, IL_OPND(idx)); 04751 make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx); 04752 COPY_OPND(IL_OPND(list_idx), n_opnd); 04753 idx = IL_NEXT_LIST_IDX(idx); 04754 } 04755 break; 04756 } 04757 } 04758 04759 OPND_IDX((*new_opnd)) = new_root; 04760 OPND_FLD((*new_opnd)) = fld; 04761 04762 SKIP: 04763 04764 TRACE (Func_Exit, "make_base_subtree", NULL); 04765 04766 return; 04767 04768 } /* make_base_subtree */ 04769 04770 /******************************************************************************\ 04771 |* *| 04772 |* Description: *| 04773 |* Finds the subcript opr that describes the section of an array *| 04774 |* section reference and the Dv_Deref_Opr ir idx if there is one. *| 04775 |* *| 04776 |* Input parameters: *| 04777 |* old_opnd - root of original tree. *| 04778 |* *| 04779 |* Output parameters: *| 04780 |* rank_idx - idx of subscript opr that is the section. *| 04781 |* dope_idx - idx of deref opr if there is one. *| 04782 |* *| 04783 |* Returns: *| 04784 |* NOTHING *| 04785 |* *| 04786 \******************************************************************************/ 04787 04788 static void just_find_dope_and_rank(opnd_type *old_opnd, 04789 int *rank_idx, 04790 int *dope_idx) 04791 04792 { 04793 opnd_type opnd; 04794 04795 TRACE (Func_Entry, "just_find_dope_and_rank", NULL); 04796 04797 COPY_OPND(opnd, (*old_opnd)); 04798 04799 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 04800 04801 if (IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr || 04802 IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) { 04803 04804 if (*rank_idx != NULL_IDX) { 04805 PRINTMSG(IR_LINE_NUM(OPND_IDX(opnd)), 545, Internal, 04806 IR_COL_NUM(OPND_IDX(opnd))); 04807 } 04808 *rank_idx = OPND_IDX(opnd); 04809 } 04810 else if (IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr && 04811 *dope_idx == NULL_IDX) { 04812 *dope_idx = OPND_IDX(opnd); 04813 } 04814 04815 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 04816 } 04817 04818 TRACE (Func_Exit, "just_find_dope_and_rank", NULL); 04819 04820 return; 04821 04822 } /* just_find_dope_and_rank */ 04823 04824 04825 /******************************************************************************\ 04826 |* *| 04827 |* Description: *| 04828 |* <description> *| 04829 |* *| 04830 |* Input parameters: *| 04831 |* NONE *| 04832 |* *| 04833 |* Output parameters: *| 04834 |* NONE *| 04835 |* *| 04836 |* Returns: *| 04837 |* NOTHING *| 04838 |* *| 04839 \******************************************************************************/ 04840 04841 void process_deferred_functions(opnd_type *opnd) 04842 04843 { 04844 int col; 04845 int ir_idx; 04846 int line; 04847 int list_idx; 04848 opnd_type loc_opnd; 04849 int save_curr_stmt_sh_idx; 04850 int sh_idx; 04851 04852 TRACE (Func_Entry, "process_deferred_functions", NULL); 04853 04854 find_opnd_line_and_column(opnd, &line, &col); 04855 04856 switch (OPND_FLD((*opnd))) { 04857 case IR_Tbl_Idx: 04858 04859 ir_idx = OPND_IDX((*opnd)); 04860 04861 if (IR_OPR(ir_idx) == Stmt_Expansion_Opr) { 04862 # ifdef _DEBUG 04863 if (IR_FLD_L(ir_idx) == NO_Tbl_Idx) { 04864 PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal, IR_COL_NUM(ir_idx), 04865 "no dags", "process_deferred_functions"); 04866 } 04867 # endif 04868 if (STMT_EXPAND_BEFORE_START_SH(ir_idx)) { 04869 04870 OPND_FLD(loc_opnd) = SH_Tbl_Idx; 04871 OPND_IDX(loc_opnd) = STMT_EXPAND_BEFORE_START_SH(ir_idx); 04872 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04873 curr_stmt_sh_idx = STMT_EXPAND_BEFORE_START_SH(ir_idx); 04874 process_deferred_functions(&loc_opnd); 04875 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 04876 04877 sh_idx = STMT_EXPAND_BEFORE_START_SH(ir_idx); 04878 while (SH_PREV_IDX(sh_idx)) { 04879 sh_idx = SH_PREV_IDX(sh_idx); 04880 } 04881 STMT_EXPAND_BEFORE_START_SH(ir_idx) = sh_idx; 04882 04883 sh_idx = STMT_EXPAND_BEFORE_END_SH(ir_idx); 04884 while (SH_NEXT_IDX(sh_idx)) { 04885 sh_idx = SH_NEXT_IDX(sh_idx); 04886 } 04887 STMT_EXPAND_BEFORE_END_SH(ir_idx) = sh_idx; 04888 04889 insert_sh_chain(STMT_EXPAND_BEFORE_START_SH(ir_idx), 04890 STMT_EXPAND_BEFORE_END_SH(ir_idx), 04891 Before); 04892 } 04893 04894 if (STMT_EXPAND_AFTER_START_SH(ir_idx)) { 04895 04896 OPND_FLD(loc_opnd) = SH_Tbl_Idx; 04897 OPND_IDX(loc_opnd) = STMT_EXPAND_AFTER_START_SH(ir_idx); 04898 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04899 curr_stmt_sh_idx = STMT_EXPAND_AFTER_START_SH(ir_idx); 04900 process_deferred_functions(&loc_opnd); 04901 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 04902 04903 sh_idx = STMT_EXPAND_AFTER_START_SH(ir_idx); 04904 while (SH_PREV_IDX(sh_idx)) { 04905 sh_idx = SH_PREV_IDX(sh_idx); 04906 } 04907 STMT_EXPAND_AFTER_START_SH(ir_idx) = sh_idx; 04908 04909 sh_idx = STMT_EXPAND_AFTER_END_SH(ir_idx); 04910 while (SH_NEXT_IDX(sh_idx)) { 04911 sh_idx = SH_NEXT_IDX(sh_idx); 04912 } 04913 STMT_EXPAND_AFTER_END_SH(ir_idx) = sh_idx; 04914 04915 insert_sh_chain(STMT_EXPAND_AFTER_START_SH(ir_idx), 04916 STMT_EXPAND_AFTER_END_SH(ir_idx), 04917 After); 04918 } 04919 04920 COPY_OPND((*opnd), IR_OPND_L(ir_idx)); 04921 IR_OPND_L(ir_idx) = null_opnd; 04922 /* 04923 free_stmt_expansion_opr(ir_idx); 04924 */ 04925 } 04926 else { 04927 if (IR_FLD_L(ir_idx) != SH_Tbl_Idx) { 04928 process_deferred_functions(&IR_OPND_L(ir_idx)); 04929 } 04930 04931 if (IR_FLD_R(ir_idx) != SH_Tbl_Idx) { 04932 process_deferred_functions(&IR_OPND_R(ir_idx)); 04933 } 04934 } 04935 break; 04936 04937 case SH_Tbl_Idx: 04938 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04939 curr_stmt_sh_idx = OPND_IDX((*opnd)); 04940 04941 while (curr_stmt_sh_idx != NULL_IDX) { 04942 OPND_FLD(loc_opnd) = IR_Tbl_Idx; 04943 OPND_IDX(loc_opnd) = SH_IR_IDX(curr_stmt_sh_idx); 04944 process_deferred_functions(&loc_opnd); 04945 SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(loc_opnd); 04946 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 04947 } 04948 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 04949 break; 04950 04951 case IL_Tbl_Idx: 04952 list_idx = OPND_IDX((*opnd)); 04953 while (list_idx) { 04954 if (IL_FLD(list_idx) != SH_Tbl_Idx) { 04955 process_deferred_functions(&IL_OPND(list_idx)); 04956 } 04957 list_idx = IL_NEXT_LIST_IDX(list_idx); 04958 } 04959 break; 04960 04961 } 04962 04963 TRACE (Func_Exit, "process_deferred_functions", NULL); 04964 04965 return; 04966 04967 } /* process_deferred_functions */ 04968 04969 /******************************************************************************\ 04970 |* *| 04971 |* Description: *| 04972 |* Perform short circuiting on Br_True_Opr stmts. *| 04973 |* Assumes that curr_stmt_sh_idx is the branch stmt. *| 04974 |* This routine is only called when there was a function encountered *| 04975 |* in the condition, so process_deferred_functions must always be called *| 04976 |* whether short circuiting is done or not. *| 04977 |* The top operator (after NOT is de'morganed) must be logical .and. or *| 04978 |* .or. in order for this routine to short circuit. *| 04979 |* The "opt" setting must be considered here to possibly prevent *| 04980 |* any short circuiting. *| 04981 |* *| 04982 |* Input parameters: *| 04983 |* NONE *| 04984 |* *| 04985 |* Output parameters: *| 04986 |* NONE *| 04987 |* *| 04988 |* Returns: *| 04989 |* NOTHING *| 04990 |* *| 04991 \******************************************************************************/ 04992 04993 void short_circuit_branch(void) 04994 04995 { 04996 int asg_idx; 04997 int br_true_idx; 04998 int col; 04999 int ir_idx; 05000 int label_idx; 05001 boolean left_is_worse; 05002 int line; 05003 int log_idx; 05004 int not_cnt = 0; 05005 int not_idx; 05006 opnd_type not_opnd; 05007 opnd_type opnd; 05008 int opnd_column; 05009 int opnd_line; 05010 int save_curr_stmt_sh_idx; 05011 int tmp_idx; 05012 05013 05014 TRACE (Func_Entry, "short_circuit_branch", NULL); 05015 05016 br_true_idx = SH_IR_IDX(curr_stmt_sh_idx); 05017 05018 line = IR_LINE_NUM(br_true_idx); 05019 col = IR_COL_NUM(br_true_idx); 05020 05021 COPY_OPND(opnd, IR_OPND_L(br_true_idx)); 05022 05023 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 05024 05025 switch(IR_OPR(OPND_IDX(opnd))) { 05026 case Not_Opr: 05027 not_cnt++; 05028 05029 if (not_cnt == 1) { 05030 COPY_OPND(not_opnd, opnd); 05031 } 05032 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 05033 break; 05034 05035 case Or_Opr: 05036 case And_Opr: 05037 05038 log_idx = OPND_IDX(opnd); 05039 05040 if (IR_SHORT_CIRCUIT_L(log_idx)) { 05041 left_is_worse = TRUE; 05042 } 05043 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 05044 else { 05045 left_is_worse = FALSE; 05046 } 05047 # else 05048 /* in case we change our minds about short circuiting decisions, save this */ 05049 else if (IR_SHORT_CIRCUIT_R(log_idx)) { 05050 left_is_worse = FALSE; 05051 } 05052 else { 05053 /* no more functions below this operator. */ 05054 if (not_cnt%2 == 0) { 05055 /* nots cancel out */ 05056 COPY_OPND(IR_OPND_L(br_true_idx), opnd); 05057 } 05058 else { 05059 COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), opnd); 05060 COPY_OPND(IR_OPND_L(br_true_idx), not_opnd); 05061 } 05062 goto OUT; 05063 } 05064 # endif 05065 05066 if (not_cnt%2 == 0) { 05067 /* nots cancel out */ 05068 COPY_OPND(IR_OPND_L(br_true_idx), opnd); 05069 } 05070 else { 05071 /* demorgan it */ 05072 COPY_OPND(IR_OPND_L(br_true_idx), opnd); 05073 05074 if (IR_OPR(log_idx) == Or_Opr) { 05075 IR_OPR(log_idx) = And_Opr; 05076 } 05077 else { 05078 IR_OPR(log_idx) = Or_Opr; 05079 } 05080 COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), 05081 IR_OPND_L(log_idx)); 05082 COPY_OPND(IR_OPND_L(log_idx), not_opnd); 05083 05084 NTR_IR_TBL(ir_idx); 05085 IR_OPR(ir_idx) = Not_Opr; 05086 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 05087 IR_LINE_NUM(ir_idx) = IR_LINE_NUM(OPND_IDX(not_opnd)); 05088 IR_COL_NUM(ir_idx) = IR_COL_NUM(OPND_IDX(not_opnd)); 05089 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(log_idx)); 05090 IR_FLD_R(log_idx) = IR_Tbl_Idx; 05091 IR_IDX_R(log_idx) = ir_idx; 05092 } 05093 05094 if (IR_OPR(log_idx) == Or_Opr) { 05095 05096 /* split condition, share label */ 05097 05098 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 05099 05100 NTR_IR_TBL(ir_idx); 05101 IR_OPR(ir_idx) = Br_True_Opr; 05102 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 05103 IR_LINE_NUM(ir_idx) = line; 05104 IR_COL_NUM(ir_idx) = col; 05105 05106 05107 /* Brian: This is from s_end.c. If I'm wrong about needing */ 05108 /* the temp, let me know and I'll get rid of it in both places.*/ 05109 /* If we're working on an IF construct expression, transfer the*/ 05110 /* branch-around label to the right operand of the Br_True IR */ 05111 /* (replacing the IL list). The IL_OPND is copied to a temp */ 05112 /* first because sometimes assignments get a little funky */ 05113 /* using these macros if the target is also being used to */ 05114 /* access the source. */ 05115 /* If we're getting tight on space, could also delete the IL */ 05116 /* nodes. */ 05117 05118 if (IR_FLD_R(br_true_idx) == IL_Tbl_Idx) { 05119 COPY_OPND(opnd, IL_OPND(IR_IDX_R(br_true_idx))); 05120 COPY_OPND(IR_OPND_R(ir_idx), opnd); 05121 } 05122 else { 05123 COPY_OPND(IR_OPND_R(ir_idx), IR_OPND_R(br_true_idx)); 05124 } 05125 05126 05127 if (left_is_worse) { 05128 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(log_idx)); 05129 COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_L(log_idx)); 05130 } 05131 else { 05132 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(log_idx)); 05133 COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_R(log_idx)); 05134 } 05135 05136 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05137 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 05138 05139 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05140 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05141 05142 short_circuit_branch(); 05143 05144 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05145 05146 short_circuit_branch(); 05147 } 05148 else { 05149 05150 /* generate label */ 05151 label_idx = gen_internal_lbl(stmt_start_line); 05152 05153 gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 05154 05155 NTR_IR_TBL(ir_idx); 05156 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05157 IR_OPR(ir_idx) = Label_Opr; 05158 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 05159 IR_LINE_NUM(ir_idx) = line; 05160 IR_COL_NUM(ir_idx) = col; 05161 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 05162 IR_IDX_L(ir_idx) = label_idx; 05163 AT_REFERENCED(label_idx) = Referenced; 05164 IR_COL_NUM_L(ir_idx) = col; 05165 IR_LINE_NUM_L(ir_idx) = line; 05166 05167 AT_DEFINED(label_idx) = TRUE; 05168 ATL_DEF_STMT_IDX(label_idx) = curr_stmt_sh_idx; 05169 05170 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05171 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 05172 05173 NTR_IR_TBL(ir_idx); 05174 IR_OPR(ir_idx) = Br_True_Opr; 05175 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 05176 IR_LINE_NUM(ir_idx) = line; 05177 IR_COL_NUM(ir_idx) = col; 05178 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 05179 IR_IDX_R(ir_idx) = label_idx; 05180 IR_LINE_NUM_R(ir_idx) = line; 05181 IR_COL_NUM_R(ir_idx) = col; 05182 05183 NTR_IR_TBL(not_idx); 05184 IR_OPR(not_idx) = Not_Opr; 05185 IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE; 05186 IR_LINE_NUM(not_idx) = line; 05187 IR_COL_NUM(not_idx) = col; 05188 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 05189 IR_IDX_L(ir_idx) = not_idx; 05190 05191 if (left_is_worse) { 05192 COPY_OPND(IR_OPND_L(not_idx), IR_OPND_R(log_idx)); 05193 COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_L(log_idx)); 05194 } 05195 else { 05196 COPY_OPND(IR_OPND_L(not_idx), IR_OPND_L(log_idx)); 05197 COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_R(log_idx)); 05198 } 05199 05200 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 05201 05202 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05203 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 05204 05205 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05206 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05207 05208 short_circuit_branch(); 05209 05210 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05211 05212 short_circuit_branch(); 05213 } 05214 05215 goto EXIT; 05216 05217 case Paren_Opr: 05218 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 05219 break; 05220 05221 default: 05222 if (not_cnt%2 == 0) { 05223 /* nots cancel out */ 05224 COPY_OPND(IR_OPND_L(br_true_idx), opnd); 05225 } 05226 else { 05227 COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), opnd); 05228 COPY_OPND(IR_OPND_L(br_true_idx), not_opnd); 05229 } 05230 05231 goto OUT; 05232 } 05233 } 05234 05235 OUT: 05236 05237 COPY_OPND(opnd, IR_OPND_L(br_true_idx)); 05238 05239 /* Brian: */ 05240 /* Just a reminder that the following block of code was duped into */ 05241 /* if_stmt-semantics to avoid short-circuiting the IF conditional */ 05242 /* expression for the high-level form of IF requested by the Mongoose */ 05243 /* optimizer. LRR Oct-Nov, 1997 */ 05244 05245 if (tree_produces_dealloc(&opnd)) { /* make logical tmp asg */ 05246 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05247 find_opnd_line_and_column(&opnd, &opnd_line, &opnd_column); 05248 05249 GEN_COMPILER_TMP_ASG(asg_idx, 05250 tmp_idx, 05251 TRUE, /* Semantics done */ 05252 opnd_line, 05253 opnd_column, 05254 LOGICAL_DEFAULT_TYPE, 05255 Priv); 05256 05257 gen_sh(Before, Assignment_Stmt, opnd_line, 05258 opnd_column, FALSE, FALSE, TRUE); 05259 05260 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 05261 05262 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 05263 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05264 05265 process_deferred_functions(&opnd); 05266 COPY_OPND(IR_OPND_R(asg_idx), opnd); 05267 05268 IR_FLD_L(br_true_idx) = AT_Tbl_Idx; 05269 IR_IDX_L(br_true_idx) = tmp_idx; 05270 IR_LINE_NUM_L(br_true_idx) = opnd_line; 05271 IR_COL_NUM_L(br_true_idx) = opnd_column; 05272 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05273 } 05274 else { 05275 process_deferred_functions(&opnd); 05276 COPY_OPND(IR_OPND_L(br_true_idx), opnd); 05277 } 05278 05279 05280 EXIT: 05281 05282 TRACE (Func_Exit, "short_circuit_branch", NULL); 05283 05284 return; 05285 05286 } /* short_circuit_branch */ 05287 05288 /******************************************************************************\ 05289 |* *| 05290 |* Description: *| 05291 |* Search a subtree to see if it has a variable size function call or *| 05292 |* a run time constructor, or dope vector result intrinsic. *| 05293 |* All of these produce some sort of dealloc stmt (or stmts) after *| 05294 |* the current stmt. The result of the tree must be pulled into a *| 05295 |* logical tmp if this routine returns TRUE so that the dealloc *| 05296 |* stmts are executed before any branch occurs. *| 05297 |* *| 05298 |* Input parameters: *| 05299 |* NONE *| 05300 |* *| 05301 |* Output parameters: *| 05302 |* NONE *| 05303 |* *| 05304 |* Returns: *| 05305 |* NOTHING *| 05306 |* *| 05307 \******************************************************************************/ 05308 05309 boolean tree_produces_dealloc(opnd_type *root) 05310 05311 { 05312 int i; 05313 int list_idx; 05314 opnd_type opnd; 05315 boolean has_dealloc = FALSE; 05316 05317 05318 TRACE (Func_Entry, "tree_produces_dealloc", NULL); 05319 05320 if (OPND_FLD((*root)) == IR_Tbl_Idx) { 05321 05322 if (IR_OPR(OPND_IDX((*root))) == Stmt_Expansion_Opr) { 05323 05324 if (STMT_EXPAND_AFTER_START_SH(OPND_IDX((*root))) != NULL_IDX) { 05325 has_dealloc = TRUE; 05326 } 05327 } 05328 else if (IR_OPR(OPND_IDX((*root))) == Array_Construct_Opr || 05329 IR_OPR(OPND_IDX((*root))) == Adjustl_Opr || 05330 IR_OPR(OPND_IDX((*root))) == Adjustr_Opr) { 05331 05332 has_dealloc = TRUE; 05333 goto EXIT; 05334 } 05335 else { 05336 05337 if (IR_FLD_L(OPND_IDX((*root))) == IR_Tbl_Idx || 05338 IR_FLD_L(OPND_IDX((*root))) == IL_Tbl_Idx) { 05339 05340 COPY_OPND(opnd, IR_OPND_L(OPND_IDX((*root)))); 05341 has_dealloc = tree_produces_dealloc(&opnd); 05342 05343 if (has_dealloc) { 05344 goto EXIT; 05345 } 05346 } 05347 05348 if (IR_FLD_R(OPND_IDX((*root))) == IR_Tbl_Idx || 05349 IR_FLD_R(OPND_IDX((*root))) == IL_Tbl_Idx) { 05350 05351 COPY_OPND(opnd, IR_OPND_R(OPND_IDX((*root)))); 05352 has_dealloc = tree_produces_dealloc(&opnd); 05353 05354 if (has_dealloc) { 05355 goto EXIT; 05356 } 05357 } 05358 } 05359 } 05360 else if (OPND_FLD((*root)) == IL_Tbl_Idx) { 05361 05362 list_idx = OPND_IDX((*root)); 05363 05364 for (i = 0; i < OPND_LIST_CNT((*root)); i++) { 05365 05366 if (IL_FLD(list_idx) == IR_Tbl_Idx || 05367 IL_FLD(list_idx) == IL_Tbl_Idx) { 05368 05369 COPY_OPND(opnd, IL_OPND(list_idx)); 05370 has_dealloc = tree_produces_dealloc(&opnd); 05371 05372 if (has_dealloc) { 05373 goto EXIT; 05374 } 05375 } 05376 05377 list_idx = IL_NEXT_LIST_IDX(list_idx); 05378 } 05379 } 05380 05381 EXIT: 05382 05383 TRACE (Func_Exit, "tree_produces_dealloc", NULL); 05384 05385 return(has_dealloc); 05386 05387 } /* tree_produces_dealloc */ 05388 05389 /******************************************************************************\ 05390 |* *| 05391 |* Description: *| 05392 |* <description> *| 05393 |* *| 05394 |* Input parameters: *| 05395 |* NONE *| 05396 |* *| 05397 |* Output parameters: *| 05398 |* NONE *| 05399 |* *| 05400 |* Returns: *| 05401 |* NOTHING *| 05402 |* *| 05403 \******************************************************************************/ 05404 05405 void create_loop_stmts(int lcv_attr, 05406 opnd_type *start_opnd, 05407 opnd_type *end_opnd, 05408 opnd_type *inc_opnd, 05409 int body_start_sh_idx, 05410 int body_end_sh_idx) 05411 05412 { 05413 int col; 05414 int ir_idx; 05415 int line; 05416 int save_curr_stmt_sh_idx; 05417 05418 # if !defined(_HIGH_LEVEL_DO_LOOP_FORM) 05419 int asg_idx; 05420 int br_around_label; 05421 int br_back_label; 05422 int div_idx; 05423 opnd_type end_tmp_opnd; 05424 expr_arg_type exp_desc; 05425 opnd_type inc_tmp_opnd; 05426 int log_idx; 05427 int minus_idx; 05428 int mult_idx; 05429 opnd_type opnd; 05430 int opnd_col; 05431 int opnd_line; 05432 int plus_idx; 05433 cif_usage_code_type save_xref_state; 05434 opnd_type start_tmp_opnd; 05435 int tmp_idx; 05436 opnd_type trip_count_tmp_opnd; 05437 opnd_type trip_counter_tmp_opnd; 05438 # else 05439 int list_idx; 05440 int list_idx2; 05441 # endif 05442 05443 05444 TRACE (Func_Entry, "create_loop_stmts", NULL); 05445 05446 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05447 05448 line = stmt_start_line; 05449 col = stmt_start_col; 05450 05451 # if defined(_HIGH_LEVEL_DO_LOOP_FORM) 05452 curr_stmt_sh_idx = body_end_sh_idx; 05453 05454 ir_idx = gen_ir(NO_Tbl_Idx, NULL_IDX, 05455 Loop_End_Opr, TYPELESS_DEFAULT_TYPE, line, col, 05456 NO_Tbl_Idx, NULL_IDX); 05457 05458 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 05459 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05460 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05461 SH_LOOP_END(curr_stmt_sh_idx) = TRUE; 05462 05463 curr_stmt_sh_idx = body_start_sh_idx; 05464 05465 NTR_IR_LIST_TBL(list_idx); 05466 gen_opnd(&IL_OPND(list_idx), lcv_attr, AT_Tbl_Idx, line, col); 05467 05468 NTR_IR_LIST_TBL(list_idx2); 05469 IL_NEXT_LIST_IDX(list_idx) = list_idx2; 05470 IL_PREV_LIST_IDX(list_idx2) = list_idx; 05471 05472 COPY_OPND(IL_OPND(list_idx2), (*start_opnd)); 05473 05474 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2)); 05475 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2; 05476 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 05477 05478 COPY_OPND(IL_OPND(list_idx2), (*end_opnd)); 05479 05480 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2)); 05481 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2; 05482 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 05483 05484 COPY_OPND(IL_OPND(list_idx2), (*inc_opnd)); 05485 05486 05487 ir_idx = gen_ir(SH_Tbl_Idx, SH_NEXT_IDX(body_end_sh_idx), 05488 Loop_Info_Opr, TYPELESS_DEFAULT_TYPE, line, col, 05489 IL_Tbl_Idx, list_idx); 05490 05491 gen_sh(Before, Do_Iterative_Stmt, line, col, FALSE, FALSE, TRUE); 05492 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 05493 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05494 05495 SH_PARENT_BLK_IDX(SH_NEXT_IDX(body_end_sh_idx)) = 05496 SH_PREV_IDX(curr_stmt_sh_idx); 05497 05498 # else 05499 /***************************************************************************\ 05500 |* branch around label. Do this first. *| 05501 \***************************************************************************/ 05502 05503 curr_stmt_sh_idx = body_end_sh_idx; 05504 05505 br_around_label = gen_internal_lbl(line); 05506 05507 ir_idx = gen_ir(AT_Tbl_Idx, br_around_label, 05508 Label_Opr, TYPELESS_DEFAULT_TYPE, line, col, 05509 NO_Tbl_Idx, NULL_IDX); 05510 05511 gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 05512 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05513 05514 AT_DEFINED(br_around_label) = TRUE; 05515 ATL_DEF_STMT_IDX(br_around_label) = curr_stmt_sh_idx; 05516 05517 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05518 05519 05520 /***************************************************************************\ 05521 |***************************************************************************| 05522 |** PREFIX CODE **| 05523 |***************************************************************************| 05524 \***************************************************************************/ 05525 05526 curr_stmt_sh_idx = body_start_sh_idx; 05527 05528 05529 /***************************************************************************\ 05530 |* temp = start value *| 05531 \***************************************************************************/ 05532 05533 if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx && 05534 TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*start_opnd)))) == 05535 Short_Typeless_Const) { 05536 05537 find_opnd_line_and_column(start_opnd, &opnd_line, &opnd_col); 05538 OPND_IDX((*start_opnd)) = cast_typeless_constant(OPND_IDX((*start_opnd)), 05539 ATD_TYPE_IDX(lcv_attr), 05540 opnd_line, 05541 opnd_col); 05542 } 05543 05544 if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx || 05545 (OPND_FLD((*start_opnd)) == AT_Tbl_Idx && 05546 ATD_CLASS(OPND_IDX((*start_opnd))) == Compiler_Tmp)) { 05547 05548 COPY_OPND(start_tmp_opnd, (*start_opnd)); 05549 } 05550 else { 05551 05552 GEN_COMPILER_TMP_ASG(asg_idx, 05553 tmp_idx, 05554 TRUE, /* Semantics done */ 05555 line, 05556 col, 05557 ATD_TYPE_IDX(lcv_attr), 05558 Priv); 05559 05560 COPY_OPND(IR_OPND_R(asg_idx), (*start_opnd)); 05561 05562 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05563 05564 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05565 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05566 05567 gen_opnd(&start_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col); 05568 } 05569 05570 /***************************************************************************\ 05571 |* temp = end value *| 05572 \***************************************************************************/ 05573 05574 if (OPND_FLD((*end_opnd)) == CN_Tbl_Idx && 05575 TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*end_opnd)))) == 05576 Short_Typeless_Const) { 05577 05578 find_opnd_line_and_column(end_opnd, &opnd_line, &opnd_col); 05579 OPND_IDX((*end_opnd)) = cast_typeless_constant(OPND_IDX((*end_opnd)), 05580 ATD_TYPE_IDX(lcv_attr), 05581 opnd_line, 05582 opnd_col); 05583 } 05584 05585 if (OPND_FLD((*end_opnd)) == CN_Tbl_Idx || 05586 (OPND_FLD((*end_opnd)) == AT_Tbl_Idx && 05587 ATD_CLASS(OPND_IDX((*end_opnd))) == Compiler_Tmp)) { 05588 05589 COPY_OPND(end_tmp_opnd, (*end_opnd)); 05590 } 05591 else { 05592 05593 GEN_COMPILER_TMP_ASG(asg_idx, 05594 tmp_idx, 05595 TRUE, /* Semantics done */ 05596 line, 05597 col, 05598 ATD_TYPE_IDX(lcv_attr), 05599 Priv); 05600 05601 COPY_OPND(IR_OPND_R(asg_idx), (*end_opnd)); 05602 05603 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05604 05605 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05606 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05607 05608 gen_opnd(&end_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col); 05609 } 05610 05611 /***************************************************************************\ 05612 |* temp = increment value *| 05613 \***************************************************************************/ 05614 05615 if (OPND_FLD((*inc_opnd)) == CN_Tbl_Idx && 05616 TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*inc_opnd)))) == 05617 Short_Typeless_Const) { 05618 05619 find_opnd_line_and_column(inc_opnd, &opnd_line, &opnd_col); 05620 OPND_IDX((*inc_opnd)) = cast_typeless_constant(OPND_IDX((*inc_opnd)), 05621 ATD_TYPE_IDX(lcv_attr), 05622 opnd_line, 05623 opnd_col); 05624 } 05625 05626 if (OPND_FLD((*inc_opnd)) == CN_Tbl_Idx || 05627 (OPND_FLD((*inc_opnd)) == AT_Tbl_Idx && 05628 ATD_CLASS(OPND_IDX((*inc_opnd))) == Compiler_Tmp)) { 05629 05630 COPY_OPND(inc_tmp_opnd, (*inc_opnd)); 05631 } 05632 else { 05633 05634 GEN_COMPILER_TMP_ASG(asg_idx, 05635 tmp_idx, 05636 TRUE, /* Semantics done */ 05637 line, 05638 col, 05639 ATD_TYPE_IDX(lcv_attr), 05640 Priv); 05641 05642 COPY_OPND(IR_OPND_R(asg_idx), (*inc_opnd)); 05643 05644 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05645 05646 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05647 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05648 05649 gen_opnd(&inc_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col); 05650 } 05651 05652 /***************************************************************************\ 05653 |* lcv attr = start temp *| 05654 \***************************************************************************/ 05655 05656 asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr, 05657 Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05658 OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd)); 05659 05660 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05661 05662 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05663 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05664 05665 /***************************************************************************\ 05666 |* temp = trip count expression. ((end - start) + inc)/inc *| 05667 \***************************************************************************/ 05668 05669 05670 minus_idx = gen_ir(OPND_FLD(end_tmp_opnd), OPND_IDX(end_tmp_opnd), 05671 Minus_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05672 OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd)); 05673 05674 plus_idx = gen_ir(IR_Tbl_Idx, minus_idx, 05675 Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05676 OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd)); 05677 05678 div_idx = gen_ir(IR_Tbl_Idx, plus_idx, 05679 Div_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05680 OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd)); 05681 05682 OPND_FLD(opnd) = IR_Tbl_Idx; 05683 OPND_IDX(opnd) = div_idx; 05684 05685 save_xref_state = xref_state; 05686 xref_state = CIF_No_Usage_Rec; 05687 expr_semantics(&opnd, &exp_desc); 05688 xref_state = save_xref_state; 05689 05690 if (OPND_FLD(opnd) == CN_Tbl_Idx || 05691 (OPND_FLD(opnd) == AT_Tbl_Idx && 05692 ATD_CLASS(OPND_IDX(opnd)) == Compiler_Tmp)) { 05693 05694 COPY_OPND(trip_count_tmp_opnd, opnd); 05695 } 05696 else { 05697 05698 GEN_COMPILER_TMP_ASG(asg_idx, 05699 tmp_idx, 05700 TRUE, /* Semantics done */ 05701 line, 05702 col, 05703 exp_desc.type_idx, 05704 Priv); 05705 05706 COPY_OPND(IR_OPND_R(asg_idx), opnd); 05707 05708 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05709 05710 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05711 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05712 05713 gen_opnd(&trip_count_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col); 05714 } 05715 05716 05717 /***************************************************************************\ 05718 |* branch around test for trip count <= 0 *| 05719 \***************************************************************************/ 05720 05721 log_idx = gen_ir(OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd), 05722 Le_Opr, LOGICAL_DEFAULT_TYPE, line, col, 05723 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 05724 05725 ir_idx = gen_ir(IR_Tbl_Idx, log_idx, 05726 Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col, 05727 AT_Tbl_Idx, br_around_label); 05728 05729 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05730 05731 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 05732 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05733 05734 /***************************************************************************\ 05735 |* trip counter temp = 0 *| 05736 \***************************************************************************/ 05737 05738 GEN_COMPILER_TMP_ASG(asg_idx, 05739 tmp_idx, 05740 TRUE, /* Semantics done */ 05741 line, 05742 col, 05743 CG_INTEGER_DEFAULT_TYPE, 05744 Priv); 05745 05746 gen_opnd(&IR_OPND_R(asg_idx), CN_INTEGER_ZERO_IDX, CN_Tbl_Idx, line, col); 05747 05748 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05749 05750 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05751 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05752 05753 gen_opnd(&trip_counter_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col); 05754 05755 /***************************************************************************\ 05756 |* branch back label *| 05757 \***************************************************************************/ 05758 05759 br_back_label = gen_internal_lbl(line); 05760 05761 ir_idx = gen_ir(AT_Tbl_Idx, br_back_label, 05762 Label_Opr, TYPELESS_DEFAULT_TYPE, line, col, 05763 NO_Tbl_Idx, NULL_IDX); 05764 05765 gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 05766 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 05767 05768 AT_DEFINED(br_back_label) = TRUE; 05769 ATL_DEF_STMT_IDX(br_back_label) = SH_PREV_IDX(curr_stmt_sh_idx); 05770 05771 if (in_constructor) { 05772 ATL_CONSTRUCTOR_LOOP(br_back_label) = TRUE; 05773 } 05774 05775 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05776 05777 /***************************************************************************\ 05778 |* lcv attr = start temp + (trip counter temp * increment temp) *| 05779 \***************************************************************************/ 05780 05781 mult_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 05782 OPND_IDX(trip_counter_tmp_opnd), 05783 Mult_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05784 OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd)); 05785 05786 plus_idx = gen_ir(OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd), 05787 Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05788 IR_Tbl_Idx, mult_idx); 05789 05790 asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr, 05791 Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05792 IR_Tbl_Idx, plus_idx); 05793 05794 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05795 05796 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 05797 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 05798 05799 05800 05801 /***************************************************************************\ 05802 |***************************************************************************| 05803 |** SUFFIX CODE **| 05804 |***************************************************************************| 05805 \***************************************************************************/ 05806 05807 curr_stmt_sh_idx = body_end_sh_idx; 05808 05809 /***************************************************************************\ 05810 |* trip counter temp = trip counter temp + 1 *| 05811 \***************************************************************************/ 05812 05813 plus_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 05814 OPND_IDX(trip_counter_tmp_opnd), 05815 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 05816 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 05817 05818 asg_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 05819 OPND_IDX(trip_counter_tmp_opnd), 05820 Asg_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 05821 IR_Tbl_Idx, plus_idx); 05822 05823 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05824 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 05825 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05826 05827 /***************************************************************************\ 05828 |* branch back test for trip counter temp < trip count *| 05829 \***************************************************************************/ 05830 05831 log_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 05832 OPND_IDX(trip_counter_tmp_opnd), 05833 Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 05834 OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd)); 05835 05836 ir_idx = gen_ir(IR_Tbl_Idx, log_idx, 05837 Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col, 05838 AT_Tbl_Idx, br_back_label); 05839 05840 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05841 05842 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05843 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05844 05845 05846 /***************************************************************************\ 05847 |* lcv attr = start temp + (trip count temp * increment temp) *| 05848 \***************************************************************************/ 05849 05850 mult_idx =gen_ir(OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd), 05851 Mult_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05852 OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd)); 05853 05854 plus_idx = gen_ir(OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd), 05855 Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05856 IR_Tbl_Idx, mult_idx); 05857 05858 asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr, 05859 Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col, 05860 IR_Tbl_Idx, plus_idx); 05861 05862 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05863 05864 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 05865 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05866 05867 # endif 05868 05869 05870 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05871 05872 TRACE (Func_Exit, "create_loop_stmts", NULL); 05873 05874 return; 05875 05876 } /* create_loop_stmts */ 05877 05878 /******************************************************************************\ 05879 |* *| 05880 |* Description: *| 05881 |* Create an array bounds table entry from an expr_arg_type arg *| 05882 |* All bounds info must be constant. *| 05883 |* *| 05884 |* Input parameters: *| 05885 |* NONE *| 05886 |* *| 05887 |* Output parameters: *| 05888 |* NONE *| 05889 |* *| 05890 |* Returns: *| 05891 |* NOTHING *| 05892 |* *| 05893 \******************************************************************************/ 05894 05895 int create_bd_ntry_for_const(expr_arg_type *exp_desc, 05896 int line, 05897 int col) 05898 05899 { 05900 int bd_idx; 05901 size_offset_type extent; 05902 int i; 05903 size_offset_type num_elements; 05904 size_offset_type stride; 05905 05906 05907 TRACE (Func_Entry, "create_bd_ntry_for_const", NULL); 05908 05909 bd_idx = reserve_array_ntry(exp_desc->rank); 05910 BD_RANK(bd_idx) = exp_desc->rank; 05911 BD_LINE_NUM(bd_idx) = line; 05912 BD_COLUMN_NUM(bd_idx) = col; 05913 BD_ARRAY_SIZE(bd_idx) = Constant_Size; 05914 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape; 05915 BD_RESOLVED(bd_idx) = TRUE; 05916 05917 num_elements.idx = CN_INTEGER_ONE_IDX; 05918 num_elements.fld = CN_Tbl_Idx; 05919 05920 for (i = 1; i <= exp_desc->rank; i++) { 05921 BD_LB_FLD(bd_idx,i) = CN_Tbl_Idx; 05922 BD_LB_IDX(bd_idx,i) = CN_INTEGER_ONE_IDX; 05923 05924 if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx) { 05925 BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]); 05926 BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]); 05927 } 05928 else { 05929 PRINTMSG(line, 966, Internal, col); 05930 } 05931 05932 BD_XT_FLD(bd_idx,i) = BD_UB_FLD(bd_idx,i); 05933 BD_XT_IDX(bd_idx,i) = BD_UB_IDX(bd_idx,i); 05934 05935 extent.fld = BD_XT_FLD(bd_idx,i); 05936 extent.idx = BD_XT_IDX(bd_idx,i); 05937 05938 size_offset_binary_calc(&extent, 05939 &num_elements, 05940 Mult_Opr, 05941 &num_elements); 05942 } 05943 05944 if (num_elements.fld == NO_Tbl_Idx) { 05945 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx; 05946 BD_LEN_IDX(bd_idx) = ntr_const_tbl(num_elements.type_idx, 05947 FALSE, 05948 num_elements.constant); 05949 } 05950 else { 05951 BD_LEN_FLD(bd_idx) = num_elements.fld; 05952 BD_LEN_IDX(bd_idx) = num_elements.idx; 05953 } 05954 05955 /* fill in stride multipliers now */ 05956 05957 set_stride_for_first_dim(exp_desc->type_idx, &stride); 05958 05959 BD_SM_FLD(bd_idx, 1) = stride.fld; 05960 BD_SM_IDX(bd_idx, 1) = stride.idx; 05961 05962 for (i = 2; i <= BD_RANK(bd_idx); i++) { 05963 extent.fld = BD_XT_FLD(bd_idx,i-1); 05964 extent.idx = BD_XT_IDX(bd_idx,i-1); 05965 05966 size_offset_binary_calc(&extent, &stride, Mult_Opr, &stride); 05967 05968 if (stride.fld == NO_Tbl_Idx) { 05969 stride.fld = CN_Tbl_Idx; 05970 stride.idx = ntr_const_tbl(stride.type_idx, 05971 FALSE, 05972 stride.constant); 05973 } 05974 05975 BD_SM_FLD(bd_idx, i) = stride.fld; 05976 BD_SM_IDX(bd_idx, i) = stride.idx; 05977 } 05978 05979 bd_idx = ntr_array_in_bd_tbl(bd_idx); 05980 05981 TRACE (Func_Exit, "create_bd_ntry_for_const", NULL); 05982 05983 return(bd_idx); 05984 05985 } /* create_bd_ntry_for_const */ 05986 05987 /******************************************************************************\ 05988 |* *| 05989 |* Description: *| 05990 |* Fold the clen_opr if possible. *| 05991 |* *| 05992 |* Input parameters: *| 05993 |* NONE *| 05994 |* *| 05995 |* Output parameters: *| 05996 |* NONE *| 05997 |* *| 05998 |* Returns: *| 05999 |* NOTHING *| 06000 |* *| 06001 \******************************************************************************/ 06002 06003 void fold_clen_opr(opnd_type *opnd, 06004 expr_arg_type *exp_desc) 06005 06006 { 06007 int attr_idx; 06008 int clen_idx; 06009 int col; 06010 int ir_idx; 06011 int line; 06012 int list_idx; 06013 int shift_idx; 06014 int type_idx; 06015 06016 06017 TRACE (Func_Entry, "fold_clen_opr", NULL); 06018 06019 find_opnd_line_and_column(opnd, &line, &col); 06020 06021 if (OPND_FLD((*opnd)) != IR_Tbl_Idx || 06022 IR_OPR(OPND_IDX((*opnd))) != Clen_Opr) { 06023 06024 goto EXIT; 06025 } 06026 06027 clen_idx = OPND_IDX((*opnd)); 06028 06029 exp_desc->type_idx = IR_TYPE_IDX(clen_idx); 06030 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 06031 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 06032 06033 switch (IR_FLD_L(clen_idx)) { 06034 case AT_Tbl_Idx : 06035 attr_idx = IR_IDX_L(clen_idx); 06036 06037 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 06038 (ATD_IM_A_DOPE(attr_idx) || 06039 ATD_POINTER(attr_idx) || 06040 ATD_ALLOCATABLE(attr_idx))) { 06041 06042 if (char_len_in_bytes) { 06043 06044 /* the length is already in bytes for solaris */ 06045 06046 NTR_IR_TBL(ir_idx); 06047 IR_OPR(ir_idx) = Dv_Access_El_Len; 06048 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 06049 IR_LINE_NUM(ir_idx) = line; 06050 IR_COL_NUM(ir_idx) = col; 06051 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(clen_idx)); 06052 06053 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06054 OPND_IDX((*opnd)) = ir_idx; 06055 } 06056 else { 06057 06058 /* must shift the bits to bytes */ 06059 06060 NTR_IR_TBL(ir_idx); 06061 IR_OPR(ir_idx) = Dv_Access_El_Len; 06062 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 06063 IR_LINE_NUM(ir_idx) = line; 06064 IR_COL_NUM(ir_idx) = col; 06065 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(clen_idx)); 06066 NTR_IR_TBL(shift_idx); 06067 IR_OPR(shift_idx) = Shiftr_Opr; 06068 IR_TYPE_IDX(shift_idx) = SA_INTEGER_DEFAULT_TYPE; 06069 IR_LINE_NUM(shift_idx) = line; 06070 IR_COL_NUM(shift_idx) = col; 06071 06072 NTR_IR_LIST_TBL(list_idx); 06073 06074 IR_FLD_L(shift_idx) = IL_Tbl_Idx; 06075 IR_IDX_L(shift_idx) = list_idx; 06076 IR_LIST_CNT_L(shift_idx) = 2; 06077 IL_FLD(list_idx) = IR_Tbl_Idx; 06078 IL_IDX(list_idx) = ir_idx; 06079 06080 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06081 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06082 list_idx = IL_NEXT_LIST_IDX(list_idx); 06083 06084 IL_FLD(list_idx) = CN_Tbl_Idx; 06085 IL_LINE_NUM(list_idx) = line; 06086 IL_COL_NUM(list_idx) = col; 06087 IL_IDX(list_idx) = CN_INTEGER_THREE_IDX; 06088 06089 OPND_FLD((*opnd)) = IR_Tbl_Idx; 06090 OPND_IDX((*opnd)) = shift_idx; 06091 } 06092 06093 exp_desc->type_idx = CG_INTEGER_DEFAULT_TYPE; 06094 exp_desc->type = Integer; 06095 exp_desc->linear_type = CG_INTEGER_DEFAULT_TYPE; 06096 } 06097 break; 06098 06099 case CN_Tbl_Idx : 06100 type_idx = CN_TYPE_IDX(IR_IDX_L(clen_idx)); 06101 OPND_FLD((*opnd)) = TYP_FLD(type_idx); 06102 OPND_IDX((*opnd)) = TYP_IDX(type_idx); 06103 OPND_LINE_NUM((*opnd)) = line; 06104 OPND_COL_NUM((*opnd)) = col; 06105 exp_desc->constant = TRUE; 06106 exp_desc->foldable = TRUE; 06107 06108 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 06109 exp_desc->type_idx = CN_TYPE_IDX(TYP_IDX(type_idx)); 06110 } 06111 else { 06112 exp_desc->type_idx = ATD_TYPE_IDX(TYP_IDX(type_idx)); 06113 } 06114 06115 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 06116 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 06117 break; 06118 06119 case IR_Tbl_Idx : 06120 06121 ir_idx = IR_IDX_L(clen_idx); 06122 06123 if ((IR_OPR(ir_idx) == Substring_Opr || 06124 IR_OPR(ir_idx) == Whole_Substring_Opr) && 06125 IL_FLD(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)))) 06126 != NO_Tbl_Idx) { 06127 06128 COPY_OPND((*opnd), IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX( 06129 IR_IDX_R(ir_idx))))); 06130 06131 if (OPND_FLD((*opnd)) == CN_Tbl_Idx) { 06132 exp_desc->type_idx = CN_TYPE_IDX(OPND_IDX((*opnd))); 06133 exp_desc->constant = TRUE; 06134 exp_desc->foldable = TRUE; 06135 } 06136 else if (OPND_FLD((*opnd)) == IR_Tbl_Idx) { 06137 exp_desc->type_idx = IR_TYPE_IDX(OPND_IDX((*opnd))); 06138 } 06139 else if (OPND_FLD((*opnd)) == AT_Tbl_Idx) { 06140 exp_desc->type_idx = ATD_TYPE_IDX(OPND_IDX((*opnd))); 06141 } 06142 06143 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 06144 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 06145 } 06146 break; 06147 } 06148 06149 EXIT: 06150 06151 TRACE (Func_Exit, "fold_clen_opr", NULL); 06152 06153 return; 06154 06155 } /* fold_clen_opr */ 06156 06157 /******************************************************************************\ 06158 |* *| 06159 |* Description: *| 06160 |* <description> *| 06161 |* *| 06162 |* Input parameters: *| 06163 |* NONE *| 06164 |* *| 06165 |* Output parameters: *| 06166 |* NONE *| 06167 |* *| 06168 |* Returns: *| 06169 |* NOTHING *| 06170 |* *| 06171 \******************************************************************************/ 06172 06173 void set_shape_for_deferred_funcs(expr_arg_type *exp_desc, 06174 int call_idx) 06175 06176 { 06177 int attr_idx; 06178 int bd_idx; 06179 int ch_idx = NULL_IDX; 06180 int col; 06181 int dummy_idx; 06182 boolean has_sf = FALSE; 06183 int i; 06184 int ir_idx; 06185 int line; 06186 int list_idx; 06187 expr_arg_type loc_exp_desc; 06188 int minus_idx; 06189 opnd_type opnd; 06190 int plus_idx; 06191 int pgm_idx; 06192 cif_usage_code_type save_xref_state; 06193 int sn_idx; 06194 06195 06196 TRACE (Func_Entry, "set_shape_for_deferred_funcs", NULL); 06197 06198 pgm_idx = IR_IDX_L(call_idx); 06199 attr_idx = ATP_RSLT_IDX(IR_IDX_L(call_idx)); 06200 bd_idx = ATD_ARRAY_IDX(attr_idx); 06201 06202 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 06203 ch_idx = ATD_TYPE_IDX(attr_idx); 06204 } 06205 06206 if ((bd_idx && BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) || 06207 (ch_idx && TYP_FLD(ch_idx) == AT_Tbl_Idx)) { 06208 06209 has_sf = TRUE; 06210 06211 /* set up the dummy args as stmt func dargs */ 06212 06213 list_idx = IR_IDX_R(call_idx); 06214 sn_idx = ATP_FIRST_IDX(pgm_idx); 06215 06216 if (ATP_EXTRA_DARG(pgm_idx)) { 06217 sn_idx++; 06218 } 06219 06220 for (i = 0; i < IR_LIST_CNT_R(call_idx); i++) { 06221 dummy_idx = SN_ATTR_IDX(sn_idx); 06222 06223 ATD_SF_DARG(dummy_idx) = TRUE; 06224 06225 ATD_SF_LINK(dummy_idx) = IL_ARG_DESC_IDX(list_idx); 06226 COPY_OPND(opnd, IL_OPND(list_idx)); 06227 06228 if (arg_info_list[ATD_SF_LINK(dummy_idx)].ed.reference && 06229 OPND_FLD(opnd) == IR_Tbl_Idx) { 06230 06231 if (IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr) { 06232 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 06233 } 06234 06235 if (OPND_FLD(opnd) == IR_Tbl_Idx && 06236 IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) { 06237 06238 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 06239 } 06240 06241 /* whole subscript and substring need to be removed */ 06242 /* since we don't know how these args will be referenced. */ 06243 /* I don't think dv_deref_oprs need to be removed. */ 06244 } 06245 06246 ATD_FLD(dummy_idx) = OPND_FLD(opnd); 06247 ATD_SF_ARG_IDX(dummy_idx) = OPND_IDX(opnd); 06248 06249 sn_idx++; 06250 list_idx = IL_NEXT_LIST_IDX(list_idx); 06251 } 06252 } 06253 06254 line = IR_LINE_NUM(call_idx); 06255 col = IR_COL_NUM(call_idx); 06256 06257 if (ch_idx) { 06258 /* fill in exp_desc->char_len */ 06259 06260 if (TYP_CHAR_CLASS(ch_idx) == Const_Len_Char) { 06261 exp_desc->char_len.fld = TYP_FLD(ch_idx); 06262 exp_desc->char_len.idx = TYP_IDX(ch_idx); 06263 } 06264 else if (TYP_FLD(ch_idx) == AT_Tbl_Idx) { 06265 06266 if (TYP_CHAR_CLASS(ch_idx) == Assumed_Size_Char) { 06267 /* TYP_ORIG_LEN_IDX not set for Assumed_Size_Char */ 06268 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_IDX(ch_idx)))); 06269 } 06270 else { 06271 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_ORIG_LEN_IDX(ch_idx)))); 06272 } 06273 06274 copy_subtree(&opnd, &opnd); 06275 06276 loc_exp_desc.rank = 0; 06277 save_xref_state = xref_state; 06278 xref_state = CIF_No_Usage_Rec; 06279 expr_semantics(&opnd, &loc_exp_desc); 06280 xref_state = save_xref_state; 06281 06282 COPY_OPND((exp_desc->char_len), opnd); 06283 } 06284 } 06285 06286 if (bd_idx) { 06287 06288 switch (BD_ARRAY_CLASS(bd_idx)) { 06289 06290 case Explicit_Shape : 06291 case Deferred_Shape : 06292 case Assumed_Shape : 06293 06294 if (BD_ARRAY_SIZE(bd_idx) == Constant_Size) { 06295 get_shape_from_attr(exp_desc, 06296 attr_idx, 06297 exp_desc->rank, 06298 IR_LINE_NUM(call_idx), 06299 IR_COL_NUM(call_idx)); 06300 } 06301 else if (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) { 06302 06303 /* set up extent expression for each dim */ 06304 06305 for (i = 0; i < BD_RANK(bd_idx); i++) { 06306 06307 NTR_IR_TBL(plus_idx); 06308 IR_OPR(plus_idx) = Plus_Opr; 06309 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 06310 IR_LINE_NUM(plus_idx) = line; 06311 IR_COL_NUM(plus_idx) = col; 06312 06313 IR_FLD_R(plus_idx) = CN_Tbl_Idx; 06314 IR_IDX_R(plus_idx) = CN_INTEGER_ONE_IDX; 06315 IR_LINE_NUM_R(plus_idx) = line; 06316 IR_COL_NUM_R(plus_idx) = col; 06317 06318 NTR_IR_TBL(minus_idx); 06319 IR_OPR(minus_idx) = Minus_Opr; 06320 IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE; 06321 IR_LINE_NUM(minus_idx) = line; 06322 IR_COL_NUM(minus_idx) = col; 06323 06324 IR_FLD_L(plus_idx) = IR_Tbl_Idx; 06325 IR_IDX_L(plus_idx) = minus_idx; 06326 06327 if (BD_LB_FLD(bd_idx,i+1) == AT_Tbl_Idx) { 06328 COPY_OPND(IR_OPND_R(minus_idx), 06329 IR_OPND_R(ATD_TMP_IDX(BD_LB_IDX(bd_idx,i+1)))); 06330 } 06331 else { 06332 IR_FLD_R(minus_idx) = BD_LB_FLD(bd_idx, i+1); 06333 IR_IDX_R(minus_idx) = BD_LB_IDX(bd_idx, i+1); 06334 IR_LINE_NUM_R(minus_idx) = line; 06335 IR_COL_NUM_R(minus_idx) = col; 06336 } 06337 06338 COPY_OPND(opnd, IR_OPND_R(minus_idx)); 06339 copy_subtree(&opnd, &opnd); 06340 COPY_OPND(IR_OPND_R(minus_idx), opnd); 06341 06342 if (BD_UB_FLD(bd_idx,i+1) == AT_Tbl_Idx) { 06343 COPY_OPND(IR_OPND_L(minus_idx), 06344 IR_OPND_R(ATD_TMP_IDX(BD_UB_IDX(bd_idx,i+1)))); 06345 } 06346 else { 06347 IR_FLD_L(minus_idx) = BD_UB_FLD(bd_idx, i+1); 06348 IR_IDX_L(minus_idx) = BD_UB_IDX(bd_idx, i+1); 06349 IR_LINE_NUM_L(minus_idx) = line; 06350 IR_COL_NUM_L(minus_idx) = col; 06351 } 06352 06353 COPY_OPND(opnd, IR_OPND_L(minus_idx)); 06354 copy_subtree(&opnd, &opnd); 06355 COPY_OPND(IR_OPND_L(minus_idx), opnd); 06356 06357 OPND_FLD(opnd) = IR_Tbl_Idx; 06358 OPND_IDX(opnd) = plus_idx; 06359 06360 loc_exp_desc.rank = 0; 06361 save_xref_state = xref_state; 06362 xref_state = CIF_No_Usage_Rec; 06363 expr_semantics(&opnd, &loc_exp_desc); 06364 xref_state = save_xref_state; 06365 06366 COPY_OPND((exp_desc->shape[i]), opnd); 06367 SHAPE_FOLDABLE(exp_desc->shape[i]) = loc_exp_desc.foldable; 06368 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = 06369 loc_exp_desc.will_fold_later; 06370 } 06371 } 06372 break; 06373 06374 case Assumed_Size : 06375 /* don't know what to do here */ 06376 /* probable shouldn't get here */ 06377 PRINTMSG(IR_LINE_NUM(call_idx), 968, Internal, 06378 IR_COL_NUM(call_idx)); 06379 06380 break; 06381 #if 0 /*fzhao*/ 06382 for (i = 0; i < BD_RANK(bd_idx); i++) { 06383 06384 NTR_IR_TBL(ir_idx); 06385 IR_OPR(ir_idx) = Dv_Access_Extent; 06386 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 06387 IR_DV_DIM(ir_idx) = i + 1; 06388 06389 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 06390 IR_IDX_L(ir_idx) = attr_idx; 06391 06392 IR_LINE_NUM(ir_idx) = IR_LINE_NUM(call_idx); 06393 IR_COL_NUM(ir_idx) = IR_COL_NUM(call_idx); 06394 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(call_idx); 06395 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(call_idx); 06396 06397 exp_desc->shape[i].fld = IR_Tbl_Idx; 06398 exp_desc->shape[i].idx = ir_idx; 06399 SHAPE_FOLDABLE(exp_desc->shape[i]) = FALSE; 06400 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = FALSE; 06401 } 06402 break; 06403 #endif 06404 06405 } 06406 } 06407 06408 if (has_sf) { 06409 sn_idx = ATP_FIRST_IDX(pgm_idx); 06410 06411 if (ATP_EXTRA_DARG(pgm_idx)) { 06412 sn_idx++; 06413 } 06414 06415 for (i = 0; i < IR_LIST_CNT_R(call_idx); i++) { 06416 ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = FALSE; 06417 sn_idx++; 06418 } 06419 } 06420 06421 06422 TRACE (Func_Exit, "set_shape_for_deferred_funcs", NULL); 06423 06424 return; 06425 06426 } /* set_shape_for_deferred_funcs */ 06427 06428 /******************************************************************************\ 06429 |* *| 06430 |* Description: *| 06431 |* Create an internal dope vector for use in folding array intrinsics. *| 06432 |* *| 06433 |* Input parameters: *| 06434 |* dope_vec - address of internal dope vector to fill in. *| 06435 |* r_opnd - address of opnd pointing to "target". *| 06436 |* just_init- TRUE => just initialize header. *| 06437 |* exp_desc - address of the expression descriptor of target. *| 06438 |* *| 06439 |* Output parameters: *| 06440 |* NONE *| 06441 |* *| 06442 |* Returns: *| 06443 |* NOTHING *| 06444 |* *| 06445 \******************************************************************************/ 06446 06447 boolean gen_internal_dope_vector(int_dope_type *dope_vec, 06448 opnd_type *r_opnd, 06449 boolean just_init, 06450 expr_arg_type *exp_desc) 06451 06452 { 06453 int bd_idx; 06454 int cn_idx; 06455 int column; 06456 long_type constant[2]; 06457 int i; 06458 # if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS) 06459 _fcd fcd_r; 06460 # endif 06461 int line; 06462 boolean ok = TRUE; 06463 opnd_type opnd; 06464 int type_idx; 06465 06466 06467 TRACE (Func_Entry, "gen_internal_dope_vector", NULL); 06468 06469 type_idx = exp_desc->type_idx; 06470 06471 /*********************************************\ 06472 |* see if we need to assign r_opnd to a tmp. *| 06473 \*********************************************/ 06474 06475 if (just_init) { 06476 /* intentionally blank */ 06477 } 06478 else if (OPND_FLD((*r_opnd)) == CN_Tbl_Idx) { 06479 cn_idx = OPND_IDX((*r_opnd)); 06480 } 06481 else if ((exp_desc->reference || 06482 exp_desc->tmp_reference) && 06483 ! exp_desc->section) { 06484 06485 COPY_OPND(opnd, (*r_opnd)); 06486 06487 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 06488 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 06489 } 06490 06491 if (ATD_FLD(OPND_IDX(opnd)) == IR_Tbl_Idx) { 06492 COPY_OPND(opnd, (*r_opnd)); 06493 06494 if (fold_aggragate_expression(&opnd, exp_desc, TRUE)) { 06495 cn_idx = OPND_IDX(opnd); 06496 06497 if (exp_desc->rank) { 06498 bd_idx = create_bd_ntry_for_const(exp_desc, 06499 stmt_start_line, 06500 stmt_start_col); 06501 } 06502 } 06503 else { 06504 ok = FALSE; 06505 goto EXIT; 06506 } 06507 } 06508 else { 06509 if (ATD_CLASS(OPND_IDX(opnd)) == Constant) { 06510 cn_idx = ATD_CONST_IDX(OPND_IDX(opnd)); 06511 } 06512 else { 06513 cn_idx = ATD_TMP_IDX(OPND_IDX(opnd)); 06514 } 06515 06516 bd_idx = ATD_ARRAY_IDX(OPND_IDX(opnd)); 06517 } 06518 } 06519 else { 06520 COPY_OPND(opnd, (*r_opnd)); 06521 06522 if (fold_aggragate_expression(&opnd, exp_desc, TRUE)) { 06523 cn_idx = OPND_IDX(opnd); 06524 06525 if (exp_desc->rank) { 06526 bd_idx = create_bd_ntry_for_const(exp_desc, 06527 stmt_start_line, 06528 stmt_start_col); 06529 } 06530 } 06531 else { 06532 ok = FALSE; 06533 goto EXIT; 06534 } 06535 } 06536 06537 # ifdef _TARGET_OS_MAX /* BRIANJ */ 06538 if (! just_init && 06539 TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == Complex_4) { 06540 /* must pack it into one word (an Integer_8 constant) */ 06541 06542 constant[0] = CN_CONST(cn_idx) << 32; 06543 constant[0] |= (CP_CONSTANT(CN_POOL_IDX(cn_idx) + 1) & 0xFFFFFFFF); 06544 06545 cn_idx = ntr_const_tbl(Integer_8, 06546 FALSE, 06547 constant); 06548 } 06549 else 06550 # endif 06551 if (! just_init && 06552 exp_desc->rank == 0 && 06553 exp_desc->type != Character && 06554 exp_desc->type != Structure && 06555 storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(cn_idx))] < 06556 TARGET_BITS_PER_WORD) { 06557 06558 /* must shift the constant so that it is left justified */ 06559 /* word size integer (CG_INTEGER_DEFAULT_TYPE) */ 06560 06561 constant[0] = CN_CONST(cn_idx) << (TARGET_BITS_PER_WORD - 06562 storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]); 06563 06564 cn_idx = ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE, 06565 FALSE, 06566 constant); 06567 } 06568 06569 /*************\ 06570 |* BASE ADDR *| 06571 \*************/ 06572 06573 if (just_init) { 06574 dope_vec->base_addr = 0; 06575 } 06576 # if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS) 06577 06578 /* BRIANJ */ 06579 06580 else if (exp_desc->type == Character) { 06581 fcd_r = _cptofcd((char *)&CN_CONST(cn_idx), 06582 CN_INT_TO_C(TYP_IDX(exp_desc->type_idx))); 06583 dope_vec->base_addr = *(int *)&fcd_r; 06584 } 06585 else if (exp_desc->type == Structure && 06586 ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) { 06587 fcd_r = _cptofcd((char *)&CN_CONST(cn_idx), 06588 (CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(exp_desc->type_idx)))) >> 3); 06589 dope_vec->base_addr = *(int *)&fcd_r; 06590 } 06591 # endif 06592 else { 06593 dope_vec->base_addr = (long)&CN_CONST(cn_idx); 06594 } 06595 06596 /*************\ 06597 |* EL_LEN *| 06598 \*************/ 06599 06600 find_opnd_line_and_column(r_opnd, &line, &column); 06601 06602 if (exp_desc->type == Structure) { 06603 06604 cn_idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 06605 if (compare_cn_and_value(cn_idx, 06606 MAX_DV_EL_LEN, 06607 Ge_Opr)) { 06608 PRINTMSG(line, 1174, Error, column, CN_INT_TO_C(cn_idx),MAX_DV_EL_LEN); 06609 dope_vec->el_len = MAX_DV_EL_LEN; 06610 } 06611 else { /* BRIANJ */ 06612 dope_vec->el_len = CN_INT_TO_C(cn_idx); 06613 } 06614 } 06615 else if (exp_desc->type == Character) { 06616 06617 if (exp_desc->char_len.fld == CN_Tbl_Idx) { 06618 06619 if (char_len_in_bytes) { 06620 06621 if (compare_cn_and_value(exp_desc->char_len.idx, 06622 MAX_DV_EL_LEN, 06623 Ge_Opr)) { 06624 PRINTMSG(line, 1174, Error, column, 06625 CN_INT_TO_C(exp_desc->char_len.idx), 06626 MAX_DV_EL_LEN); 06627 dope_vec->el_len = MAX_DV_EL_LEN; 06628 } 06629 else { 06630 dope_vec->el_len = CN_INT_TO_C(exp_desc->char_len.idx); 06631 } 06632 } 06633 else { 06634 06635 if (compare_cn_and_value(exp_desc->char_len.idx, 06636 MAX_DV_EL_LEN/8, 06637 Ge_Opr)) { 06638 PRINTMSG(line, 1174, Error, column, 06639 CN_INT_TO_C(exp_desc->char_len.idx), 06640 MAX_DV_EL_LEN/8); 06641 dope_vec->el_len = MAX_DV_EL_LEN; 06642 } 06643 else { 06644 dope_vec->el_len = CN_INT_TO_C(exp_desc->char_len.idx)*8; 06645 } 06646 } 06647 } 06648 else { 06649 PRINTMSG(line, 969, Internal, column); 06650 } 06651 } 06652 else { 06653 dope_vec->el_len = storage_bit_size_tbl[exp_desc->linear_type]; 06654 } 06655 06656 /*************\ 06657 |* ASSOC *| 06658 \*************/ 06659 06660 if (just_init) { 06661 dope_vec->assoc = 0; 06662 } 06663 else { 06664 dope_vec->assoc = 1; 06665 } 06666 06667 /*************\ 06668 |* PTR_ALLOC *| 06669 \*************/ 06670 06671 dope_vec->ptr_alloc = 0; 06672 06673 /*************\ 06674 |* P_OR_A *| 06675 \*************/ 06676 06677 dope_vec->p_or_a = 1; /* pointer */ 06678 06679 /*************\ 06680 |* A_CONTIG *| 06681 \*************/ 06682 06683 dope_vec->a_contig = 0; 06684 06685 /*************\ 06686 |* UNUSED 1 *| 06687 \*************/ 06688 06689 dope_vec->unused_1 = 0; 06690 06691 # if defined(_TARGET64) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 06692 /*************\ 06693 |* UNUSED 2 *| 06694 \*************/ 06695 06696 dope_vec->unused_2 = 0; 06697 # endif 06698 06699 06700 /*************\ 06701 |* N_DIM *| 06702 \*************/ 06703 06704 dope_vec->num_dims = exp_desc->rank; 06705 06706 # if defined(_TARGET64) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 06707 # ifndef _TYPE_CODE_64_BIT 06708 /*************\ 06709 |* UNUSED 3 *| 06710 \*************/ 06711 06712 dope_vec->unused_3 = 0; 06713 # endif 06714 # endif 06715 06716 /*************\ 06717 |* TYPE_CODE *| 06718 \*************/ 06719 06720 make_io_type_code(type_idx, constant); 06721 # ifdef _TYPE_CODE_64_BIT 06722 dope_vec->type_code = *(f90_type_t *)constant; 06723 # else 06724 dope_vec->type_code = *constant; 06725 # endif 06726 06727 /*************\ 06728 |* ORIG_BASE *| 06729 \*************/ 06730 06731 dope_vec->orig_base = 0; 06732 06733 /*************\ 06734 |* ORIG_SIZE *| 06735 \*************/ 06736 06737 dope_vec->orig_size = 0; 06738 06739 for (i = 0; i < exp_desc->rank; i++) { 06740 06741 /*************\ 06742 |* DIM i LB *| 06743 \*************/ 06744 06745 if (just_init) { 06746 dope_vec->dim[i].low_bound = 0; 06747 } 06748 else { 06749 /* set to one */ 06750 dope_vec->dim[i].low_bound = 1; 06751 } 06752 06753 06754 /*************\ 06755 |* DIM i EX *| 06756 \*************/ 06757 06758 if (just_init) { 06759 dope_vec->dim[i].extent = 0; 06760 } 06761 else if (compare_cn_and_value(BD_XT_IDX(bd_idx, i+1), 0, Lt_Opr)) { 06762 dope_vec->dim[i].extent = 0; 06763 } 06764 else { /* BRIANJ */ 06765 dope_vec->dim[i].extent = CN_INT_TO_C(BD_XT_IDX(bd_idx, i+1)); 06766 } 06767 06768 /*************\ 06769 |* DIM i SM *| 06770 \*************/ 06771 06772 if (just_init) { 06773 dope_vec->dim[i].stride_mult = 0; 06774 } 06775 else { /* BRIANJ */ 06776 dope_vec->dim[i].stride_mult = CN_INT_TO_C(BD_SM_IDX(bd_idx, i+1)); 06777 } 06778 } 06779 06780 EXIT: 06781 06782 TRACE (Func_Exit, "gen_internal_dope_vector", NULL); 06783 06784 return(ok); 06785 06786 } /* gen_internal_dope_vector */ 06787 06788 /******************************************************************************\ 06789 |* *| 06790 |* Description: *| 06791 |* Transform a reference of character sequence derived type to a *| 06792 |* substring reference of the first component. *| 06793 |* *| 06794 |* Input parameters: *| 06795 |* top_opnd - address of top of tree. *| 06796 |* type_idx - idx to type table. *| 06797 |* *| 06798 |* Output parameters: *| 06799 |* top_opnd - address of top of new tree. *| 06800 |* *| 06801 |* Returns: *| 06802 |* NOTHING *| 06803 |* *| 06804 \******************************************************************************/ 06805 06806 void transform_char_sequence_ref(opnd_type *top_opnd, 06807 int type_idx) 06808 06809 { 06810 int col; 06811 int ir_idx; 06812 size_offset_type length; 06813 int line; 06814 int list_idx; 06815 size_offset_type num_chars; 06816 opnd_type opnd; 06817 06818 # if 0 06819 int attr_idx; 06820 int bd_idx; 06821 int i; 06822 # endif 06823 06824 TRACE (Func_Entry, "transform_char_sequence_ref", NULL); 06825 06826 switch (OPND_FLD((*top_opnd))) { 06827 case AT_Tbl_Idx : 06828 06829 if (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*top_opnd)))) == Structure && 06830 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(OPND_IDX((*top_opnd)))))) { 06831 06832 goto REFERENCE; 06833 } 06834 else { 06835 goto EXIT; 06836 } 06837 06838 case IR_Tbl_Idx : 06839 06840 # ifdef _DEBUG 06841 if (IR_TYPE_IDX(OPND_IDX((*top_opnd))) == NULL_IDX) { 06842 print_ir(OPND_IDX((*top_opnd))); 06843 find_opnd_line_and_column(top_opnd, &line, &col); 06844 PRINTMSG(line, 993, Internal, col); 06845 } 06846 # endif 06847 06848 if ((IR_OPR(OPND_IDX((*top_opnd))) == Struct_Opr || 06849 IR_OPR(OPND_IDX((*top_opnd))) == Dv_Deref_Opr || 06850 IR_OPR(OPND_IDX((*top_opnd))) == Subscript_Opr || 06851 IR_OPR(OPND_IDX((*top_opnd))) == Whole_Subscript_Opr || 06852 IR_OPR(OPND_IDX((*top_opnd))) == Section_Subscript_Opr) && 06853 TYP_TYPE(IR_TYPE_IDX(OPND_IDX((*top_opnd)))) == Structure && 06854 ATT_CHAR_SEQ(TYP_IDX(IR_TYPE_IDX(OPND_IDX((*top_opnd)))))) { 06855 06856 goto REFERENCE; 06857 } 06858 else if (TYP_TYPE(IR_TYPE_IDX(OPND_IDX((*top_opnd)))) != Structure || 06859 ! ATT_CHAR_SEQ(TYP_IDX(IR_TYPE_IDX(OPND_IDX((*top_opnd)))))) { 06860 06861 COPY_OPND(opnd, IR_OPND_L(OPND_IDX((*top_opnd)))); 06862 transform_char_sequence_ref(&opnd, type_idx); 06863 COPY_OPND(IR_OPND_L(OPND_IDX((*top_opnd))), opnd); 06864 06865 COPY_OPND(opnd, IR_OPND_R(OPND_IDX((*top_opnd)))); 06866 transform_char_sequence_ref(&opnd, type_idx); 06867 COPY_OPND(IR_OPND_R(OPND_IDX((*top_opnd))), opnd); 06868 06869 goto EXIT; 06870 } 06871 else { 06872 COPY_OPND(opnd, IR_OPND_L(OPND_IDX((*top_opnd)))); 06873 transform_char_sequence_ref(&opnd, type_idx); 06874 COPY_OPND(IR_OPND_L(OPND_IDX((*top_opnd))), opnd); 06875 06876 COPY_OPND(opnd, IR_OPND_R(OPND_IDX((*top_opnd)))); 06877 transform_char_sequence_ref(&opnd, type_idx); 06878 COPY_OPND(IR_OPND_R(OPND_IDX((*top_opnd))), opnd); 06879 06880 find_opnd_line_and_column(top_opnd, &line, &col); 06881 06882 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 06883 06884 TYP_TYPE(TYP_WORK_IDX) = Character; 06885 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 06886 TYP_DESC(TYP_WORK_IDX) = Default_Typed; 06887 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 06888 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 06889 06890 num_chars.idx = CN_INTEGER_CHAR_BIT_IDX; 06891 num_chars.fld = CN_Tbl_Idx; 06892 06893 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 06894 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 06895 06896 size_offset_binary_calc(&length, &num_chars, Div_Opr, &num_chars); 06897 06898 if (num_chars.fld == NO_Tbl_Idx) { 06899 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 06900 TYP_IDX(TYP_WORK_IDX) = ntr_const_tbl(num_chars.type_idx, 06901 FALSE, 06902 num_chars.constant); 06903 } 06904 else { 06905 TYP_FLD(TYP_WORK_IDX) = num_chars.fld; 06906 TYP_IDX(TYP_WORK_IDX) = num_chars.idx; 06907 } 06908 06909 IR_TYPE_IDX(OPND_IDX((*top_opnd))) = ntr_type_tbl(); 06910 goto EXIT; 06911 } 06912 06913 /* break; - Both sides of the IF end with GOTOs */ 06914 06915 case IL_Tbl_Idx : 06916 list_idx = OPND_IDX((*top_opnd)); 06917 06918 while (list_idx) { 06919 COPY_OPND(opnd, IL_OPND(list_idx)); 06920 transform_char_sequence_ref(&opnd, type_idx); 06921 COPY_OPND(IL_OPND(list_idx), opnd); 06922 06923 list_idx = IL_NEXT_LIST_IDX(list_idx); 06924 } 06925 goto EXIT; 06926 06927 case CN_Tbl_Idx : 06928 case SH_Tbl_Idx : 06929 case NO_Tbl_Idx : 06930 goto EXIT; 06931 } 06932 06933 REFERENCE: 06934 06935 find_opnd_line_and_column(top_opnd, &line, &col); 06936 06937 num_chars.idx = CN_INTEGER_CHAR_BIT_IDX; 06938 num_chars.fld = CN_Tbl_Idx; 06939 length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 06940 length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 06941 06942 size_offset_binary_calc(&length, &num_chars, Div_Opr, &num_chars); 06943 06944 # if 0 06945 while (TYP_TYPE(type_idx) == Structure) { 06946 06947 attr_idx = SN_ATTR_IDX(ATT_FIRST_CPNT_IDX(TYP_IDX(type_idx))); 06948 06949 NTR_IR_TBL(ir_idx); 06950 IR_OPR(ir_idx) = Struct_Opr; 06951 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 06952 IR_LINE_NUM(ir_idx) = line; 06953 IR_COL_NUM(ir_idx) = col; 06954 COPY_OPND(IR_OPND_L(ir_idx), (*top_opnd)); 06955 OPND_FLD((*top_opnd)) = IR_Tbl_Idx; 06956 OPND_IDX((*top_opnd)) = ir_idx; 06957 06958 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 06959 IR_IDX_R(ir_idx) = attr_idx; 06960 IR_LINE_NUM_R(ir_idx) = line; 06961 IR_COL_NUM_R(ir_idx) = col; 06962 06963 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 06964 bd_idx = ATD_ARRAY_IDX(attr_idx); 06965 06966 NTR_IR_TBL(ir_idx); 06967 IR_OPR(ir_idx) = Subscript_Opr; 06968 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 06969 IR_LINE_NUM(ir_idx) = line; 06970 IR_COL_NUM(ir_idx) = col; 06971 COPY_OPND(IR_OPND_L(ir_idx), (*top_opnd)); 06972 OPND_FLD((*top_opnd)) = IR_Tbl_Idx; 06973 OPND_IDX((*top_opnd)) = ir_idx; 06974 06975 NTR_IR_LIST_TBL(list_idx); 06976 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 06977 IR_IDX_R(ir_idx) = list_idx; 06978 IR_LIST_CNT_R(ir_idx) = BD_RANK(bd_idx); 06979 06980 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1); 06981 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1); 06982 IL_LINE_NUM(list_idx) = line; 06983 IL_COL_NUM(list_idx) = col; 06984 06985 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 06986 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 06987 } 06988 06989 for (i = 2; i <= BD_RANK(bd_idx); i++) { 06990 06991 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06992 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06993 list_idx = IL_NEXT_LIST_IDX(list_idx); 06994 06995 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 06996 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 06997 IL_LINE_NUM(list_idx) = line; 06998 IL_COL_NUM(list_idx) = col; 06999 07000 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 07001 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 07002 } 07003 } 07004 } 07005 07006 type_idx = ATD_TYPE_IDX(attr_idx); 07007 } 07008 # endif 07009 07010 NTR_IR_TBL(ir_idx); 07011 IR_OPR(ir_idx) = Substring_Opr; 07012 IR_TYPE_IDX(ir_idx) = CHARACTER_DEFAULT_TYPE; 07013 IR_LINE_NUM(ir_idx) = line; 07014 IR_COL_NUM(ir_idx) = col; 07015 07016 COPY_OPND(IR_OPND_L(ir_idx), (*top_opnd)); 07017 OPND_FLD((*top_opnd)) = IR_Tbl_Idx; 07018 OPND_IDX((*top_opnd)) = ir_idx; 07019 07020 NTR_IR_LIST_TBL(list_idx); 07021 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 07022 IR_IDX_R(ir_idx) = list_idx; 07023 IR_LIST_CNT_R(ir_idx) = 2; 07024 IL_FLD(list_idx) = CN_Tbl_Idx; 07025 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 07026 IL_LINE_NUM(list_idx) = line; 07027 IL_COL_NUM(list_idx) = col; 07028 07029 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07030 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07031 list_idx = IL_NEXT_LIST_IDX(list_idx); 07032 07033 if (num_chars.fld == NO_Tbl_Idx) { 07034 IL_FLD(list_idx) = CN_Tbl_Idx; 07035 IL_IDX(list_idx) = ntr_const_tbl(num_chars.type_idx, 07036 FALSE, 07037 num_chars.constant); 07038 } 07039 else { 07040 IL_FLD(list_idx) = num_chars.fld; 07041 IL_IDX(list_idx) = num_chars.idx; 07042 } 07043 07044 IL_LINE_NUM(list_idx) = line; 07045 IL_COL_NUM(list_idx) = col; 07046 07047 add_substring_length(ir_idx); 07048 07049 EXIT: 07050 07051 TRACE (Func_Exit, "transform_char_sequence_ref", NULL); 07052 07053 return; 07054 07055 } /* "transform_char_sequence_ref" */ 07056 07057 /******************************************************************************\ 07058 |* *| 07059 |* Description: *| 07060 |* Because of the problems of deferred function expansion of variable *| 07061 |* length character functions within concats, this routine creates a new *| 07062 |* length expression for the concat after the functions have been *| 07063 |* processed. (Their length is a tmp at this point). *| 07064 |* *| 07065 |* Input parameters: *| 07066 |* concat_idx - IR_Tbl_Idx for concat. *| 07067 |* *| 07068 |* Output parameters: *| 07069 |* len_opnd - the length expression tree. *| 07070 |* *| 07071 |* Returns: *| 07072 |* NOTHING *| 07073 |* *| 07074 \******************************************************************************/ 07075 07076 void get_concat_len(int concat_idx, 07077 opnd_type *len_opnd) 07078 07079 { 07080 int col; 07081 int line; 07082 int list_idx; 07083 opnd_type opnd; 07084 opnd_type opnd2; 07085 int plus_idx; 07086 07087 07088 TRACE (Func_Entry, "get_concat_len", NULL); 07089 07090 line = IR_LINE_NUM(concat_idx); 07091 col = IR_COL_NUM(concat_idx); 07092 07093 list_idx = IR_IDX_L(concat_idx); 07094 *len_opnd = null_opnd; 07095 07096 while (list_idx) { 07097 07098 COPY_OPND(opnd2, IL_OPND(list_idx)); 07099 get_char_len(&opnd2, &opnd); 07100 07101 if (OPND_FLD((*len_opnd)) == NO_Tbl_Idx) { 07102 COPY_OPND((*len_opnd), opnd); 07103 } 07104 else { 07105 NTR_IR_TBL(plus_idx); 07106 IR_OPR(plus_idx) = Plus_Opr; 07107 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 07108 IR_LINE_NUM(plus_idx) = line; 07109 IR_COL_NUM(plus_idx) = col; 07110 07111 COPY_OPND(IR_OPND_L(plus_idx), (*len_opnd)); 07112 COPY_OPND(IR_OPND_R(plus_idx), opnd); 07113 OPND_FLD((*len_opnd)) = IR_Tbl_Idx; 07114 OPND_IDX((*len_opnd)) = plus_idx; 07115 } 07116 07117 list_idx = IL_NEXT_LIST_IDX(list_idx); 07118 } 07119 07120 TRACE (Func_Exit, "get_concat_len", NULL); 07121 07122 return; 07123 07124 } /* get_concat_len */ 07125 07126 /******************************************************************************\ 07127 |* *| 07128 |* Description: *| 07129 |* <description> *| 07130 |* *| 07131 |* Input parameters: *| 07132 |* NONE *| 07133 |* *| 07134 |* Output parameters: *| 07135 |* NONE *| 07136 |* *| 07137 |* Returns: *| 07138 |* NOTHING *| 07139 |* *| 07140 \******************************************************************************/ 07141 07142 void get_char_len(opnd_type *ref_opnd, 07143 opnd_type *length_opnd) 07144 07145 { 07146 int cn_idx; 07147 int ir_idx; 07148 int line; 07149 int col; 07150 opnd_type opnd; 07151 07152 TRACE (Func_Entry, "get_char_len", NULL); 07153 07154 find_opnd_line_and_column(ref_opnd, 07155 &line, 07156 &col); 07157 07158 switch(OPND_FLD((*ref_opnd))) { 07159 case IR_Tbl_Idx : 07160 ir_idx = OPND_IDX((*ref_opnd)); 07161 07162 if (IR_OPR(ir_idx) == Substring_Opr || 07163 IR_OPR(ir_idx) == Whole_Substring_Opr) { 07164 07165 COPY_OPND((*length_opnd), IL_OPND(IL_NEXT_LIST_IDX( 07166 IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))))); 07167 } 07168 else if (IR_OPR(ir_idx) == Stmt_Expansion_Opr || 07169 IR_OPR(ir_idx) == Paren_Opr) { 07170 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 07171 get_char_len(&opnd, length_opnd); 07172 } 07173 else if (IR_TYPE_IDX(ir_idx) != NULL_IDX && 07174 TYP_TYPE(IR_TYPE_IDX(ir_idx)) == Character) { 07175 07176 OPND_FLD((*length_opnd)) = TYP_FLD(IR_TYPE_IDX(ir_idx)); 07177 OPND_IDX((*length_opnd)) = TYP_IDX(IR_TYPE_IDX(ir_idx)); 07178 OPND_LINE_NUM((*length_opnd)) = line; 07179 OPND_COL_NUM((*length_opnd)) = col; 07180 07181 if (OPND_FLD((*length_opnd)) == AT_Tbl_Idx) { 07182 ADD_TMP_TO_SHARED_LIST(OPND_IDX((*length_opnd))); 07183 } 07184 } 07185 # if 0 /* March */ 07186 else { 07187 PRINTMSG(line, 626, Internal, col, 07188 "type idx", "get_char_len"); 07189 } 07190 # endif 07191 break; 07192 07193 case CN_Tbl_Idx : 07194 07195 cn_idx = OPND_IDX((*ref_opnd)); 07196 # ifdef _DEBUG 07197 if (TYP_TYPE(CN_TYPE_IDX(cn_idx)) != Character) { 07198 PRINTMSG(line, 626, Internal, col, 07199 "CHARACTER type constant" 07200 "get_concat_len"); 07201 } 07202 # endif 07203 07204 OPND_FLD((*length_opnd)) = TYP_FLD(CN_TYPE_IDX(cn_idx)); 07205 OPND_IDX((*length_opnd)) = TYP_IDX(CN_TYPE_IDX(cn_idx)); 07206 OPND_LINE_NUM((*length_opnd)) = line; 07207 OPND_COL_NUM((*length_opnd)) = col; 07208 break; 07209 07210 /* March add NO_Tbl_Idx case */ 07211 case NO_Tbl_Idx: 07212 07213 OPND_FLD((*length_opnd)) = NO_Tbl_Idx; 07214 OPND_LINE_NUM((*length_opnd)) = line; 07215 OPND_COL_NUM((*length_opnd)) = col; 07216 break; 07217 07218 default : 07219 # if 0 /* March */ 07220 PRINTMSG(line, 626, Internal, col, 07221 "IR_Tbl_Idx or CN_Tbl_Idx", 07222 "get_char_len"); 07223 # endif 07224 break; 07225 } 07226 07227 07228 TRACE (Func_Exit, "get_char_len", NULL); 07229 07230 return; 07231 07232 } /* get_char_len */ 07233 07234 /******************************************************************************\ 07235 |* *| 07236 |* Description: *| 07237 |* Gen the dv_whole_def_opr for variable size function processing. *| 07238 |* *| 07239 |* Input parameters: *| 07240 |* NONE *| 07241 |* *| 07242 |* Output parameters: *| 07243 |* NONE *| 07244 |* *| 07245 |* Returns: *| 07246 |* attr idx of tmp_dope_vector *| 07247 |* *| 07248 \******************************************************************************/ 07249 07250 int gen_sf_dv_whole_def(opnd_type *r_opnd, 07251 int type_idx, 07252 int bd_idx) 07253 07254 { 07255 int asg_idx; 07256 opnd_type base_opnd; 07257 int col; 07258 long_type constant; 07259 int dope_idx = NULL_IDX; 07260 int dv_attr_idx; 07261 int i; 07262 int ir_idx; 07263 int line; 07264 int list_idx; 07265 int loc_idx; 07266 int mult_idx; 07267 size_offset_type num_chars; 07268 opnd_type opnd; 07269 long rank; 07270 int rank_idx = NULL_IDX; 07271 size_offset_type result; 07272 07273 07274 TRACE (Func_Entry, "gen_sf_dv_whole_def", NULL); 07275 07276 find_opnd_line_and_column(r_opnd, &line, &col); 07277 07278 dv_attr_idx = gen_compiler_tmp(line, col, Priv, TRUE); 07279 07280 ATD_TYPE_IDX(dv_attr_idx) = type_idx; 07281 ATD_STOR_BLK_IDX(dv_attr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 07282 AT_SEMANTICS_DONE(dv_attr_idx) = TRUE; 07283 07284 /* Positions 1-7 are deferred shape entries in bd table. */ 07285 ATD_ARRAY_IDX(dv_attr_idx) = BD_RANK(bd_idx); 07286 07287 07288 NTR_IR_TBL(asg_idx); 07289 IR_OPR(asg_idx) = Dv_Def_Asg_Opr; 07290 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 07291 IR_LINE_NUM(asg_idx) = line; 07292 IR_COL_NUM(asg_idx) = col; 07293 07294 NTR_IR_TBL(ir_idx); 07295 IR_OPR(ir_idx) = Dv_Whole_Def_Opr; 07296 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 07297 IR_LINE_NUM(ir_idx) = line; 07298 IR_COL_NUM(ir_idx) = col; 07299 07300 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 07301 IR_IDX_L(asg_idx) = dv_attr_idx; 07302 IR_LINE_NUM_L(asg_idx) = line; 07303 IR_COL_NUM_L(asg_idx) = col; 07304 07305 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 07306 IR_IDX_R(asg_idx) = ir_idx; 07307 07308 NTR_IR_LIST_TBL(list_idx); 07309 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 07310 IR_IDX_L(ir_idx) = list_idx; 07311 07312 rank = (long) BD_RANK(bd_idx); 07313 07314 IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank); 07315 IR_DV_DIM(ir_idx) = rank; 07316 07317 /*************\ 07318 |* BASE ADDR *| 07319 \*************/ 07320 07321 if (OPND_FLD((*r_opnd)) == AT_Tbl_Idx && 07322 AT_OBJ_CLASS(OPND_IDX((*r_opnd))) == Data_Obj && 07323 ATD_CLASS(OPND_IDX((*r_opnd))) == Compiler_Tmp && 07324 (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*r_opnd)))) == CRI_Ptr || 07325 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*r_opnd)))) == CRI_Ch_Ptr || 07326 ATD_IM_A_DOPE(OPND_IDX((*r_opnd))))) { 07327 07328 if (ATD_IM_A_DOPE(OPND_IDX((*r_opnd)))) { 07329 07330 NTR_IR_TBL(loc_idx); 07331 IR_OPR(loc_idx) = Dv_Access_Base_Addr; 07332 IR_TYPE_IDX(loc_idx) = SA_INTEGER_DEFAULT_TYPE; 07333 IR_LINE_NUM(loc_idx) = line; 07334 IR_COL_NUM(loc_idx) = col; 07335 COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd)); 07336 IL_FLD(list_idx) = IR_Tbl_Idx; 07337 IL_IDX(list_idx) = loc_idx; 07338 } 07339 else { 07340 COPY_OPND(IL_OPND(list_idx), (*r_opnd)); 07341 } 07342 } 07343 else { 07344 NTR_IR_TBL(loc_idx); 07345 IR_OPR(loc_idx) = Loc_Opr; 07346 IR_LINE_NUM(loc_idx) = line; 07347 IR_COL_NUM(loc_idx) = col; 07348 07349 if (TYP_TYPE(type_idx) == Character) { 07350 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 07351 } 07352 else { 07353 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 07354 } 07355 07356 IL_FLD(list_idx) = IR_Tbl_Idx; 07357 IL_IDX(list_idx) = loc_idx; 07358 07359 make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx); 07360 COPY_OPND(IR_OPND_L(loc_idx), base_opnd); 07361 07362 # ifdef _TRANSFORM_CHAR_SEQUENCE 07363 # ifdef _TARGET_OS_UNICOS 07364 if (TYP_TYPE(type_idx) == Structure && 07365 ATT_CHAR_SEQ(TYP_IDX(type_idx))) { 07366 07367 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 07368 COPY_OPND(opnd, IR_OPND_L(loc_idx)); 07369 transform_char_sequence_ref(&opnd, type_idx); 07370 COPY_OPND(IR_OPND_L(loc_idx), opnd); 07371 } 07372 # endif 07373 # endif 07374 } 07375 07376 07377 /*************\ 07378 |* EL_LEN *| 07379 \*************/ 07380 07381 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07382 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07383 list_idx = IL_NEXT_LIST_IDX(list_idx); 07384 07385 if (TYP_TYPE(type_idx) == Structure) { 07386 IL_FLD(list_idx) = (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 07387 IL_IDX(list_idx) = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 07388 IL_LINE_NUM(list_idx) = line; 07389 IL_COL_NUM(list_idx) = col; 07390 } 07391 else if (TYP_TYPE(type_idx) == Character) { 07392 07393 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 07394 07395 if (char_len_in_bytes) { /* Len is in bytes on solaris */ 07396 07397 IL_FLD(list_idx) = CN_Tbl_Idx; 07398 IL_IDX(list_idx) = TYP_IDX(type_idx); 07399 } 07400 else { 07401 result.idx = CN_INTEGER_CHAR_BIT_IDX; 07402 result.fld = CN_Tbl_Idx; 07403 07404 num_chars.fld = TYP_FLD(type_idx); 07405 num_chars.idx = TYP_IDX(type_idx); 07406 07407 size_offset_binary_calc(&num_chars, &result, Mult_Opr, &result); 07408 07409 if (result.fld == NO_Tbl_Idx) { 07410 IL_FLD(list_idx) = CN_Tbl_Idx; 07411 IL_IDX(list_idx) = ntr_const_tbl(result.type_idx, 07412 FALSE, 07413 result.constant); 07414 } 07415 else { 07416 IL_FLD(list_idx) = result.fld; 07417 IL_IDX(list_idx) = result.idx; 07418 } 07419 } 07420 IL_LINE_NUM(list_idx) = line; 07421 IL_COL_NUM(list_idx) = col; 07422 } 07423 else { 07424 if (char_len_in_bytes) { 07425 /* Len is in bytes on solaris */ 07426 IL_FLD(list_idx) = TYP_FLD(type_idx); 07427 IL_IDX(list_idx) = TYP_IDX(type_idx); 07428 IL_LINE_NUM(list_idx) = line; 07429 IL_COL_NUM(list_idx) = col; 07430 07431 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 07432 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 07433 } 07434 } 07435 else { 07436 07437 NTR_IR_TBL(mult_idx); 07438 IR_OPR(mult_idx) = Mult_Opr; 07439 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 07440 IR_LINE_NUM(mult_idx) = line; 07441 IR_COL_NUM(mult_idx) = col; 07442 constant = 8; 07443 IR_FLD_L(mult_idx) = CN_Tbl_Idx; 07444 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8); 07445 IR_LINE_NUM_L(mult_idx) = line; 07446 IR_COL_NUM_L(mult_idx) = col; 07447 07448 IR_FLD_R(mult_idx) = TYP_FLD(type_idx); 07449 IR_IDX_R(mult_idx) = TYP_IDX(type_idx); 07450 IR_LINE_NUM_R(mult_idx) = line; 07451 IR_COL_NUM_R(mult_idx) = col; 07452 07453 if (IR_FLD_R(mult_idx) == AT_Tbl_Idx) { 07454 ADD_TMP_TO_SHARED_LIST(IR_IDX_R(mult_idx)); 07455 } 07456 07457 IL_FLD(list_idx) = IR_Tbl_Idx; 07458 IL_IDX(list_idx) = mult_idx; 07459 } 07460 } 07461 } 07462 else { 07463 constant = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 07464 IL_FLD(list_idx) = CN_Tbl_Idx; 07465 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, constant); 07466 IL_LINE_NUM(list_idx) = line; 07467 IL_COL_NUM(list_idx) = col; 07468 } 07469 07470 /*************\ 07471 |* ASSOC *| 07472 \*************/ 07473 07474 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07475 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07476 list_idx = IL_NEXT_LIST_IDX(list_idx); 07477 07478 IL_FLD(list_idx) = CN_Tbl_Idx; 07479 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 07480 IL_LINE_NUM(list_idx) = line; 07481 IL_COL_NUM(list_idx) = col; 07482 07483 /*************\ 07484 |* PTR_ALLOC *| 07485 \*************/ 07486 07487 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07488 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07489 list_idx = IL_NEXT_LIST_IDX(list_idx); 07490 07491 IL_FLD(list_idx) = CN_Tbl_Idx; 07492 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 07493 IL_LINE_NUM(list_idx) = line; 07494 IL_COL_NUM(list_idx) = col; 07495 07496 07497 /*************\ 07498 |* P_OR_A *| 07499 \*************/ 07500 07501 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07502 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07503 list_idx = IL_NEXT_LIST_IDX(list_idx); 07504 07505 IL_FLD(list_idx) = CN_Tbl_Idx; 07506 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 07507 IL_LINE_NUM(list_idx) = line; 07508 IL_COL_NUM(list_idx) = col; 07509 07510 07511 /*************\ 07512 |* A_CONTIG *| 07513 \*************/ 07514 07515 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07516 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07517 list_idx = IL_NEXT_LIST_IDX(list_idx); 07518 07519 IL_FLD(list_idx) = CN_Tbl_Idx; 07520 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 07521 IL_LINE_NUM(list_idx) = line; 07522 IL_COL_NUM(list_idx) = col; 07523 07524 /*************\ 07525 |* N_DIM *| 07526 \*************/ 07527 07528 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07529 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07530 list_idx = IL_NEXT_LIST_IDX(list_idx); 07531 07532 IL_FLD(list_idx) = CN_Tbl_Idx; 07533 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank); 07534 IL_LINE_NUM(list_idx) = line; 07535 IL_COL_NUM(list_idx) = col; 07536 07537 07538 /*************\ 07539 |* TYPE_CODE *| 07540 \*************/ 07541 07542 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07543 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07544 list_idx = IL_NEXT_LIST_IDX(list_idx); 07545 07546 IL_FLD(list_idx) = CN_Tbl_Idx; 07547 IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx); 07548 IL_LINE_NUM(list_idx) = line; 07549 IL_COL_NUM(list_idx) = col; 07550 07551 /*************\ 07552 |* ORIG_BASE *| 07553 \*************/ 07554 07555 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07556 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07557 list_idx = IL_NEXT_LIST_IDX(list_idx); 07558 07559 IL_FLD(list_idx) = CN_Tbl_Idx; 07560 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 07561 IL_LINE_NUM(list_idx) = line; 07562 IL_COL_NUM(list_idx) = col; 07563 07564 07565 /*************\ 07566 |* ORIG_SIZE *| 07567 \*************/ 07568 07569 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07570 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07571 list_idx = IL_NEXT_LIST_IDX(list_idx); 07572 07573 IL_FLD(list_idx) = CN_Tbl_Idx; 07574 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 07575 IL_LINE_NUM(list_idx) = line; 07576 IL_COL_NUM(list_idx) = col; 07577 07578 07579 for (i = 1; i <= rank; i++) { 07580 07581 /*************\ 07582 |* DIM i LB *| 07583 \*************/ 07584 07585 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07586 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07587 list_idx = IL_NEXT_LIST_IDX(list_idx); 07588 07589 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 07590 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 07591 IL_LINE_NUM(list_idx) = line; 07592 IL_COL_NUM(list_idx) = col; 07593 07594 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 07595 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 07596 } 07597 07598 /*************\ 07599 |* DIM i EX *| 07600 \*************/ 07601 07602 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07603 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07604 list_idx = IL_NEXT_LIST_IDX(list_idx); 07605 07606 IL_FLD(list_idx) = BD_XT_FLD(bd_idx, i); 07607 IL_IDX(list_idx) = BD_XT_IDX(bd_idx, i); 07608 IL_LINE_NUM(list_idx) = line; 07609 IL_COL_NUM(list_idx) = col; 07610 07611 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 07612 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 07613 } 07614 07615 /*************\ 07616 |* DIM i SM *| 07617 \*************/ 07618 07619 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07620 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07621 list_idx = IL_NEXT_LIST_IDX(list_idx); 07622 07623 IL_FLD(list_idx) = BD_SM_FLD(bd_idx, i); 07624 IL_IDX(list_idx) = BD_SM_IDX(bd_idx, i); 07625 IL_LINE_NUM(list_idx) = line; 07626 IL_COL_NUM(list_idx) = col; 07627 07628 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 07629 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 07630 } 07631 } 07632 07633 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 07634 07635 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 07636 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07637 07638 TRACE (Func_Exit, "gen_sf_dv_whole_def", NULL); 07639 07640 return(dv_attr_idx); 07641 07642 } /* gen_sf_dv_whole_def */ 07643 07644 /******************************************************************************\ 07645 |* *| 07646 |* Description: *| 07647 |* This routine determines the correct character length of an expression *| 07648 |* for use by the dope vector gen routines. This is necessary, since we *| 07649 |* don't create new type entries for each node of a concat and substring *| 07650 |* tree. Remember the rule, don't use type_idx for character length for *| 07651 |* a general case character expression. It must be calculated. *| 07652 |* *| 07653 |* Input parameters: *| 07654 |* NONE *| 07655 |* *| 07656 |* Output parameters: *| 07657 |* NONE *| 07658 |* *| 07659 |* Returns: *| 07660 |* NOTHING *| 07661 |* *| 07662 \******************************************************************************/ 07663 07664 static void compute_char_element_len(opnd_type *char_len, 07665 opnd_type *char_opnd, 07666 opnd_type *result_opnd) 07667 07668 { 07669 int col; 07670 int line; 07671 expr_arg_type loc_exp_desc; 07672 int mult_idx; 07673 cif_usage_code_type save_xref_state; 07674 07675 07676 TRACE (Func_Entry, "compute_char_element_len", NULL); 07677 07678 find_opnd_line_and_column(char_opnd, &line, &col); 07679 07680 if (OPND_FLD((*char_opnd)) == IR_Tbl_Idx && 07681 IR_OPR(OPND_IDX((*char_opnd))) == Concat_Opr) { 07682 07683 get_concat_len(OPND_IDX((*char_opnd)), result_opnd); 07684 } 07685 else { 07686 COPY_OPND((*result_opnd), (*char_len)); 07687 } 07688 07689 if (! char_len_in_bytes) { 07690 /* Len is in bytes for solaris */ 07691 /* Len is in bits for everyone else */ 07692 07693 NTR_IR_TBL(mult_idx); 07694 IR_OPR(mult_idx) = Mult_Opr; 07695 IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE; 07696 IR_LINE_NUM(mult_idx) = line; 07697 IR_COL_NUM(mult_idx) = col; 07698 IR_FLD_L(mult_idx) = CN_Tbl_Idx; 07699 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8); 07700 IR_LINE_NUM_L(mult_idx) = line; 07701 IR_COL_NUM_L(mult_idx) = col; 07702 07703 COPY_OPND(IR_OPND_R(mult_idx), (*result_opnd)); 07704 07705 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 07706 OPND_IDX((*result_opnd)) = mult_idx; 07707 } 07708 07709 /* try to fold it down */ 07710 loc_exp_desc.rank = 0; 07711 save_xref_state = xref_state; 07712 xref_state = CIF_No_Usage_Rec; 07713 expr_semantics(result_opnd, &loc_exp_desc); 07714 xref_state = save_xref_state; 07715 07716 TRACE (Func_Exit, "compute_char_element_len", NULL); 07717 07718 return; 07719 07720 } /* compute_char_element_len */ 07721 07722 /******************************************************************************\ 07723 |* *| 07724 |* Description: *| 07725 |* This routine determines the correct character length of an expression *| 07726 |* for use by the dope vector gen routines. This is necessary, since we *| 07727 |* don't create new type entries for each node of a concat and substring *| 07728 |* tree. Remember the rule, don't use type_idx for character length for *| 07729 |* a general case character expression. It must be calculated. *| 07730 |* *| 07731 |* Input parameters: *| 07732 |* NONE *| 07733 |* *| 07734 |* Output parameters: *| 07735 |* NONE *| 07736 |* *| 07737 |* Returns: *| 07738 |* NOTHING *| 07739 |* *| 07740 \******************************************************************************/ 07741 07742 void get_shape_from_attr(expr_arg_type *exp_desc, 07743 int attr_idx, 07744 int rank, 07745 int line, 07746 int column) 07747 07748 { 07749 int i; 07750 int ir_idx; 07751 07752 07753 TRACE (Func_Entry, "get_shape_from_attr", NULL); 07754 07755 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 07756 for (i = 0; i < rank; i++) { 07757 07758 if (ATD_IM_A_DOPE(attr_idx)) { 07759 OPND_FLD(exp_desc->shape[i]) = IR_Tbl_Idx; 07760 NTR_IR_TBL(ir_idx); 07761 IR_OPR(ir_idx) = Dv_Access_Extent; 07762 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 07763 IR_LINE_NUM(ir_idx) = line; 07764 IR_COL_NUM(ir_idx) = column; 07765 IR_DV_DIM(ir_idx) = i + 1; 07766 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 07767 IR_IDX_L(ir_idx) = attr_idx; 07768 IR_LINE_NUM_L(ir_idx) = line; 07769 IR_COL_NUM_L(ir_idx) = column; 07770 OPND_IDX(exp_desc->shape[i]) = ir_idx; 07771 07772 SHAPE_FOLDABLE(exp_desc->shape[i]) = FALSE; 07773 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = FALSE; 07774 } 07775 else { 07776 OPND_FLD(exp_desc->shape[i]) = 07777 BD_XT_FLD(ATD_ARRAY_IDX(attr_idx), i+1); 07778 OPND_IDX(exp_desc->shape[i]) = 07779 BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), i+1); 07780 OPND_LINE_NUM(exp_desc->shape[i]) = line; 07781 OPND_COL_NUM(exp_desc->shape[i]) = column; 07782 07783 if (OPND_FLD(exp_desc->shape[i]) == AT_Tbl_Idx) { 07784 ADD_TMP_TO_SHARED_LIST(OPND_IDX(exp_desc->shape[i])); 07785 } 07786 07787 if (OPND_FLD(exp_desc->shape[i]) == CN_Tbl_Idx) { 07788 SHAPE_FOLDABLE(exp_desc->shape[i]) = TRUE; 07789 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = TRUE; 07790 } 07791 else if (OPND_FLD(exp_desc->shape[i]) == AT_Tbl_Idx && 07792 AT_OBJ_CLASS(OPND_IDX(exp_desc->shape[i])) == Data_Obj && 07793 ATD_LCV_IS_CONST(OPND_IDX(exp_desc->shape[i]))) { 07794 SHAPE_FOLDABLE(exp_desc->shape[i]) = FALSE; 07795 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = TRUE; 07796 } 07797 else { 07798 SHAPE_FOLDABLE(exp_desc->shape[i]) = FALSE; 07799 SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = FALSE; 07800 } 07801 } 07802 } 07803 } 07804 07805 TRACE (Func_Exit, "get_shape_from_attr", NULL); 07806 07807 return; 07808 07809 } /* get_shape_from_attr */ 07810 07811 /******************************************************************************\ 07812 |* *| 07813 |* Description: *| 07814 |* This routine will generate a Init_Opr statement for compiler temps *| 07815 |* and insert the statement before the end statement of the scope. It is *| 07816 |* used at pdgcs conversion time whenever a compiler temp is *| 07817 |* encountered that has its ATD_TMP_INIT_NOT_DONE flag set. This is to *| 07818 |* ensure that only the data init's of compiler temps (for constructors *| 07819 |* and some folded intrinsics) are only added if the temp is still being *| 07820 |* referenced at interface time. No one else will optimize these out and *| 07821 |* they can make the binarys quite large and slow down loading. *| 07822 |* *| 07823 |* Input parameters: *| 07824 |* NONE *| 07825 |* *| 07826 |* Output parameters: *| 07827 |* NONE *| 07828 |* *| 07829 |* Returns: *| 07830 |* NOTHING *| 07831 |* *| 07832 \******************************************************************************/ 07833 07834 void insert_init_stmt_for_tmp(int tmp_idx) 07835 07836 { 07837 int asg_idx; 07838 int bd_idx; 07839 int col; 07840 int i; 07841 int line; 07842 int list_idx; 07843 int save_curr_stmt_sh_idx; 07844 int sub_idx; 07845 07846 07847 TRACE (Func_Entry, "insert_init_stmt_for_tmp", NULL); 07848 07849 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 07850 curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx); 07851 07852 line = AT_DEF_LINE(tmp_idx); 07853 col = AT_DEF_COLUMN(tmp_idx); 07854 bd_idx = ATD_ARRAY_IDX(tmp_idx); 07855 07856 NTR_IR_TBL(asg_idx); 07857 IR_OPR(asg_idx) = Init_Opr; 07858 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 07859 IR_LINE_NUM(asg_idx) = line; 07860 IR_COL_NUM(asg_idx) = col; 07861 IR_LINE_NUM_L(asg_idx) = line; 07862 IR_COL_NUM_L(asg_idx) = col; 07863 07864 if (ATD_FLD(tmp_idx) == IR_Tbl_Idx && 07865 bd_idx != NULL_IDX) { 07866 07867 NTR_IR_TBL(sub_idx); 07868 IR_OPR(sub_idx) = Subscript_Opr; 07869 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(tmp_idx); 07870 IR_LINE_NUM(sub_idx) = line; 07871 IR_COL_NUM(sub_idx) = col; 07872 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 07873 IR_IDX_L(sub_idx) = tmp_idx; 07874 IR_LINE_NUM_L(sub_idx) = line; 07875 IR_COL_NUM_L(sub_idx) = col; 07876 07877 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 07878 IR_IDX_L(asg_idx) = sub_idx; 07879 07880 NTR_IR_LIST_TBL(list_idx); 07881 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 07882 IR_LIST_CNT_R(sub_idx) = BD_RANK(bd_idx); 07883 IR_IDX_R(sub_idx) = list_idx; 07884 07885 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1); 07886 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1); 07887 IL_LINE_NUM(list_idx) = line; 07888 IL_COL_NUM(list_idx) = col; 07889 07890 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 07891 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 07892 } 07893 07894 for (i = 2; i <= BD_RANK(bd_idx); i++) { 07895 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07896 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07897 list_idx = IL_NEXT_LIST_IDX(list_idx); 07898 07899 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 07900 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 07901 IL_LINE_NUM(list_idx) = line; 07902 IL_COL_NUM(list_idx) = col; 07903 07904 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 07905 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 07906 } 07907 } 07908 } 07909 else { 07910 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 07911 IR_IDX_L(asg_idx) = tmp_idx; 07912 } 07913 07914 NTR_IR_LIST_TBL(list_idx); 07915 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 07916 IR_IDX_R(asg_idx) = list_idx; 07917 IR_LIST_CNT_R(asg_idx) = 3; 07918 07919 IL_FLD(list_idx) = CN_Tbl_Idx; 07920 IL_IDX(list_idx) = (ATD_FLD(tmp_idx) == CN_Tbl_Idx ? ATD_TMP_IDX(tmp_idx) : 07921 IR_IDX_R(ATD_TMP_IDX(tmp_idx))); 07922 IL_LINE_NUM(list_idx) = line; 07923 IL_COL_NUM(list_idx) = col; 07924 07925 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07926 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07927 list_idx = IL_NEXT_LIST_IDX(list_idx); 07928 07929 IL_FLD(list_idx) = CN_Tbl_Idx; 07930 IL_IDX(list_idx) = (ATD_FLD(tmp_idx) == CN_Tbl_Idx ? CN_INTEGER_ONE_IDX : 07931 IR_IDX_L(ATD_TMP_IDX(tmp_idx))); 07932 IL_LINE_NUM(list_idx) = line; 07933 IL_COL_NUM(list_idx) = col; 07934 07935 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 07936 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 07937 list_idx = IL_NEXT_LIST_IDX(list_idx); 07938 07939 IL_FLD(list_idx) = CN_Tbl_Idx; 07940 07941 if (ATD_FLD(tmp_idx) == CN_Tbl_Idx) { 07942 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 07943 } 07944 else { 07945 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 07946 storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX( 07947 IR_IDX_R(ATD_TMP_IDX(tmp_idx))))]); 07948 } 07949 07950 IL_LINE_NUM(list_idx) = line; 07951 IL_COL_NUM(list_idx) = col; 07952 07953 gen_sh(Before, Assignment_Stmt, line, col, 07954 FALSE, FALSE, TRUE); 07955 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 07956 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07957 07958 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 07959 07960 ATD_TMP_INIT_NOT_DONE(tmp_idx) = FALSE; 07961 07962 TRACE (Func_Exit, "insert_init_stmt_for_tmp", NULL); 07963 07964 return; 07965 07966 } /* insert_init_stmt_for_tmp */ 07967 07968 /******************************************************************************\ 07969 |* *| 07970 |* Description: *| 07971 |* generate a static integer array of the specified size. *| 07972 |* *| 07973 |* Input parameters: *| 07974 |* NONE *| 07975 |* *| 07976 |* Output parameters: *| 07977 |* NONE *| 07978 |* *| 07979 |* Returns: *| 07980 |* NOTHING *| 07981 |* *| 07982 \******************************************************************************/ 07983 07984 int gen_static_integer_array_tmp(int size, 07985 int line, 07986 int col) 07987 07988 { 07989 expr_arg_type exp_desc; 07990 int tmp_idx; 07991 int type_idx; 07992 07993 07994 TRACE (Func_Entry, "gen_static_integer_array_tmp", NULL); 07995 07996 # if defined(GENERATE_WHIRL) 07997 type_idx = SA_INTEGER_DEFAULT_TYPE; 07998 # else 07999 type_idx = CG_INTEGER_DEFAULT_TYPE; 08000 # endif 08001 08002 tmp_idx = gen_compiler_tmp(line,col, Shared, TRUE); 08003 ATD_TYPE_IDX(tmp_idx) = type_idx; 08004 ATD_SAVED(tmp_idx) = TRUE; 08005 ATD_DATA_INIT(tmp_idx) = TRUE; 08006 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 08007 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 08008 08009 exp_desc = init_exp_desc; 08010 exp_desc.type = Integer; 08011 exp_desc.type_idx = type_idx; 08012 exp_desc.linear_type = TYP_LINEAR(type_idx); 08013 exp_desc.rank = 1; 08014 exp_desc.shape[0].fld = CN_Tbl_Idx; 08015 exp_desc.shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, size); 08016 08017 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&exp_desc, 08018 line, 08019 col); 08020 08021 08022 TRACE (Func_Exit, "gen_static_integer_array_tmp", NULL); 08023 08024 return(tmp_idx); 08025 08026 } /* gen_static_integer_array_tmp */ 08027 08028 /******************************************************************************\ 08029 |* *| 08030 |* Description: *| 08031 |* <description> *| 08032 |* *| 08033 |* Input parameters: *| 08034 |* NONE *| 08035 |* *| 08036 |* Output parameters: *| 08037 |* NONE *| 08038 |* *| 08039 |* Returns: *| 08040 |* NOTHING *| 08041 |* *| 08042 \******************************************************************************/ 08043 08044 int cast_typeless_constant(int cn_idx, 08045 int type_idx, 08046 int line, 08047 int col) 08048 08049 { 08050 # if defined(_TARGET_OS_UNICOS) 08051 long_type another_constant[MAX_WORDS_FOR_NUMERIC]; 08052 # endif 08053 08054 char *char_ptr; 08055 long64 i; 08056 long64 k; 08057 int l; 08058 int new_const_idx; 08059 long64 new_word_size; 08060 long64 old_word_size; 08061 boolean right_justified; 08062 long_type the_constant[MAX_WORDS_FOR_NUMERIC]; 08063 boolean zero_pad; 08064 long_type swap_for_little_endian; 08065 08066 08067 TRACE (Func_Entry, "cast_typeless_constant", NULL); 08068 08069 if (TYP_TYPE(type_idx) == CRI_Ptr || 08070 TYP_TYPE(type_idx) == CRI_Parcel_Ptr || 08071 TYP_TYPE(type_idx) == CRI_Ch_Ptr) { 08072 type_idx = TYPELESS_DEFAULT_TYPE; 08073 } 08074 08075 if (CN_HOLLERITH_TYPE(cn_idx) == H_Hollerith) { 08076 right_justified = FALSE; 08077 zero_pad = FALSE; 08078 old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx))); 08079 } 08080 else if (CN_HOLLERITH_TYPE(cn_idx) == L_Hollerith) { 08081 right_justified = FALSE; 08082 zero_pad = TRUE; 08083 old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx))); 08084 } 08085 else if (CN_HOLLERITH_TYPE(cn_idx) == R_Hollerith) { 08086 right_justified = TRUE; 08087 zero_pad = TRUE; 08088 old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx))); 08089 } 08090 else if (TYP_TYPE(CN_TYPE_IDX(cn_idx)) == Character) { 08091 right_justified = FALSE; 08092 zero_pad = FALSE; 08093 old_word_size = TARGET_BYTES_TO_WORDS( 08094 CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(cn_idx)))); 08095 } 08096 else { 08097 /* non hollerith, non character, => typeless */ 08098 right_justified = TRUE; 08099 zero_pad = TRUE; 08100 old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx))); 08101 } 08102 08103 08104 if (TYP_TYPE(type_idx) == Typeless) { 08105 new_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(type_idx)); 08106 } 08107 else { 08108 new_word_size = TARGET_BITS_TO_WORDS( 08109 storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 08110 } 08111 08112 if (right_justified) { /* BRIANJ */ 08113 k = old_word_size - 1; 08114 for (i = new_word_size - 1; i >= 0; i--) { 08115 if (k < 0) { 08116 break; 08117 } 08118 the_constant[i] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + k); 08119 k--; 08120 } 08121 08122 while (i >= 0) { 08123 /* fill in pad */ 08124 if (zero_pad) { 08125 the_constant[i] = 0; 08126 } 08127 else { 08128 char_ptr = (char *)&(the_constant[i]); 08129 for (l = 0; l < TARGET_CHARS_PER_WORD; l++) { 08130 char_ptr[l] = ' '; 08131 } 08132 } 08133 08134 i--; 08135 } 08136 08137 if (k >= 0) { 08138 /* issue truncation message */ 08139 PRINTMSG(line, 1127, Caution, col); 08140 } 08141 } 08142 else { 08143 k = 0; 08144 for (i = 0; i < new_word_size; i++) { 08145 if (k >= old_word_size) { 08146 break; 08147 } 08148 the_constant[i] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + k); 08149 k++; 08150 } 08151 08152 while (i < new_word_size) { 08153 /* fill in pad */ 08154 if (zero_pad) { 08155 the_constant[i] = 0; 08156 } 08157 else { 08158 char_ptr = (char *)&(the_constant[i]); 08159 for (l = 0; l < TARGET_CHARS_PER_WORD; l++) { 08160 char_ptr[l] = ' '; 08161 } 08162 } 08163 08164 i++; 08165 } 08166 08167 if (k < old_word_size) { 08168 /* issue truncation message */ 08169 PRINTMSG(line, 1127, Caution, col); 08170 } 08171 08172 # ifdef _TARGET_OS_MAX 08173 if (TYP_LINEAR(type_idx) == Integer_1 || 08174 TYP_LINEAR(type_idx) == Integer_2 || 08175 TYP_LINEAR(type_idx) == Integer_4 || 08176 TYP_LINEAR(type_idx) == Real_4 || 08177 TYP_LINEAR(type_idx) == Logical_1 || 08178 TYP_LINEAR(type_idx) == Logical_2 || 08179 TYP_LINEAR(type_idx) == Logical_4) { 08180 08181 the_constant[0] = the_constant[0] >> 32; 08182 } 08183 # elif defined(_INTEGER_1_AND_2) && !defined(_TARGET_LITTLE_ENDIAN) 08184 08185 if (on_off_flags.integer_1_and_2 && 08186 (TYP_LINEAR(type_idx) == Integer_1 || 08187 TYP_LINEAR(type_idx) == Integer_2 || 08188 TYP_LINEAR(type_idx) == Logical_1 || 08189 TYP_LINEAR(type_idx) == Logical_2)) { 08190 08191 the_constant[0] = the_constant[0] >> (TARGET_BITS_PER_WORD - 08192 storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 08193 } 08194 # endif 08195 } 08196 08197 # if defined(_INTEGER_1_AND_2) 08198 08199 if (on_off_flags.integer_1_and_2) { 08200 08201 if (TYP_LINEAR(type_idx) == Integer_1 || 08202 TYP_LINEAR(type_idx) == Logical_1) { 08203 08204 the_constant[0] = the_constant[0] & 0XFF; 08205 } 08206 else if (TYP_LINEAR(type_idx) == Integer_2 || 08207 TYP_LINEAR(type_idx) == Logical_2) { 08208 08209 the_constant[0] = the_constant[0] & 0XFFFF; 08210 } 08211 } 08212 # endif 08213 08214 # ifdef _TARGET_OS_UNICOS 08215 08216 /* to get proper sign extension on UNICOS pvp's for short ints, */ 08217 /* convert the 64 bit typeless to short int. */ 08218 08219 if (TYP_LINEAR(type_idx) == Integer_1 || 08220 TYP_LINEAR(type_idx) == Integer_2 || 08221 TYP_LINEAR(type_idx) == Integer_4) { 08222 08223 if (folder_driver( (char *) the_constant, 08224 Integer_8, 08225 NULL, 08226 NULL_IDX, 08227 another_constant, 08228 &type_idx, 08229 line, 08230 col, 08231 1, 08232 Cvrt_Opr)) { 08233 08234 for (i=0; i<MAX_WORDS_FOR_INTEGER; i++) { 08235 the_constant[i] = another_constant[i]; 08236 } 08237 } 08238 } 08239 # endif 08240 08241 08242 /* must swap the two words for little endian machine 08243 since there is only problem for integer(8) or larger 08244 rank interger (occupy 2 or more than two words) and 08245 now we only accept up to 8 bytes integer,we only need 08246 swap the two words----FMZ 08247 */ 08248 # if defined(_TARGET_LITTLE_ENDIAN) 08249 if (new_word_size == 2) { 08250 swap_for_little_endian = the_constant[0]; 08251 the_constant[0] = the_constant[1]; 08252 the_constant[1] = swap_for_little_endian; 08253 } 08254 # endif 08255 08256 08257 08258 if (TYP_TYPE(type_idx) == Typeless && 08259 CN_BOZ_CONSTANT(cn_idx)) { 08260 new_const_idx = ntr_boz_const_tbl(type_idx, 08261 the_constant); 08262 } 08263 else if (TYP_TYPE(type_idx) == Typeless && 08264 CN_BOOLEAN_CONSTANT(cn_idx)) { 08265 new_const_idx = ntr_boolean_const_tbl(type_idx, 08266 the_constant); 08267 } 08268 else { 08269 08270 if (TYP_TYPE(type_idx) == Real) { 08271 new_const_idx = ntr_unshared_const_tbl(type_idx, 08272 FALSE, 08273 the_constant); 08274 } 08275 else { 08276 new_const_idx = ntr_const_tbl(type_idx, 08277 FALSE, 08278 the_constant); 08279 } 08280 } 08281 08282 TRACE (Func_Exit, "cast_typeless_constant", NULL); 08283 08284 return(new_const_idx); 08285 08286 } /* cast_typeless_constant */ 08287 08288 /******************************************************************************\ 08289 |* *| 08290 |* Description: *| 08291 |* In cases where the default integer (logical) type has been changed by *| 08292 |* the command line, we must cast some arguments to library routines to *| 08293 |* machine size integers. This occurs when default types are doubled on *| 08294 |* solaris and when they are halved on mpp. *| 08295 |* *| 08296 |* Input parameters: *| 08297 |* opnd - subtree to put cvrt_opr over. *| 08298 |* exp_desc - expression descriptor for that opnd. *| 08299 |* *| 08300 |* Output parameters: *| 08301 |* opnd - holds the new tree. *| 08302 |* exp_desc - some fields have been changed, like type. *| 08303 |* *| 08304 |* Returns: *| 08305 |* NOTHING *| 08306 |* *| 08307 \******************************************************************************/ 08308 08309 void cast_to_cg_default(opnd_type *opnd, 08310 expr_arg_type *exp_desc) 08311 08312 { 08313 int col; 08314 int cvrt_idx; 08315 boolean do_cast = FALSE; 08316 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 08317 int line; 08318 int type_idx; 08319 08320 TRACE (Func_Entry, "cast_to_cg_default", NULL); 08321 08322 if (exp_desc->type == Integer) { 08323 08324 if (storage_bit_size_tbl[exp_desc->linear_type] != 08325 storage_bit_size_tbl[TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)]) { 08326 08327 do_cast = TRUE; 08328 type_idx = CG_INTEGER_DEFAULT_TYPE; 08329 } 08330 } 08331 else if (exp_desc->type == Logical) { 08332 08333 if (storage_bit_size_tbl[exp_desc->linear_type] != 08334 storage_bit_size_tbl[TYP_LINEAR(CG_LOGICAL_DEFAULT_TYPE)]) { 08335 08336 do_cast = TRUE; 08337 type_idx = CG_LOGICAL_DEFAULT_TYPE; 08338 } 08339 } 08340 08341 if (do_cast) { 08342 find_opnd_line_and_column(opnd, &line, &col); 08343 08344 if (OPND_FLD((*opnd)) == CN_Tbl_Idx) { 08345 08346 if (folder_driver((char *)&CN_CONST(OPND_IDX((*opnd))), 08347 exp_desc->type_idx, 08348 NULL, 08349 NULL_IDX, 08350 folded_const, 08351 &type_idx, 08352 line, 08353 col, 08354 1, 08355 Cvrt_Opr)) { 08356 /* intentionally blank */ 08357 } 08358 08359 OPND_IDX((*opnd)) = ntr_const_tbl(type_idx, 08360 FALSE, 08361 folded_const); 08362 08363 } 08364 else { 08365 08366 NTR_IR_TBL(cvrt_idx); 08367 IR_OPR(cvrt_idx) = Cvrt_Opr; 08368 IR_TYPE_IDX(cvrt_idx) = type_idx; 08369 IR_LINE_NUM(cvrt_idx) = line; 08370 IR_COL_NUM(cvrt_idx) = col; 08371 08372 IR_RANK(cvrt_idx) = exp_desc->rank; 08373 08374 COPY_OPND(IR_OPND_L(cvrt_idx), (*opnd)); 08375 08376 if (exp_desc->rank > 0) { 08377 IR_ARRAY_SYNTAX(cvrt_idx) = TRUE; 08378 } 08379 08380 OPND_FLD((*opnd)) = IR_Tbl_Idx; 08381 OPND_IDX((*opnd)) = cvrt_idx; 08382 08383 exp_desc->reference = FALSE; 08384 exp_desc->tmp_reference = FALSE; 08385 } 08386 08387 exp_desc->type_idx = type_idx; 08388 exp_desc->type = TYP_TYPE(type_idx); 08389 exp_desc->linear_type = TYP_LINEAR(type_idx); 08390 } 08391 08392 TRACE (Func_Exit, "cast_to_cg_default", NULL); 08393 08394 return; 08395 08396 } /* cast_to_cg_default */ 08397 08398 08399 08400 /******************************************************************************\ 08401 |* *| 08402 |* Description: *| 08403 |* <description> *| 08404 |* *| 08405 |* Input parameters: *| 08406 |* NONE *| 08407 |* *| 08408 |* Output parameters: *| 08409 |* NONE *| 08410 |* *| 08411 |* Returns: *| 08412 |* NOTHING *| 08413 |* *| 08414 \******************************************************************************/ 08415 08416 void cast_opnd_to_type_idx(opnd_type *opnd, 08417 int type_idx) 08418 08419 { 08420 int col; 08421 expr_arg_type exp_desc; 08422 int line; 08423 08424 TRACE (Func_Entry, "cast_opnd_to_type_idx", NULL); 08425 08426 exp_desc = init_exp_desc; 08427 08428 if (OPND_FLD((*opnd)) == CN_Tbl_Idx) { 08429 exp_desc.type_idx = CN_TYPE_IDX(OPND_IDX((*opnd))); 08430 } 08431 else if (OPND_FLD((*opnd)) == AT_Tbl_Idx) { 08432 exp_desc.type_idx = ATD_TYPE_IDX(OPND_IDX((*opnd))); 08433 } 08434 else if (OPND_FLD((*opnd)) == IR_Tbl_Idx) { 08435 exp_desc.type_idx = IR_TYPE_IDX(OPND_IDX((*opnd))); 08436 exp_desc.rank = IR_RANK(OPND_IDX((*opnd))); 08437 } 08438 else { 08439 # ifdef _DEBUG 08440 find_opnd_line_and_column(opnd, &line, &col); 08441 PRINTMSG(line, 626, Internal, col, 08442 "CN, AT, or IR_Tbl_Idx", "cast_opnd_to_type_idx"); 08443 # endif 08444 } 08445 08446 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx); 08447 exp_desc.type = TYP_TYPE(exp_desc.type_idx); 08448 08449 cast_to_type_idx(opnd, &exp_desc, type_idx); 08450 08451 TRACE (Func_Exit, "cast_opnd_to_type_idx", NULL); 08452 08453 return; 08454 08455 } /* cast_opnd_to_type_idx */ 08456 08457 08458 08459 /******************************************************************************\ 08460 |* *| 08461 |* Description: *| 08462 |* Cast an arbitrary opnd to type described in typ_tbl[type_idx]. *| 08463 |* *| 08464 |* Input parameters: *| 08465 |* NONE *| 08466 |* *| 08467 |* Output parameters: *| 08468 |* NONE *| 08469 |* *| 08470 |* Returns: *| 08471 |* NOTHING *| 08472 |* *| 08473 \******************************************************************************/ 08474 08475 void cast_to_type_idx(opnd_type *opnd, 08476 expr_arg_type *exp_desc, 08477 int type_idx) 08478 08479 { 08480 char *char_ptr1; 08481 char *char_ptr2; 08482 int cn_idx; 08483 int col; 08484 int cvrt_idx; 08485 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 08486 long64 i; 08487 int line; 08488 08489 TRACE (Func_Entry, "cast_to_type_idx", NULL); 08490 08491 if ((TYP_TYPE(type_idx) != Character && 08492 TYP_LINEAR(type_idx) != exp_desc->linear_type) || 08493 (TYP_TYPE(type_idx) == Character && 08494 TYP_FLD(type_idx) == CN_Tbl_Idx && 08495 TYP_FLD(exp_desc->type_idx) == CN_Tbl_Idx && 08496 fold_relationals(TYP_IDX(type_idx), 08497 TYP_IDX(exp_desc->type_idx), 08498 Ne_Opr))) { 08499 08500 find_opnd_line_and_column(opnd, &line, &col); 08501 08502 if (exp_desc->linear_type == Short_Typeless_Const) { 08503 OPND_IDX((*opnd)) = cast_typeless_constant(OPND_IDX((*opnd)), 08504 type_idx, 08505 line, 08506 col); 08507 08508 } 08509 else if (OPND_FLD((*opnd)) == CN_Tbl_Idx) { 08510 08511 if (TYP_TYPE(type_idx) == Character) { 08512 cn_idx = ntr_const_tbl(type_idx, TRUE, NULL); 08513 char_ptr1 = (char *)&CN_CONST(OPND_IDX((*opnd))); 08514 char_ptr2 = (char *)&CN_CONST(cn_idx); 08515 08516 for (i = 0; 08517 i < CN_INT_TO_C(TYP_IDX(exp_desc->type_idx)) && 08518 i < CN_INT_TO_C(TYP_IDX(type_idx)); 08519 i++) { 08520 char_ptr2[i] = char_ptr1[i]; 08521 } 08522 08523 for (; i < CN_INT_TO_C(TYP_IDX(type_idx)); i++) { 08524 char_ptr2[i] = ' '; 08525 } 08526 08527 while ((i % TARGET_CHARS_PER_WORD) != 0) { 08528 char_ptr2[i] = ' '; 08529 i++; 08530 } 08531 08532 OPND_IDX((*opnd)) = cn_idx; 08533 08534 if (compare_cn_and_value(TYP_IDX(type_idx), 08535 MAX_CHARS_IN_TYPELESS, 08536 Le_Opr)) { 08537 exp_desc->linear_type = Short_Char_Const; 08538 } 08539 else { 08540 /* assume one byte character for now */ 08541 exp_desc->linear_type = Character_1; 08542 } 08543 } 08544 else { 08545 if (folder_driver((char *)&CN_CONST(OPND_IDX((*opnd))), 08546 exp_desc->type_idx, 08547 NULL, 08548 NULL_IDX, 08549 folded_const, 08550 &type_idx, 08551 line, 08552 col, 08553 1, 08554 Cvrt_Opr)) { 08555 /* intentionally blank */ 08556 } 08557 08558 OPND_IDX((*opnd)) = ntr_const_tbl(type_idx, 08559 FALSE, 08560 folded_const); 08561 } 08562 } 08563 # if _DEBUG 08564 else if (TYP_TYPE(type_idx) == Character) { 08565 PRINTMSG(line, 626, Internal, col, 08566 "non character operand", 08567 "cast_to_type_idx"); 08568 } 08569 # endif 08570 else { 08571 08572 NTR_IR_TBL(cvrt_idx); 08573 IR_OPR(cvrt_idx) = Cvrt_Opr; 08574 IR_RANK(cvrt_idx) = exp_desc->rank; 08575 08576 IR_TYPE_IDX(cvrt_idx) = type_idx; 08577 IR_LINE_NUM(cvrt_idx) = line; 08578 IR_COL_NUM(cvrt_idx) = col; 08579 08580 COPY_OPND(IR_OPND_L(cvrt_idx), (*opnd)); 08581 08582 if (exp_desc->rank > 0) { 08583 IR_ARRAY_SYNTAX(cvrt_idx) = TRUE; 08584 } 08585 08586 OPND_FLD((*opnd)) = IR_Tbl_Idx; 08587 OPND_IDX((*opnd)) = cvrt_idx; 08588 08589 exp_desc->reference = FALSE; 08590 exp_desc->tmp_reference = FALSE; 08591 } 08592 08593 exp_desc->type_idx = type_idx; 08594 exp_desc->type = TYP_TYPE(type_idx); 08595 exp_desc->linear_type = TYP_LINEAR(type_idx); 08596 08597 if (exp_desc->type == Character) { 08598 OPND_FLD(exp_desc->char_len) = TYP_FLD(exp_desc->type_idx); 08599 OPND_IDX(exp_desc->char_len) = TYP_IDX(exp_desc->type_idx); 08600 } 08601 } 08602 08603 TRACE (Func_Exit, "cast_to_type_idx", NULL); 08604 08605 return; 08606 08607 } /* cast_to_type_idx */ 08608 08609 /******************************************************************************\ 08610 |* *| 08611 |* Description: *| 08612 |* set up a logical constant value in an integer array depending on *| 08613 |* kind type and platform. *| 08614 |* *| 08615 |* Input parameters: *| 08616 |* NONE *| 08617 |* *| 08618 |* Output parameters: *| 08619 |* NONE *| 08620 |* *| 08621 |* Returns: *| 08622 |* NOTHING *| 08623 |* *| 08624 \******************************************************************************/ 08625 08626 int set_up_logical_constant(long_type *the_constant, 08627 int type_idx, 08628 int value, 08629 boolean enter_con) 08630 08631 { 08632 int cn_idx; 08633 08634 08635 TRACE (Func_Entry, "set_up_logical_constant", NULL); 08636 08637 /* BRIANJ KAYKAY - Should this use arith? */ 08638 08639 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 08640 if (TYP_LINEAR(type_idx) == Logical_8) { 08641 # if defined(_HOST_LITTLE_ENDIAN) && defined(_TARGET_LITTLE_ENDIAN) 08642 *(long long *)the_constant = value; 08643 # else 08644 the_constant[0] = 0; 08645 the_constant[1] = value; 08646 # endif 08647 } 08648 else { 08649 the_constant[0] = value; 08650 } 08651 # else 08652 the_constant[0] = value; 08653 # endif 08654 08655 if (enter_con) { 08656 cn_idx = ntr_const_tbl(type_idx, 08657 FALSE, 08658 the_constant); 08659 } 08660 else { 08661 cn_idx = NULL_IDX; 08662 } 08663 08664 TRACE (Func_Exit, "set_up_logical_constant", NULL); 08665 08666 return(cn_idx); 08667 08668 } /* set_up_logical_constant */ 08669 08670 /******************************************************************************\ 08671 |* *| 08672 |* Description: *| 08673 |* <description> *| 08674 |* *| 08675 |* Input parameters: *| 08676 |* NONE *| 08677 |* *| 08678 |* Output parameters: *| 08679 |* NONE *| 08680 |* *| 08681 |* Returns: *| 08682 |* NOTHING *| 08683 |* *| 08684 \******************************************************************************/ 08685 08686 boolean validate_char_len(opnd_type *result_opnd, 08687 expr_arg_type *exp_desc) 08688 08689 { 08690 int ch_asg_idx; 08691 int col; 08692 opnd_type length_opnd; 08693 int line; 08694 expr_arg_type loc_exp_desc; 08695 boolean ok = TRUE; 08696 cif_usage_code_type save_xref_state; 08697 int tmp_idx; 08698 08699 TRACE (Func_Entry, "validate_char_len", NULL); 08700 08701 if (exp_desc->type == Character && 08702 (exp_desc->char_len.fld != TYP_FLD(exp_desc->type_idx) || 08703 exp_desc->char_len.idx != TYP_IDX(exp_desc->type_idx) || 08704 (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 08705 IR_OPR(OPND_IDX((*result_opnd))) == Concat_Opr))) { 08706 08707 find_opnd_line_and_column(result_opnd, &line, &col); 08708 08709 # ifdef _DEBUG 08710 if (exp_desc->char_len.fld == NO_Tbl_Idx) { 08711 PRINTMSG(line, 1018, Internal, col); 08712 } 08713 # endif 08714 08715 loc_exp_desc.rank = 0; 08716 08717 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 08718 IR_OPR(OPND_IDX((*result_opnd))) == Concat_Opr) { 08719 08720 get_concat_len(OPND_IDX((*result_opnd)), &length_opnd); 08721 } 08722 else { 08723 COPY_OPND(length_opnd, (exp_desc->char_len)); 08724 } 08725 08726 save_xref_state = xref_state; 08727 xref_state = CIF_No_Usage_Rec; 08728 ok = expr_semantics(&length_opnd, &loc_exp_desc); 08729 xref_state = save_xref_state; 08730 08731 COPY_OPND((exp_desc->char_len), length_opnd); 08732 08733 if (loc_exp_desc.constant) { 08734 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 08735 08736 TYP_TYPE(TYP_WORK_IDX) = Character; 08737 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 08738 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 08739 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 08740 TYP_IDX(TYP_WORK_IDX) = OPND_IDX(length_opnd); 08741 exp_desc->type_idx = ntr_type_tbl(); 08742 exp_desc->type = Character; 08743 exp_desc->linear_type = CHARACTER_DEFAULT_TYPE; 08744 } 08745 else { /* non constant character length means an alloc'd item */ 08746 08747 GEN_COMPILER_TMP_ASG(ch_asg_idx, 08748 tmp_idx, 08749 TRUE, /* Semantics done */ 08750 line, 08751 col, 08752 loc_exp_desc.type_idx, 08753 Priv); 08754 08755 COPY_OPND(IR_OPND_R(ch_asg_idx), length_opnd); 08756 08757 gen_sh(Before, Assignment_Stmt, stmt_start_line, 08758 stmt_start_col, FALSE, FALSE, TRUE); 08759 08760 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 08761 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08762 08763 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 08764 08765 TYP_TYPE(TYP_WORK_IDX) = Character; 08766 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 08767 TYP_CHAR_CLASS(TYP_WORK_IDX) = Var_Len_Char; 08768 TYP_FLD(TYP_WORK_IDX) = AT_Tbl_Idx; 08769 TYP_IDX(TYP_WORK_IDX) = tmp_idx; 08770 TYP_ORIG_LEN_IDX(TYP_WORK_IDX) = tmp_idx; 08771 exp_desc->type_idx = ntr_type_tbl(); 08772 exp_desc->type = Character; 08773 exp_desc->linear_type = CHARACTER_DEFAULT_TYPE; 08774 } 08775 } 08776 08777 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 08778 (IR_OPR(OPND_IDX((*result_opnd))) == Substring_Opr || 08779 IR_OPR(OPND_IDX((*result_opnd))) == Whole_Substring_Opr)) { 08780 08781 IR_TYPE_IDX(OPND_IDX((*result_opnd))) = exp_desc->type_idx; 08782 } 08783 08784 08785 TRACE (Func_Exit, "validate_char_len", NULL); 08786 08787 return(ok); 08788 08789 } /* validate_char_len */ 08790 08791 /******************************************************************************\ 08792 |* *| 08793 |* Description: *| 08794 |* <description> *| 08795 |* *| 08796 |* Input parameters: *| 08797 |* NONE *| 08798 |* *| 08799 |* Output parameters: *| 08800 |* NONE *| 08801 |* *| 08802 |* Returns: *| 08803 |* NOTHING *| 08804 |* *| 08805 \******************************************************************************/ 08806 08807 void gen_runtime_checks(opnd_type *top_opnd) 08808 08809 { 08810 int ir_idx; 08811 int list_idx; 08812 opnd_type opnd; 08813 08814 TRACE (Func_Entry, "gen_runtime_checks", NULL); 08815 08816 switch (OPND_FLD((*top_opnd))) { 08817 case IR_Tbl_Idx: 08818 ir_idx = OPND_IDX((*top_opnd)); 08819 08820 if ((IR_OPR(ir_idx) == Subscript_Opr || 08821 IR_OPR(ir_idx) == Section_Subscript_Opr) && 08822 needs_bounds_check(ir_idx)) { 08823 08824 gen_runtime_bounds(ir_idx); 08825 } 08826 else if (cmd_line_flags.runtime_substring && 08827 IR_OPR(ir_idx) == Substring_Opr && 08828 ATD_CLASS(find_left_attr(&IR_OPND_L(ir_idx))) != Compiler_Tmp) { 08829 gen_runtime_substring(ir_idx); 08830 } 08831 08832 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 08833 gen_runtime_checks(&opnd); 08834 08835 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 08836 gen_runtime_checks(&opnd); 08837 break; 08838 08839 case IL_Tbl_Idx: 08840 list_idx = OPND_IDX((*top_opnd)); 08841 08842 while (list_idx) { 08843 COPY_OPND(opnd, IL_OPND(list_idx)); 08844 gen_runtime_checks(&opnd); 08845 08846 list_idx = IL_NEXT_LIST_IDX(list_idx); 08847 } 08848 break; 08849 } 08850 08851 TRACE (Func_Exit, "gen_runtime_checks", NULL); 08852 08853 return; 08854 08855 } /* gen_runtime_checks */ 08856 08857 /******************************************************************************\ 08858 |* *| 08859 |* Description: *| 08860 |* <description> *| 08861 |* *| 08862 |* Input parameters: *| 08863 |* NONE *| 08864 |* *| 08865 |* Output parameters: *| 08866 |* NONE *| 08867 |* *| 08868 |* Returns: *| 08869 |* NOTHING *| 08870 |* *| 08871 \******************************************************************************/ 08872 08873 void gen_runtime_conformance(opnd_type *l_opnd, 08874 expr_arg_type *l_exp_desc, 08875 opnd_type *r_opnd, /* BRIANJ -not used*/ 08876 expr_arg_type *r_exp_desc) 08877 08878 { 08879 int col; 08880 int i; 08881 expr_arg_type left_exp_desc; 08882 int line; 08883 expr_arg_type right_exp_desc; 08884 08885 TRACE (Func_Entry, "gen_runtime_conformance", NULL); 08886 08887 left_exp_desc = *l_exp_desc; 08888 right_exp_desc = *r_exp_desc; 08889 08890 find_opnd_line_and_column(l_opnd, &line, &col); 08891 08892 # ifdef _DEBUG 08893 if (defer_stmt_expansion) { 08894 PRINTMSG(line, 626, Internal, col, 08895 "defer_stmt_expansion to be FALSE", 08896 "gen_runtime_conformance"); 08897 } 08898 # endif 08899 08900 for (i = 0; i < left_exp_desc.rank; i++) { 08901 gen_conform_check_call(&(left_exp_desc.shape[i]), 08902 &(right_exp_desc.shape[i]), 08903 i + 1, 08904 line, 08905 col); 08906 } 08907 08908 TRACE (Func_Exit, "gen_runtime_conformance", NULL); 08909 08910 return; 08911 08912 } /* gen_runtime_conformance */ 08913 08914 /******************************************************************************\ 08915 |* *| 08916 |* Description: *| 08917 |* <description> *| 08918 |* *| 08919 |* Input parameters: *| 08920 |* NONE *| 08921 |* *| 08922 |* Output parameters: *| 08923 |* NONE *| 08924 |* *| 08925 |* Returns: *| 08926 |* NOTHING *| 08927 |* *| 08928 \******************************************************************************/ 08929 08930 void gen_runtime_substring(int substring_idx) 08931 08932 { 08933 int attr_idx; 08934 int list_idx; 08935 int line; 08936 int col; 08937 opnd_type size_opnd; 08938 opnd_type start_opnd; 08939 opnd_type subln_opnd; 08940 08941 TRACE (Func_Entry, "gen_runtime_substring", NULL); 08942 08943 attr_idx = find_base_attr(&IR_OPND_L(substring_idx), &line, &col); 08944 08945 # ifdef _DEBUG 08946 if (defer_stmt_expansion) { 08947 PRINTMSG(line, 626, Internal, col, 08948 "defer_stmt_expansion to be FALSE", 08949 "gen_runtime_substring"); 08950 } 08951 # endif 08952 08953 list_idx = IR_IDX_R(substring_idx); 08954 08955 OPND_FLD(size_opnd) = TYP_FLD(ATD_TYPE_IDX(attr_idx)); 08956 OPND_IDX(size_opnd) = TYP_IDX(ATD_TYPE_IDX(attr_idx)); 08957 OPND_LINE_NUM(size_opnd) = line; 08958 OPND_COL_NUM(size_opnd) = col; 08959 08960 COPY_OPND(start_opnd, IL_OPND(list_idx)); 08961 list_idx = IL_NEXT_LIST_IDX(list_idx); 08962 list_idx = IL_NEXT_LIST_IDX(list_idx); 08963 08964 # ifdef _DEBUG 08965 if (list_idx == NULL_IDX) { 08966 PRINTMSG(line, 626, Internal, col, 08967 "substring length", 08968 "gen_runtime_substring"); 08969 } 08970 # endif 08971 08972 COPY_OPND(subln_opnd, IL_OPND(list_idx)); 08973 08974 if (OPND_FLD(start_opnd) == CN_Tbl_Idx && 08975 OPND_FLD(subln_opnd) == CN_Tbl_Idx && 08976 OPND_FLD(size_opnd) == CN_Tbl_Idx) { 08977 08978 } 08979 else { 08980 gen_sbounds_check_call(AT_OBJ_NAME_PTR(attr_idx), 08981 &size_opnd, 08982 &start_opnd, 08983 &subln_opnd, 08984 line, 08985 col); 08986 08987 IR_BOUNDS_DONE(substring_idx) = TRUE; 08988 } 08989 08990 08991 TRACE (Func_Exit, "gen_runtime_substring", NULL); 08992 08993 return; 08994 08995 } /* gen_runtime_substring */ 08996 08997 /******************************************************************************\ 08998 |* *| 08999 |* Description: *| 09000 |* <description> *| 09001 |* *| 09002 |* Input parameters: *| 09003 |* NONE *| 09004 |* *| 09005 |* Output parameters: *| 09006 |* NONE *| 09007 |* *| 09008 |* Returns: *| 09009 |* NOTHING *| 09010 |* *| 09011 \******************************************************************************/ 09012 09013 void gen_runtime_ptr_chk(opnd_type *dv_opnd) 09014 09015 { 09016 int attr_idx; 09017 int bd_idx; 09018 int col; 09019 int left_attr; 09020 int line; 09021 09022 TRACE (Func_Entry, "gen_runtime_ptr_chk", NULL); 09023 09024 attr_idx = find_base_attr(dv_opnd, &line, &col); 09025 left_attr = find_left_attr(dv_opnd); 09026 09027 bd_idx = ATD_ARRAY_IDX(attr_idx); 09028 09029 if (ATD_CLASS(left_attr) == Compiler_Tmp) { 09030 goto EXIT; 09031 } 09032 09033 if (ATD_POINTER(attr_idx)) { 09034 gen_ptr_chk_call(AT_OBJ_NAME_PTR(attr_idx), 09035 1, /* means POINTER */ 09036 dv_opnd, 09037 line, 09038 col); 09039 } 09040 else if (ATD_ALLOCATABLE(attr_idx)) { 09041 gen_ptr_chk_call(AT_OBJ_NAME_PTR(attr_idx), 09042 2, /* means ALLOCATABLE ARRAY */ 09043 dv_opnd, 09044 line, 09045 col); 09046 } 09047 else if (bd_idx && 09048 BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) { 09049 gen_ptr_chk_call(AT_OBJ_NAME_PTR(attr_idx), 09050 3, /* means ASSUMED SHAPE ARRAY */ 09051 dv_opnd, 09052 line, 09053 col); 09054 } 09055 09056 EXIT: 09057 09058 TRACE (Func_Exit, "gen_runtime_ptr_chk", NULL); 09059 09060 return; 09061 09062 } /* gen_runtime_ptr_chk */ 09063 09064 /******************************************************************************\ 09065 |* *| 09066 |* Description: *| 09067 |* <description> *| 09068 |* *| 09069 |* Input parameters: *| 09070 |* NONE *| 09071 |* *| 09072 |* Output parameters: *| 09073 |* NONE *| 09074 |* *| 09075 |* Returns: *| 09076 |* NOTHING *| 09077 |* *| 09078 \******************************************************************************/ 09079 09080 void gen_runtime_bounds(int sub_idx) 09081 09082 { 09083 int attr_idx; 09084 int bd_idx; 09085 int col; 09086 int dim; 09087 opnd_type end_opnd; 09088 opnd_type inc_opnd; 09089 int ir_idx2; 09090 opnd_type lb_opnd; 09091 int line; 09092 int list_idx; 09093 int list_idx2; 09094 int minus_idx; 09095 opnd_type opnd; 09096 opnd_type opnd2; 09097 int plus_idx; 09098 opnd_type start_opnd; 09099 opnd_type ub_opnd; 09100 09101 TRACE (Func_Entry, "gen_runtime_bounds", NULL); 09102 09103 attr_idx = find_base_attr(&IR_OPND_L(sub_idx), &line, &col); 09104 09105 09106 # ifdef _DEBUG 09107 if (defer_stmt_expansion) { 09108 PRINTMSG(line, 626, Internal, col, 09109 "defer_stmt_expansion to be FALSE", 09110 "gen_runtime_bounds"); 09111 } 09112 # endif 09113 09114 bd_idx = ATD_ARRAY_IDX(attr_idx); 09115 09116 list_idx = IR_IDX_R(sub_idx); 09117 dim = 1; 09118 09119 while (list_idx != NULL_IDX) { 09120 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size && 09121 dim == BD_RANK(bd_idx)) { 09122 break; 09123 } 09124 09125 if (IL_VECTOR_SUBSCRIPT(list_idx)) { 09126 list_idx = IL_NEXT_LIST_IDX(list_idx); 09127 dim++; 09128 continue; 09129 } 09130 09131 if (ATD_IM_A_DOPE(attr_idx)) { 09132 COPY_OPND(opnd, IR_OPND_L(sub_idx)); 09133 09134 if (OPND_FLD(opnd) == IR_Tbl_Idx && 09135 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) { 09136 09137 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 09138 } 09139 09140 gen_dv_access_low_bound(&lb_opnd, &opnd, dim); 09141 09142 copy_subtree(&lb_opnd, &opnd2); 09143 09144 ir_idx2 = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 09145 Dv_Access_Extent, SA_INTEGER_DEFAULT_TYPE, 09146 line, col, 09147 NO_Tbl_Idx, NULL_IDX); 09148 IR_DV_DIM(ir_idx2) = dim; 09149 09150 plus_idx = gen_ir(OPND_FLD(opnd2), OPND_IDX(opnd2), 09151 Plus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, 09152 IR_Tbl_Idx, ir_idx2); 09153 09154 minus_idx = gen_ir(IR_Tbl_Idx, plus_idx, 09155 Minus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col, 09156 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 09157 09158 gen_opnd(&ub_opnd, minus_idx, IR_Tbl_Idx, line, col); 09159 } 09160 else { 09161 gen_opnd(&lb_opnd, BD_LB_IDX(bd_idx,dim), 09162 BD_LB_FLD(bd_idx, dim), line, col); 09163 gen_opnd(&ub_opnd, BD_UB_IDX(bd_idx,dim), 09164 BD_UB_FLD(bd_idx, dim), line, col); 09165 } 09166 09167 if (IL_FLD(list_idx) == IR_Tbl_Idx && 09168 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) { 09169 09170 list_idx2 = IR_IDX_L(IL_IDX(list_idx)); 09171 COPY_OPND(start_opnd, IL_OPND(list_idx2)); 09172 copy_subtree(&start_opnd, &start_opnd); 09173 09174 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 09175 COPY_OPND(end_opnd, IL_OPND(list_idx2)); 09176 copy_subtree(&end_opnd, &end_opnd); 09177 09178 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 09179 COPY_OPND(inc_opnd, IL_OPND(list_idx2)); 09180 copy_subtree(&inc_opnd, &inc_opnd); 09181 09182 if (OPND_FLD(lb_opnd) != CN_Tbl_Idx || 09183 OPND_FLD(ub_opnd) != CN_Tbl_Idx || 09184 OPND_FLD(start_opnd) != CN_Tbl_Idx || 09185 OPND_FLD(end_opnd) != CN_Tbl_Idx || 09186 OPND_FLD(inc_opnd) != CN_Tbl_Idx) { 09187 09188 gen_rbounds_check_call(AT_OBJ_NAME_PTR(attr_idx), 09189 &lb_opnd, 09190 &ub_opnd, 09191 &start_opnd, 09192 &end_opnd, 09193 &inc_opnd, 09194 dim, 09195 line, 09196 col); 09197 IR_BOUNDS_DONE(sub_idx) = TRUE; 09198 } 09199 } 09200 # if 0 09201 else if (IL_VECTOR_SUBSCRIPT(list_idx)) { 09202 /* not supported yet. These are pulled off of IO */ 09203 } 09204 # endif 09205 else if (IL_FLD(list_idx) != CN_Tbl_Idx || 09206 OPND_FLD(lb_opnd) != CN_Tbl_Idx || 09207 OPND_FLD(ub_opnd) != CN_Tbl_Idx) { 09208 09209 COPY_OPND(start_opnd, IL_OPND(list_idx)); 09210 copy_subtree(&start_opnd, &start_opnd); 09211 09212 gen_bounds_check_call(AT_OBJ_NAME_PTR(attr_idx), 09213 &lb_opnd, 09214 &ub_opnd, 09215 &start_opnd, 09216 dim, 09217 line, 09218 col); 09219 09220 IR_BOUNDS_DONE(sub_idx) = TRUE; 09221 } 09222 09223 list_idx = IL_NEXT_LIST_IDX(list_idx); 09224 dim++; 09225 } 09226 09227 TRACE (Func_Exit, "gen_runtime_bounds", NULL); 09228 09229 return; 09230 09231 } /* gen_runtime_bounds */ 09232 09233 /******************************************************************************\ 09234 |* *| 09235 |* Description: *| 09236 |* generate the call to the conformance check lib routine (which only *| 09237 |* issues the message). When support exists for a conform_opr, this *| 09238 |* routine will generate that. *| 09239 |* *| 09240 |* Input parameters: *| 09241 |* NONE *| 09242 |* *| 09243 |* Output parameters: *| 09244 |* NONE *| 09245 |* *| 09246 |* Returns: *| 09247 |* NOTHING *| 09248 |* *| 09249 \******************************************************************************/ 09250 09251 static void gen_conform_check_call(opnd_type *l_shape, opnd_type *r_shape, 09252 int dim, int line, int col) 09253 09254 { 09255 int call_idx; 09256 opnd_type cond_opnd; 09257 int dim_idx; 09258 int end_sh_idx; 09259 expr_arg_type exp_desc; 09260 int ir_idx; 09261 int line_idx; 09262 int list_idx; 09263 int max_idx; 09264 int max_idx2; 09265 opnd_type opnd; 09266 int save_curr_stmt_sh_idx; 09267 expr_mode_type save_expr_mode; 09268 cif_usage_code_type save_xref_state; 09269 int start_sh_idx; 09270 int tmp_idx; 09271 09272 09273 TRACE (Func_Entry, "gen_conform_check_call", NULL); 09274 09275 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 09276 09277 /* save the bounding stmts for the gen_if_stmt call */ 09278 09279 start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09280 end_sh_idx = curr_stmt_sh_idx; 09281 09282 /* generate the if condition */ 09283 09284 GEN_MAX_ZERO_IR(max_idx, (*l_shape), line, col); 09285 09286 GEN_MAX_ZERO_IR(max_idx2, (*r_shape), line, col); 09287 09288 ir_idx = gen_ir(IR_Tbl_Idx, max_idx, 09289 Ne_Opr, LOGICAL_DEFAULT_TYPE, line, col, 09290 IR_Tbl_Idx, max_idx2); 09291 09292 gen_opnd(&cond_opnd, ir_idx, IR_Tbl_Idx, line, col); 09293 09294 if (glb_tbl_idx[Conform_Attr_Idx] == NULL_IDX) { 09295 glb_tbl_idx[Conform_Attr_Idx] = create_lib_entry_attr( 09296 CONFORM_LIB_ENTRY, 09297 CONFORM_NAME_LEN, 09298 line, 09299 col); 09300 } 09301 09302 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Conform_Attr_Idx]); 09303 09304 /* count (= 0) must be static temp */ 09305 09306 tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col); 09307 09308 line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line); 09309 dim_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dim); 09310 09311 list_idx = gen_il(4, TRUE, line, col, 09312 CN_Tbl_Idx, put_file_name_in_cn(line), /* file name */ 09313 CN_Tbl_Idx, line_idx, /* line */ 09314 CN_Tbl_Idx, dim_idx, /* dim */ 09315 AT_Tbl_Idx, tmp_idx); /* count */ 09316 09317 call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Conform_Attr_Idx], 09318 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col, 09319 IL_Tbl_Idx, list_idx); 09320 09321 gen_sh(Before, Call_Stmt, line, col, 09322 FALSE, FALSE, TRUE); 09323 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09324 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 09325 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 09326 09327 gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col); 09328 09329 save_xref_state = xref_state; 09330 xref_state = CIF_No_Usage_Rec; 09331 save_expr_mode = expr_mode; 09332 expr_mode = Regular_Expr; 09333 09334 exp_desc = init_exp_desc; 09335 call_list_semantics(&opnd, &exp_desc, FALSE); 09336 xref_state = save_xref_state; 09337 expr_mode = save_expr_mode; 09338 09339 gen_if_stmt(&cond_opnd, 09340 SH_NEXT_IDX(start_sh_idx), 09341 SH_PREV_IDX(end_sh_idx), 09342 NULL_IDX, 09343 NULL_IDX, 09344 line, 09345 col); 09346 09347 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 09348 09349 TRACE (Func_Exit, "gen_conform_check_call", NULL); 09350 09351 return; 09352 09353 } /* gen_conform_check_call */ 09354 09355 /******************************************************************************\ 09356 |* *| 09357 |* Description: *| 09358 |* generate the call to the bounds check lib routine (which only *| 09359 |* issues the message). When support exists for a bounds_opr, this *| 09360 |* routine will generate that. *| 09361 |* *| 09362 |* Input parameters: *| 09363 |* NONE *| 09364 |* *| 09365 |* Output parameters: *| 09366 |* NONE *| 09367 |* *| 09368 |* Returns: *| 09369 |* NOTHING *| 09370 |* *| 09371 \******************************************************************************/ 09372 09373 static void gen_bounds_check_call(char *var, 09374 opnd_type *lb_opnd, 09375 opnd_type *ub_opnd, 09376 opnd_type *subscript, 09377 int dim, 09378 int line, 09379 int col) 09380 09381 { 09382 int call_idx; 09383 opnd_type cond_opnd; 09384 int dim_idx; 09385 int end_sh_idx; 09386 expr_arg_type exp_desc; 09387 int gt_idx; 09388 int line_idx; 09389 int list_idx; 09390 int lt_idx; 09391 int or_idx; 09392 opnd_type opnd; 09393 int save_curr_stmt_sh_idx; 09394 expr_mode_type save_expr_mode; 09395 cif_usage_code_type save_xref_state; 09396 int start_sh_idx; 09397 int tmp_idx; 09398 09399 09400 TRACE (Func_Entry, "gen_bounds_check_call", NULL); 09401 09402 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 09403 09404 /* save the bounding stmts for the gen_if_stmt call */ 09405 09406 start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09407 end_sh_idx = curr_stmt_sh_idx; 09408 09409 /* cond_opnd = (subscript < lb) .or. (subscript > ub) */ 09410 09411 /* subscript < lb */ 09412 09413 lt_idx = gen_ir(OPND_FLD((*subscript)), OPND_IDX((*subscript)), 09414 Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 09415 OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd))); 09416 09417 /* subscript > ub */ 09418 gt_idx = gen_ir(OPND_FLD((*subscript)), OPND_IDX((*subscript)), 09419 Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 09420 OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd))); 09421 09422 or_idx = gen_ir(IR_Tbl_Idx, lt_idx, 09423 Or_Opr, LOGICAL_DEFAULT_TYPE, line, col, 09424 IR_Tbl_Idx, gt_idx); 09425 09426 09427 gen_opnd(&cond_opnd, or_idx, IR_Tbl_Idx, line, col); 09428 09429 if (glb_tbl_idx[Bounds_Attr_Idx] == NULL_IDX) { 09430 glb_tbl_idx[Bounds_Attr_Idx] = create_lib_entry_attr( 09431 BOUNDS_LIB_ENTRY, 09432 BOUNDS_NAME_LEN, 09433 line, 09434 col); 09435 } 09436 09437 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Bounds_Attr_Idx]); 09438 09439 /* count (= 0) must be static temp */ 09440 09441 tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col); 09442 line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line); 09443 dim_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dim); 09444 09445 list_idx = gen_il(8, TRUE, line, col, 09446 CN_Tbl_Idx, put_file_name_in_cn(line), /* file name */ 09447 CN_Tbl_Idx, line_idx, 09448 CN_Tbl_Idx, put_c_str_in_cn(var), /* var name */ 09449 CN_Tbl_Idx, dim_idx, 09450 OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd)),/* lower bd */ 09451 OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd)),/* upper bd */ 09452 OPND_FLD((*subscript)), OPND_IDX((*subscript)), 09453 AT_Tbl_Idx, tmp_idx); /* count */ 09454 09455 call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Bounds_Attr_Idx], 09456 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col, 09457 IL_Tbl_Idx, list_idx); 09458 09459 gen_sh(Before, Call_Stmt, line, col, 09460 FALSE, FALSE, TRUE); 09461 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09462 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 09463 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 09464 09465 gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col); 09466 09467 save_xref_state = xref_state; 09468 xref_state = CIF_No_Usage_Rec; 09469 save_expr_mode = expr_mode; 09470 expr_mode = Regular_Expr; 09471 09472 exp_desc = init_exp_desc; 09473 call_list_semantics(&opnd, &exp_desc, FALSE); 09474 xref_state = save_xref_state; 09475 expr_mode = save_expr_mode; 09476 09477 gen_if_stmt(&cond_opnd, 09478 SH_NEXT_IDX(start_sh_idx), 09479 SH_PREV_IDX(end_sh_idx), 09480 NULL_IDX, 09481 NULL_IDX, 09482 line, 09483 col); 09484 09485 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 09486 09487 TRACE (Func_Exit, "gen_bounds_check_call", NULL); 09488 09489 return; 09490 09491 } /* gen_bounds_check_call */ 09492 09493 /******************************************************************************\ 09494 |* *| 09495 |* Description: *| 09496 |* generate the call to the bounds check lib routine (which only *| 09497 |* issues the message). When support exists for a bounds_opr, this *| 09498 |* routine will generate that. This is for range checks for sections. *| 09499 |* *| 09500 |* Input parameters: *| 09501 |* NONE *| 09502 |* *| 09503 |* Output parameters: *| 09504 |* NONE *| 09505 |* *| 09506 |* Returns: *| 09507 |* NOTHING *| 09508 |* *| 09509 \******************************************************************************/ 09510 09511 static void gen_rbounds_check_call(char *var, 09512 opnd_type *lb_opnd, 09513 opnd_type *ub_opnd, 09514 opnd_type *start_opnd, 09515 opnd_type *end_opnd, 09516 opnd_type *inc_opnd, 09517 int dim, 09518 int line, 09519 int col) 09520 09521 { 09522 int call_idx; 09523 opnd_type cond_opnd; 09524 int dim_idx; 09525 int end_sh_idx; 09526 expr_arg_type exp_desc; 09527 int line_idx; 09528 int list_idx; 09529 opnd_type opnd; 09530 int save_curr_stmt_sh_idx; 09531 expr_mode_type save_expr_mode; 09532 cif_usage_code_type save_xref_state; 09533 int start_sh_idx; 09534 int tmp_idx; 09535 09536 09537 TRACE (Func_Entry, "gen_rbounds_check_call", NULL); 09538 09539 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 09540 09541 /* save the bounding stmts for the gen_if_stmt call */ 09542 09543 start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09544 end_sh_idx = curr_stmt_sh_idx; 09545 09546 gen_rbounds_condition(&cond_opnd, 09547 start_opnd, 09548 end_opnd, 09549 inc_opnd, 09550 lb_opnd, 09551 ub_opnd, 09552 line, 09553 col); 09554 09555 if (glb_tbl_idx[Rbounds_Attr_Idx] == NULL_IDX) { 09556 glb_tbl_idx[Rbounds_Attr_Idx] = create_lib_entry_attr( 09557 RBOUNDS_LIB_ENTRY, 09558 RBOUNDS_NAME_LEN, 09559 line, 09560 col); 09561 } 09562 09563 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Rbounds_Attr_Idx]); 09564 09565 /* count (= 0) must be static temp */ 09566 09567 tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col); 09568 line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line); 09569 dim_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dim); 09570 list_idx = gen_il(10, TRUE, line, col, 09571 CN_Tbl_Idx, put_file_name_in_cn(line), /* file name */ 09572 CN_Tbl_Idx, line_idx, /* line */ 09573 CN_Tbl_Idx, put_c_str_in_cn(var), /* var name */ 09574 CN_Tbl_Idx, dim_idx, /* dim */ 09575 OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd)),/* lower bd */ 09576 OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd)),/* upper bd */ 09577 OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)), 09578 OPND_FLD((*end_opnd)), OPND_IDX((*end_opnd)), 09579 OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd)), 09580 AT_Tbl_Idx, tmp_idx); /* count */ 09581 09582 call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Rbounds_Attr_Idx], 09583 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col, 09584 IL_Tbl_Idx, list_idx); 09585 09586 gen_sh(Before, Call_Stmt, line, col, 09587 FALSE, FALSE, TRUE); 09588 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09589 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 09590 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 09591 09592 gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col); 09593 09594 save_xref_state = xref_state; 09595 xref_state = CIF_No_Usage_Rec; 09596 save_expr_mode = expr_mode; 09597 expr_mode = Regular_Expr; 09598 09599 exp_desc = init_exp_desc; 09600 call_list_semantics(&opnd, &exp_desc, FALSE); 09601 xref_state = save_xref_state; 09602 expr_mode = save_expr_mode; 09603 09604 gen_if_stmt(&cond_opnd, 09605 SH_NEXT_IDX(start_sh_idx), 09606 SH_PREV_IDX(end_sh_idx), 09607 NULL_IDX, 09608 NULL_IDX, 09609 line, 09610 col); 09611 09612 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 09613 09614 TRACE (Func_Exit, "gen_rbounds_check_call", NULL); 09615 09616 return; 09617 09618 } /* gen_rbounds_check_call */ 09619 09620 /******************************************************************************\ 09621 |* *| 09622 |* Description: *| 09623 |* generate the call to the substring bounds check lib routine (which *| 09624 |* issues the message). When support exists for a sbounds_opr, this *| 09625 |* routine will generate that. *| 09626 |* *| 09627 |* Input parameters: *| 09628 |* NONE *| 09629 |* *| 09630 |* Output parameters: *| 09631 |* NONE *| 09632 |* *| 09633 |* Returns: *| 09634 |* NOTHING *| 09635 |* *| 09636 \******************************************************************************/ 09637 09638 static void gen_sbounds_check_call(char *var, opnd_type *size_opnd, 09639 opnd_type *start_opnd, 09640 opnd_type *subln_opnd, int line, int col) 09641 09642 { 09643 int call_idx; 09644 opnd_type cond_opnd; 09645 int end_sh_idx; 09646 expr_arg_type exp_desc; 09647 int ir_idx; 09648 int line_idx; 09649 int list_idx; 09650 int lt_idx; 09651 int minus_idx; 09652 int minus_idx2; 09653 opnd_type opnd; 09654 int plus_idx; 09655 int plus_idx2; 09656 int save_curr_stmt_sh_idx; 09657 expr_mode_type save_expr_mode; 09658 cif_usage_code_type save_xref_state; 09659 int start_sh_idx; 09660 int tmp_idx; 09661 09662 09663 TRACE (Func_Entry, "gen_sbounds_check_call", NULL); 09664 09665 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 09666 09667 /* save the bounding stmts for the gen_if_stmt call */ 09668 09669 start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09670 end_sh_idx = curr_stmt_sh_idx; 09671 09672 /* generate the condition. */ 09673 09674 /* if start is a constant, it is assumed that the start value */ 09675 /* was checked at compile time and is not below 1. */ 09676 /* (1 + size_opnd) - (start_opnd + subln_opnd) < 0 => error */ 09677 /* else if start is not a constant ... */ 09678 /* (((1 + size_opnd) - (start_opnd + subln_opnd)) .bor. */ 09679 /* (start_opnd - 1)) < 0 */ 09680 09681 plus_idx = gen_ir(CN_Tbl_Idx, CN_INTEGER_ONE_IDX, 09682 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 09683 OPND_FLD((*size_opnd)), OPND_IDX((*size_opnd))); 09684 09685 plus_idx2 = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)), 09686 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 09687 OPND_FLD((*subln_opnd)), OPND_IDX((*subln_opnd))); 09688 09689 minus_idx = gen_ir(IR_Tbl_Idx, plus_idx, 09690 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 09691 IR_Tbl_Idx, plus_idx2); 09692 09693 if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx) { 09694 lt_idx = gen_ir(IR_Tbl_Idx, minus_idx, 09695 Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 09696 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 09697 } 09698 else { 09699 09700 minus_idx2 = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)), 09701 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 09702 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 09703 09704 ir_idx = gen_ir(IR_Tbl_Idx, minus_idx2, 09705 Bor_Opr, TYPELESS_DEFAULT_TYPE, line, col, 09706 IR_Tbl_Idx, minus_idx); 09707 09708 lt_idx = gen_ir(IR_Tbl_Idx, ir_idx, 09709 Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 09710 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 09711 } 09712 09713 gen_opnd(&cond_opnd, lt_idx, IR_Tbl_Idx, line, col); 09714 09715 if (glb_tbl_idx[Sbounds_Attr_Idx] == NULL_IDX) { 09716 glb_tbl_idx[Sbounds_Attr_Idx] = create_lib_entry_attr( 09717 SBOUNDS_LIB_ENTRY, 09718 SBOUNDS_NAME_LEN, 09719 line, 09720 col); 09721 } 09722 09723 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Sbounds_Attr_Idx]); 09724 09725 /* count (= 0) must be static temp */ 09726 09727 tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col); 09728 line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line); 09729 list_idx = gen_il(7, TRUE, line, col, 09730 CN_Tbl_Idx, put_file_name_in_cn(line), /* file name */ 09731 CN_Tbl_Idx, line_idx, /* line */ 09732 CN_Tbl_Idx, put_c_str_in_cn(var), /* var name */ 09733 OPND_FLD((*size_opnd)), OPND_IDX((*size_opnd)), 09734 OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)), 09735 OPND_FLD((*subln_opnd)), OPND_IDX((*subln_opnd)), 09736 AT_Tbl_Idx, tmp_idx); /* count */ 09737 09738 call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Sbounds_Attr_Idx], 09739 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col, 09740 IL_Tbl_Idx, list_idx); 09741 09742 gen_sh(Before, Call_Stmt, line, col, 09743 FALSE, FALSE, TRUE); 09744 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09745 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 09746 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 09747 09748 gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col); 09749 09750 save_xref_state = xref_state; 09751 xref_state = CIF_No_Usage_Rec; 09752 save_expr_mode = expr_mode; 09753 expr_mode = Regular_Expr; 09754 09755 exp_desc = init_exp_desc; 09756 call_list_semantics(&opnd, &exp_desc, FALSE); 09757 xref_state = save_xref_state; 09758 expr_mode = save_expr_mode; 09759 09760 gen_if_stmt(&cond_opnd, 09761 SH_NEXT_IDX(start_sh_idx), 09762 SH_PREV_IDX(end_sh_idx), 09763 NULL_IDX, 09764 NULL_IDX, 09765 line, 09766 col); 09767 09768 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 09769 09770 TRACE (Func_Exit, "gen_sbounds_check_call", NULL); 09771 09772 return; 09773 09774 } /* gen_sbounds_check_call */ 09775 09776 /******************************************************************************\ 09777 |* *| 09778 |* Description: *| 09779 |* generate the call to the NULL pointer checking lib routine (which *| 09780 |* issues the message). When support exists for a ptr_chk_opr, this *| 09781 |* routine will generate that. *| 09782 |* *| 09783 |* Input parameters: *| 09784 |* NONE *| 09785 |* *| 09786 |* Output parameters: *| 09787 |* NONE *| 09788 |* *| 09789 |* Returns: *| 09790 |* NOTHING *| 09791 |* *| 09792 \******************************************************************************/ 09793 09794 static void gen_ptr_chk_call(char *var, 09795 int dv_desc, 09796 opnd_type *dv_opnd, 09797 int line, 09798 int col) 09799 09800 { 09801 int call_idx; 09802 opnd_type cond_opnd; 09803 int dv_idx; 09804 int end_sh_idx; 09805 int eq_idx; 09806 expr_arg_type exp_desc; 09807 int ir_idx; 09808 int line_idx; 09809 int list_idx; 09810 opnd_type opnd; 09811 int save_curr_stmt_sh_idx; 09812 expr_mode_type save_expr_mode; 09813 cif_usage_code_type save_xref_state; 09814 int start_sh_idx; 09815 int tmp_idx; 09816 09817 09818 TRACE (Func_Entry, "gen_ptr_chk_call", NULL); 09819 09820 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 09821 09822 /* save the bounding stmts for the gen_if_stmt call */ 09823 09824 start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09825 end_sh_idx = curr_stmt_sh_idx; 09826 09827 /* generate the condition. */ 09828 09829 ir_idx = gen_ir(OPND_FLD((*dv_opnd)), OPND_IDX((*dv_opnd)), 09830 Dv_Access_Assoc, CG_INTEGER_DEFAULT_TYPE, line, col, 09831 NO_Tbl_Idx, NULL_IDX); 09832 09833 eq_idx = gen_ir(IR_Tbl_Idx, ir_idx, 09834 Eq_Opr, LOGICAL_DEFAULT_TYPE, line, col, 09835 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 09836 09837 gen_opnd(&cond_opnd, eq_idx, IR_Tbl_Idx, line, col); 09838 09839 if (glb_tbl_idx[Ptr_Chk_Attr_Idx] == NULL_IDX) { 09840 glb_tbl_idx[Ptr_Chk_Attr_Idx] = create_lib_entry_attr( 09841 PTR_CHK_LIB_ENTRY, 09842 PTR_CHK_NAME_LEN, 09843 line, 09844 col); 09845 } 09846 09847 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Ptr_Chk_Attr_Idx]); 09848 09849 /* count (= 0) must be static temp */ 09850 09851 tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col); 09852 line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line); 09853 dv_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dv_desc); 09854 09855 list_idx = gen_il(5, TRUE, line, col, 09856 CN_Tbl_Idx, put_file_name_in_cn(line), /* file name */ 09857 CN_Tbl_Idx, line_idx, /* line */ 09858 CN_Tbl_Idx, put_c_str_in_cn(var), /* var name */ 09859 CN_Tbl_Idx, dv_idx, /* dv_desc */ 09860 AT_Tbl_Idx, tmp_idx); /* count */ 09861 09862 call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Ptr_Chk_Attr_Idx], 09863 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col, 09864 IL_Tbl_Idx, list_idx); 09865 09866 gen_sh(Before, Call_Stmt, line, col, 09867 FALSE, FALSE, TRUE); 09868 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09869 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 09870 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 09871 09872 gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col); 09873 09874 save_xref_state = xref_state; 09875 xref_state = CIF_No_Usage_Rec; 09876 save_expr_mode = expr_mode; 09877 expr_mode = Regular_Expr; 09878 09879 exp_desc = init_exp_desc; 09880 call_list_semantics(&opnd, &exp_desc, FALSE); 09881 xref_state = save_xref_state; 09882 expr_mode = save_expr_mode; 09883 09884 gen_if_stmt(&cond_opnd, 09885 SH_NEXT_IDX(start_sh_idx), 09886 SH_PREV_IDX(end_sh_idx), 09887 NULL_IDX, 09888 NULL_IDX, 09889 line, 09890 col); 09891 09892 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 09893 09894 TRACE (Func_Exit, "gen_ptr_chk_call", NULL); 09895 09896 return; 09897 09898 } /* gen_ptr_chk_call */ 09899 09900 /******************************************************************************\ 09901 |* *| 09902 |* Description: *| 09903 |* generate a static compiler temp with the type of the given contant *| 09904 |* and initialize it to the constant. *| 09905 |* *| 09906 |* Input parameters: *| 09907 |* NONE *| 09908 |* *| 09909 |* Output parameters: *| 09910 |* NONE *| 09911 |* *| 09912 |* Returns: *| 09913 |* NOTHING *| 09914 |* *| 09915 \******************************************************************************/ 09916 09917 int gen_initialized_tmp(int cn_idx, 09918 int line, 09919 int col) 09920 09921 { 09922 int asg_idx; 09923 int list_idx; 09924 int tmp_idx; 09925 09926 TRACE (Func_Entry, "gen_initialized_tmp", NULL); 09927 09928 tmp_idx = gen_compiler_tmp(line,col, Shared, TRUE); 09929 ATD_TYPE_IDX(tmp_idx) = CN_TYPE_IDX(cn_idx); 09930 09931 ATD_SAVED(tmp_idx) = TRUE; 09932 ATD_DATA_INIT(tmp_idx) = TRUE; 09933 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 09934 ATD_FLD(tmp_idx) = CN_Tbl_Idx; 09935 ATD_TMP_IDX(tmp_idx) = cn_idx; 09936 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 09937 09938 /* create data init stmt */ 09939 NTR_IR_TBL(asg_idx); 09940 IR_OPR(asg_idx) = Init_Opr; 09941 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 09942 IR_LINE_NUM(asg_idx) = line; 09943 IR_COL_NUM(asg_idx) = col; 09944 IR_LINE_NUM_L(asg_idx) = line; 09945 IR_COL_NUM_L(asg_idx) = col; 09946 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 09947 IR_IDX_L(asg_idx) = tmp_idx; 09948 09949 NTR_IR_LIST_TBL(list_idx); 09950 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 09951 IR_IDX_R(asg_idx) = list_idx; 09952 IR_LIST_CNT_R(asg_idx) = 3; 09953 09954 IL_FLD(list_idx) = CN_Tbl_Idx; 09955 IL_IDX(list_idx) = cn_idx; 09956 IL_LINE_NUM(list_idx) = line; 09957 IL_COL_NUM(list_idx) = col; 09958 09959 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09960 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09961 list_idx = IL_NEXT_LIST_IDX(list_idx); 09962 09963 IL_FLD(list_idx) = CN_Tbl_Idx; 09964 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 09965 IL_LINE_NUM(list_idx) = line; 09966 IL_COL_NUM(list_idx) = col; 09967 09968 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 09969 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 09970 list_idx = IL_NEXT_LIST_IDX(list_idx); 09971 09972 IL_FLD(list_idx) = CN_Tbl_Idx; 09973 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 09974 IL_LINE_NUM(list_idx) = line; 09975 IL_COL_NUM(list_idx) = col; 09976 09977 gen_sh(Before, Assignment_Stmt, line, col, 09978 FALSE, FALSE, TRUE); 09979 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09980 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09981 09982 TRACE (Func_Exit, "gen_initialized_tmp", NULL); 09983 09984 return(tmp_idx); 09985 09986 } /* gen_initialized_tmp */ 09987 09988 /******************************************************************************\ 09989 |* *| 09990 |* Description: *| 09991 |* <description> *| 09992 |* *| 09993 |* Input parameters: *| 09994 |* NONE *| 09995 |* *| 09996 |* Output parameters: *| 09997 |* NONE *| 09998 |* *| 09999 |* Returns: *| 10000 |* NOTHING *| 10001 |* *| 10002 \******************************************************************************/ 10003 10004 static int put_file_name_in_cn(int line) 10005 10006 { 10007 int cn_idx; 10008 int idx; 10009 char name[MAX_FILE_NAME_SIZE]; 10010 10011 10012 TRACE (Func_Entry, "put_file_name_in_cn", NULL); 10013 10014 /*******************************************************\ 10015 |* THIS ROUTINE IS ONLY FOR RUNTIME CHECKING CALLS !!! *| 10016 \*******************************************************/ 10017 10018 strcpy(name, global_to_local_file(line)); 10019 10020 for (idx = strlen(name) - 1; idx >= 0; idx--) { 10021 if (name[idx] == '/') 10022 break; 10023 } 10024 10025 idx++; 10026 10027 cn_idx = put_c_str_in_cn(&(name[idx])); 10028 10029 TRACE (Func_Exit, "put_file_name_in_cn", NULL); 10030 10031 return(cn_idx); 10032 10033 } /* put_file_name_in_cn */ 10034 10035 /******************************************************************************\ 10036 |* *| 10037 |* Description: *| 10038 |* <description> *| 10039 |* *| 10040 |* Input parameters: *| 10041 |* NONE *| 10042 |* *| 10043 |* Output parameters: *| 10044 |* NONE *| 10045 |* *| 10046 |* Returns: *| 10047 |* NOTHING *| 10048 |* *| 10049 \******************************************************************************/ 10050 10051 static int put_c_str_in_cn(char *ch_ptr) 10052 10053 { 10054 int cn_idx; 10055 int i; 10056 long length; 10057 long_type the_constant[(MAX_FILE_NAME_SIZE + TARGET_CHARS_PER_WORD - 1)/ 10058 TARGET_CHARS_PER_WORD]; 10059 int type_idx; 10060 10061 TRACE (Func_Entry, "put_c_str_in_cn", NULL); 10062 10063 /*******************************************************\ 10064 |* THIS ROUTINE IS ONLY FOR RUNTIME CHECKING CALLS !!! *| 10065 \*******************************************************/ 10066 10067 for (i = 0; i < (MAX_FILE_NAME_SIZE + TARGET_CHARS_PER_WORD - 1)/ 10068 TARGET_CHARS_PER_WORD; i++) { 10069 the_constant[i] = 0; 10070 } 10071 10072 length = (long) strlen(ch_ptr); 10073 10074 /* add one to length for the null byte */ 10075 length++; 10076 10077 strcpy((char *)the_constant, ch_ptr); 10078 10079 if (two_word_fcd) { 10080 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 10081 TYP_TYPE(TYP_WORK_IDX) = Typeless; 10082 TYP_BIT_LEN(TYP_WORK_IDX) = WORD_ALIGNED_BIT_LENGTH(length * CHAR_BIT); 10083 type_idx = ntr_type_tbl(); 10084 } 10085 else { 10086 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 10087 TYP_TYPE(TYP_WORK_IDX) = Character; 10088 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 10089 TYP_DESC(TYP_WORK_IDX) = Default_Typed; 10090 TYP_CHAR_CLASS(TYP_WORK_IDX)= Const_Len_Char; 10091 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 10092 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, length); 10093 type_idx = ntr_type_tbl(); 10094 } 10095 10096 cn_idx = ntr_const_tbl(type_idx, 10097 TRUE, 10098 the_constant); 10099 10100 TRACE (Func_Exit, "put_c_str_in_cn", NULL); 10101 10102 return(cn_idx); 10103 10104 } /* put_c_str_in_cn */ 10105 10106 /******************************************************************************\ 10107 |* *| 10108 |* Description: *| 10109 |* <description> *| 10110 |* *| 10111 |* Input parameters: *| 10112 |* NONE *| 10113 |* *| 10114 |* Output parameters: *| 10115 |* NONE *| 10116 |* *| 10117 |* Returns: *| 10118 |* NOTHING *| 10119 |* *| 10120 \******************************************************************************/ 10121 10122 void gen_internal_call_stmt(char *name, 10123 opnd_type *opnd, 10124 sh_position_type position) 10125 10126 { 10127 10128 int call_idx; 10129 int list_idx; 10130 int loc_idx; 10131 int lib_idx; 10132 10133 TRACE (Func_Entry, "gen_internal_call_stmt", NULL); 10134 10135 lib_idx = create_lib_entry_attr(name, 10136 strlen(name), 10137 stmt_start_line, 10138 stmt_start_col); 10139 10140 ADD_ATTR_TO_LOCAL_LIST(lib_idx); 10141 10142 NTR_IR_TBL(call_idx); 10143 IR_OPR(call_idx) = Call_Opr; 10144 IR_TYPE_IDX(call_idx) = CG_INTEGER_DEFAULT_TYPE; 10145 IR_LINE_NUM(call_idx) = stmt_start_line; 10146 IR_COL_NUM(call_idx) = stmt_start_col; 10147 IR_FLD_L(call_idx) = AT_Tbl_Idx; 10148 IR_IDX_L(call_idx) = lib_idx; 10149 IR_LINE_NUM_L(call_idx) = stmt_start_line; 10150 IR_COL_NUM_L(call_idx) = stmt_start_col; 10151 10152 NTR_IR_LIST_TBL(list_idx); 10153 IR_FLD_R(call_idx) = IL_Tbl_Idx; 10154 IR_IDX_R(call_idx) = list_idx; 10155 IR_LIST_CNT_R(call_idx) = 1; 10156 10157 NTR_IR_TBL(loc_idx); 10158 10159 if (OPND_FLD((*opnd)) == CN_Tbl_Idx) { 10160 IR_OPR(loc_idx) = Const_Tmp_Loc_Opr; 10161 IR_TYPE_IDX(loc_idx) = CN_TYPE_IDX(OPND_IDX((*opnd))); 10162 } 10163 else { 10164 IR_OPR(loc_idx) = Aloc_Opr; 10165 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 10166 } 10167 10168 IR_LINE_NUM(loc_idx) = stmt_start_line; 10169 IR_COL_NUM(loc_idx) = stmt_start_col; 10170 IL_FLD(list_idx) = IR_Tbl_Idx; 10171 IL_IDX(list_idx) = loc_idx; 10172 10173 COPY_OPND(IR_OPND_L(loc_idx), (*opnd)); 10174 10175 gen_sh(position, Call_Stmt, stmt_start_line, 10176 stmt_start_col, FALSE, FALSE, TRUE); 10177 10178 if (position == Before) { 10179 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = call_idx; 10180 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10181 } 10182 else { 10183 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 10184 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10185 } 10186 10187 TRACE (Func_Exit, "gen_internal_call_stmt", NULL); 10188 10189 return; 10190 10191 } /* gen_internal_call_stmt */ 10192 10193 /******************************************************************************\ 10194 |* *| 10195 |* Description: *| 10196 |* <description> *| 10197 |* *| 10198 |* Input parameters: *| 10199 |* NONE *| 10200 |* *| 10201 |* Output parameters: *| 10202 |* NONE *| 10203 |* *| 10204 |* Returns: *| 10205 |* NOTHING *| 10206 |* *| 10207 \******************************************************************************/ 10208 10209 void gen_lb_array_ref(opnd_type *result_opnd, 10210 int attr_idx) 10211 10212 { 10213 int bd_idx; 10214 int i; 10215 int list_idx; 10216 int sub_idx; 10217 10218 TRACE (Func_Entry, "gen_lb_array_ref", NULL); 10219 10220 bd_idx = ATD_ARRAY_IDX(attr_idx); 10221 10222 NTR_IR_TBL(sub_idx); 10223 IR_OPR(sub_idx) = Subscript_Opr; 10224 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx); 10225 IR_LINE_NUM(sub_idx) = stmt_start_line; 10226 IR_COL_NUM(sub_idx) = stmt_start_col; 10227 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 10228 IR_IDX_L(sub_idx) = attr_idx; 10229 IR_LINE_NUM_L(sub_idx) = stmt_start_line; 10230 IR_COL_NUM_L(sub_idx) = stmt_start_col; 10231 10232 NTR_IR_LIST_TBL(list_idx); 10233 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 10234 IR_LIST_CNT_R(sub_idx) = BD_RANK(bd_idx); 10235 IR_IDX_R(sub_idx) = list_idx; 10236 10237 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1); 10238 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1); 10239 IL_LINE_NUM(list_idx) = stmt_start_line; 10240 IL_COL_NUM(list_idx) = stmt_start_col; 10241 10242 for (i = 2; i <= BD_RANK(bd_idx); i++) { 10243 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 10244 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 10245 list_idx = IL_NEXT_LIST_IDX(list_idx); 10246 10247 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 10248 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 10249 IL_LINE_NUM(list_idx) = stmt_start_line; 10250 IL_COL_NUM(list_idx) = stmt_start_col; 10251 } 10252 10253 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 10254 OPND_IDX((*result_opnd)) = sub_idx; 10255 10256 TRACE (Func_Exit, "gen_lb_array_ref", NULL); 10257 10258 return; 10259 10260 } /* gen_lb_array_ref */ 10261 10262 /******************************************************************************\ 10263 |* *| 10264 |* Description: *| 10265 |* <description> *| 10266 |* *| 10267 |* Input parameters: *| 10268 |* NONE *| 10269 |* *| 10270 |* Output parameters: *| 10271 |* NONE *| 10272 |* *| 10273 |* Returns: *| 10274 |* NOTHING *| 10275 |* *| 10276 \******************************************************************************/ 10277 10278 void set_up_exp_desc(opnd_type *top_opnd, 10279 expr_arg_type *exp_desc) 10280 10281 { 10282 int attr_idx; 10283 int col; 10284 int line; 10285 10286 TRACE (Func_Entry, "set_up_exp_desc", NULL); 10287 10288 (*exp_desc) = init_exp_desc; 10289 10290 find_opnd_line_and_column(top_opnd, &line, &col); 10291 10292 switch (OPND_FLD((*top_opnd))) { 10293 case AT_Tbl_Idx: 10294 attr_idx = OPND_IDX((*top_opnd)); 10295 10296 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 10297 exp_desc->type_idx = ATD_TYPE_IDX(attr_idx); 10298 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 10299 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 10300 } 10301 # ifdef _DEBUG 10302 else { 10303 PRINTMSG(line, 626, Internal, col, 10304 "Data_Obj", "set_up_exp_desc"); 10305 } 10306 # endif 10307 break; 10308 10309 case IR_Tbl_Idx: 10310 exp_desc->type_idx = IR_TYPE_IDX(OPND_IDX((*top_opnd))); 10311 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 10312 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 10313 exp_desc->rank = IR_RANK(OPND_IDX((*top_opnd))); 10314 break; 10315 10316 case CN_Tbl_Idx: 10317 exp_desc->type_idx = CN_TYPE_IDX(OPND_IDX((*top_opnd))); 10318 exp_desc->type = TYP_TYPE(exp_desc->type_idx); 10319 exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx); 10320 break; 10321 10322 default: 10323 # ifdef _DEBUG 10324 PRINTMSG(line, 626, Internal, col, 10325 "AT_Tbl_Idx, IR_Tbl_Idx, or CN_Tbl_Idx", 10326 "set_up_exp_desc"); 10327 # endif 10328 break; 10329 } 10330 10331 TRACE (Func_Exit, "set_up_exp_desc", NULL); 10332 10333 return; 10334 10335 } /* set_up_exp_desc */ 10336 10337 /******************************************************************************\ 10338 |* *| 10339 |* Description: *| 10340 |* Swap the dimensions for certain array bounds and references for the *| 10341 |* current scope. *| 10342 |* *| 10343 |* Input parameters: *| 10344 |* NONE *| 10345 |* *| 10346 |* Output parameters: *| 10347 |* NONE *| 10348 |* *| 10349 |* Returns: *| 10350 |* NOTHING *| 10351 |* *| 10352 \******************************************************************************/ 10353 10354 void dim_reshape_pass_driver (void) 10355 10356 { 10357 int al_idx; 10358 int attr_idx; 10359 opnd_type opnd; 10360 int save_curr_stmt_sh_idx; 10361 10362 10363 TRACE (Func_Entry, "dim_reshape_pass_driver", NULL); 10364 10365 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 10366 10367 /* first, create new bounds table entries for reshape candidates */ 10368 10369 al_idx = SCP_RESHAPE_ARRAY_LIST(curr_scp_idx); 10370 10371 while (al_idx) { 10372 attr_idx = AL_ATTR_IDX(al_idx); 10373 10374 # ifdef _DEBUG 10375 if (AT_OBJ_CLASS(attr_idx) != Data_Obj || 10376 ! ATD_RESHAPE_ARRAY_OPT(attr_idx)) { 10377 10378 PRINTMSG(1, 626, Internal, 1, 10379 "ATD_RESHAPE_ARRAY_OPT flag", "dim_reshape_pass_driver"); 10380 } 10381 10382 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX || 10383 ATD_RESHAPE_ARRAY_IDX(attr_idx) == NULL_IDX) { 10384 PRINTMSG(1, 626, Internal, 1, 10385 "ATD_RESHAPE_ARRAY_IDX", "dim_reshape_pass_driver"); 10386 } 10387 # endif 10388 10389 ATD_ARRAY_IDX(attr_idx) = ATD_RESHAPE_ARRAY_IDX(attr_idx); 10390 al_idx = AL_NEXT_IDX(al_idx); 10391 } 10392 10393 /* second, traverse the ir to reshape reference dimensions */ 10394 10395 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 10396 10397 while (curr_stmt_sh_idx != NULL_IDX) { 10398 10399 if (SH_IR_IDX(curr_stmt_sh_idx) != NULL_IDX) { 10400 OPND_FLD(opnd) = IR_Tbl_Idx; 10401 OPND_IDX(opnd) = SH_IR_IDX(curr_stmt_sh_idx); 10402 10403 reshape_reference_subscripts(&opnd); 10404 10405 SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(opnd); 10406 } 10407 10408 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 10409 } 10410 10411 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 10412 10413 PRINT_IR_TBL4; 10414 10415 TRACE (Func_Exit, "dim_reshape_pass_driver", NULL); 10416 10417 return; 10418 10419 } /* dim_reshape_pass_driver */ 10420 10421 /******************************************************************************\ 10422 |* *| 10423 |* Description: *| 10424 |* <description> *| 10425 |* *| 10426 |* Input parameters: *| 10427 |* NONE *| 10428 |* *| 10429 |* Output parameters: *| 10430 |* NONE *| 10431 |* *| 10432 |* Returns: *| 10433 |* NOTHING *| 10434 |* *| 10435 \******************************************************************************/ 10436 10437 static void reshape_reference_subscripts(opnd_type *result_opnd) 10438 10439 { 10440 int attr_idx; 10441 int col; 10442 int ir_idx; 10443 int line; 10444 int head; 10445 int list_idx; 10446 opnd_type opnd; 10447 10448 10449 TRACE (Func_Entry, "reshape_reference_subscripts", NULL); 10450 10451 switch (OPND_FLD((*result_opnd))) { 10452 case IR_Tbl_Idx: 10453 ir_idx = OPND_IDX((*result_opnd)); 10454 10455 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 10456 reshape_reference_subscripts(&opnd); 10457 COPY_OPND(IR_OPND_L(ir_idx), opnd); 10458 10459 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 10460 reshape_reference_subscripts(&opnd); 10461 COPY_OPND(IR_OPND_R(ir_idx), opnd); 10462 10463 if (IR_OPR(ir_idx) == Subscript_Opr || 10464 IR_OPR(ir_idx) == Whole_Subscript_Opr || 10465 IR_OPR(ir_idx) == Section_Subscript_Opr) { 10466 10467 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 10468 attr_idx = find_base_attr(&opnd, &line, &col); 10469 10470 if (ATD_RESHAPE_ARRAY_OPT(attr_idx)) { 10471 gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, IR_LINE_NUM(ir_idx), 10472 IR_COL_NUM(ir_idx)); 10473 copy_subtree(&opnd, result_opnd); 10474 ir_idx = OPND_IDX((*result_opnd)); 10475 10476 list_idx = IR_IDX_R(ir_idx); 10477 head = list_idx; 10478 10479 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 10480 list_idx = IL_NEXT_LIST_IDX(list_idx); 10481 } 10482 IR_IDX_R(ir_idx) = list_idx; 10483 IL_NEXT_LIST_IDX(IL_PREV_LIST_IDX(list_idx)) = NULL_IDX; 10484 IL_PREV_LIST_IDX(list_idx) = NULL_IDX; 10485 IL_NEXT_LIST_IDX(list_idx) = head; 10486 IL_PREV_LIST_IDX(head) = list_idx; 10487 } 10488 } 10489 break; 10490 10491 case IL_Tbl_Idx: 10492 list_idx = OPND_IDX((*result_opnd)); 10493 10494 while (list_idx) { 10495 COPY_OPND(opnd, IL_OPND(list_idx)); 10496 reshape_reference_subscripts(&opnd); 10497 COPY_OPND(IL_OPND(list_idx), opnd); 10498 10499 list_idx = IL_NEXT_LIST_IDX(list_idx); 10500 } 10501 break; 10502 } 10503 10504 TRACE (Func_Exit, "reshape_reference_subscripts", NULL); 10505 10506 return; 10507 10508 } /* reshape_reference_subscripts */ 10509 10510 /******************************************************************************\ 10511 |* *| 10512 |* Description: *| 10513 |* <description> *| 10514 |* *| 10515 |* Input parameters: *| 10516 |* NONE *| 10517 |* *| 10518 |* Output parameters: *| 10519 |* NONE *| 10520 |* *| 10521 |* Returns: *| 10522 |* NOTHING *| 10523 |* *| 10524 \******************************************************************************/ 10525 10526 boolean check_for_legal_define(opnd_type *top_opnd) 10527 10528 { 10529 int attr_idx; 10530 int col; 10531 int line; 10532 boolean ok = TRUE; 10533 opnd_type opnd; 10534 10535 TRACE (Func_Entry, "check_for_legal_define", NULL); 10536 10537 COPY_OPND(opnd, (*top_opnd)); 10538 10539 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 10540 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 10541 } 10542 10543 if (OPND_FLD(opnd) == AT_Tbl_Idx && 10544 AT_OBJ_CLASS(OPND_IDX(opnd)) == Data_Obj) { 10545 10546 attr_idx = OPND_IDX(opnd); 10547 line = OPND_LINE_NUM(opnd); 10548 col = OPND_COL_NUM(opnd); 10549 10550 if (ATD_LIVE_DO_VAR(attr_idx)) { 10551 PRINTMSG(line, 48, Error, col); 10552 ok = FALSE; 10553 } 10554 else if (ATD_PURE(attr_idx)) { 10555 PRINTMSG(line, 1270, Error, col, 10556 AT_OBJ_NAME_PTR(attr_idx), 10557 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure":"elemental"); 10558 ok = FALSE; 10559 } 10560 else if (ATD_CLASS(attr_idx) == Dummy_Argument && 10561 ATD_INTENT(attr_idx) == Intent_In) { 10562 PRINTMSG(line, 890, Error, col, 10563 AT_OBJ_NAME_PTR(attr_idx)); 10564 ok = FALSE; 10565 } 10566 else if (ATD_FORALL_INDEX(attr_idx)) { 10567 PRINTMSG(line, 1608, Error, col, 10568 AT_OBJ_NAME_PTR(attr_idx)); 10569 ok = FALSE; 10570 } 10571 else if (ATD_SYMBOLIC_CONSTANT(attr_idx) && 10572 (ATD_CLASS(attr_idx) == Variable || 10573 ATD_CLASS(attr_idx) == Constant)) { 10574 PRINTMSG(line, 1632, Error, col, 10575 AT_OBJ_NAME_PTR(attr_idx)); 10576 ok = FALSE; 10577 } 10578 } 10579 10580 10581 TRACE (Func_Exit, "check_for_legal_define", NULL); 10582 10583 return(ok); 10584 10585 } /* check_for_legal_define */ 10586 10587 10588 10589 /******************************************************************************\ 10590 |* *| 10591 |* Description: *| 10592 |* Check for a dependence in an arbitrary expression. *| 10593 |* *| 10594 |* Input parameters: *| 10595 |* item opject which we will search for in exp *| 10596 |* exp this is the expression that is to be searched *| 10597 |* *| 10598 |* Output parameters: *| 10599 |* NONE *| 10600 |* *| 10601 |* Returns: *| 10602 |* boolean indicating a dependence was found *| 10603 |* *| 10604 \******************************************************************************/ 10605 void check_dependence(boolean *dependant, 10606 opnd_type item, 10607 opnd_type exp) 10608 10609 { 10610 int attr_idx; 10611 int idx; 10612 int fld; 10613 int line; 10614 int col; 10615 10616 static int level; 10617 static boolean target_found; 10618 static boolean pointer_found; 10619 static boolean pointer_item; 10620 static boolean target_item; 10621 10622 TRACE (Func_Entry, "check_dependence", NULL); 10623 level = level + 1; 10624 10625 10626 attr_idx = find_base_attr(&item, &line, &col); 10627 if (ATD_POINTER(attr_idx)) pointer_item = TRUE; 10628 if (ATD_TARGET(attr_idx)) target_item = TRUE; 10629 if (ATD_CLASS(attr_idx) == CRI__Pointee) *dependant = TRUE; 10630 10631 attr_idx = find_left_attr(&item); 10632 if (ATD_EQUIV(attr_idx)) *dependant = TRUE; 10633 10634 idx = OPND_IDX(exp); 10635 fld = OPND_FLD(exp); 10636 10637 if (idx != NULL_IDX) { 10638 10639 switch(fld) { 10640 case IR_Tbl_Idx : 10641 if (IR_FLD_R(idx) != NO_Tbl_Idx) { 10642 check_dependence(dependant, item, IR_OPND_R(idx)); 10643 } 10644 10645 if (IR_FLD_L(idx) != NO_Tbl_Idx) { 10646 check_dependence(dependant, item, IR_OPND_L(idx)); 10647 } 10648 break; 10649 10650 case AT_Tbl_Idx : 10651 if (AT_OBJ_CLASS(idx) == Data_Obj) { 10652 if (ATD_TARGET(idx)) target_found = TRUE; 10653 if (ATD_POINTER(idx)) pointer_found = TRUE; 10654 if (idx == attr_idx) *dependant = TRUE; 10655 } 10656 break; 10657 10658 case NO_Tbl_Idx : 10659 case CN_Tbl_Idx : 10660 case SH_Tbl_Idx : 10661 break; 10662 10663 case IL_Tbl_Idx : 10664 while (idx != NULL_IDX) { 10665 if (IL_FLD(idx) != NO_Tbl_Idx) { 10666 check_dependence(dependant, item, IL_OPND(idx)); 10667 } 10668 idx = IL_NEXT_LIST_IDX(idx); 10669 } 10670 break; 10671 } 10672 } 10673 10674 10675 level = level - 1; 10676 if (level == 0) { 10677 if (target_found && pointer_item) *dependant = TRUE; 10678 if (pointer_found && pointer_item) *dependant = TRUE; 10679 if (pointer_found && target_item) *dependant = TRUE; 10680 target_found = FALSE; 10681 pointer_found = FALSE; 10682 pointer_item = FALSE; 10683 target_item = FALSE; 10684 } 10685 10686 TRACE (Func_Exit, "check_dependence", NULL); 10687 10688 } /* check_dependence */ 10689 10690 /******************************************************************************\ 10691 |* *| 10692 |* Description: *| 10693 |* This routine takes an array section (or whole array) reference and *| 10694 |* returns an array element reference corresponding to which_one. *| 10695 |* the section must be rank 1 and which_one is 1 based. *| 10696 |* *| 10697 |* Input parameters: *| 10698 |* section_opnd - the array section *| 10699 |* which_one - which element you want (1,2,3,...) *| 10700 |* *| 10701 |* Output parameters: *| 10702 |* element_opnd - the resulting element reference tree. *| 10703 |* *| 10704 |* Returns: *| 10705 |* NOTHING *| 10706 |* *| 10707 \******************************************************************************/ 10708 10709 void change_section_to_this_element(opnd_type *section_opnd, 10710 opnd_type *element_opnd, 10711 int which_one) 10712 10713 { 10714 int col; 10715 expr_arg_type exp_desc; 10716 int line; 10717 int list_idx; 10718 int mult_idx; 10719 opnd_type opnd1; 10720 opnd_type opnd2; 10721 int plus_idx; 10722 int rank_idx = NULL_IDX; 10723 cif_usage_code_type save_xref_state; 10724 int start_list_idx; 10725 int stride_list_idx; 10726 int trip_idx; 10727 int unused = NULL_IDX; 10728 10729 TRACE (Func_Entry, "change_section_to_this_element", NULL); 10730 10731 find_opnd_line_and_column(section_opnd, &line, &col); 10732 10733 # ifdef _DEBUG 10734 if (OPND_FLD((*section_opnd)) != IR_Tbl_Idx || 10735 IR_RANK(OPND_IDX((*section_opnd))) != 1) { 10736 PRINTMSG(line, 626, Internal, col, 10737 "rank 1 array", "change_section_to_this_element"); 10738 } 10739 # endif 10740 10741 copy_subtree(section_opnd, element_opnd); 10742 10743 just_find_dope_and_rank(element_opnd, &rank_idx, &unused); 10744 10745 # ifdef _DEBUG 10746 if (rank_idx == NULL_IDX) { 10747 PRINTMSG(line, 626, Internal, col, 10748 "section subscript", "change_section_to_this_element"); 10749 } 10750 # endif 10751 10752 IR_OPR(rank_idx) = Subscript_Opr; 10753 10754 list_idx = IR_IDX_R(rank_idx); 10755 10756 while (list_idx) { 10757 if (IL_VECTOR_SUBSCRIPT(list_idx)) { 10758 COPY_OPND(opnd1, IL_OPND(list_idx)); 10759 change_section_to_this_element(&opnd1, &opnd2, which_one); 10760 COPY_OPND(IL_OPND(list_idx), opnd2); 10761 break; 10762 } 10763 else if (IL_FLD(list_idx) == IR_Tbl_Idx && 10764 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) { 10765 10766 trip_idx = IL_IDX(list_idx); 10767 start_list_idx = IR_IDX_L(trip_idx); 10768 stride_list_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(start_list_idx)); 10769 line = IR_LINE_NUM(trip_idx); 10770 col = IR_COL_NUM(trip_idx); 10771 10772 10773 mult_idx = gen_ir(CN_Tbl_Idx, C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 10774 (which_one - 1)), 10775 Mult_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 10776 IL_FLD(stride_list_idx), IL_IDX(stride_list_idx)); 10777 10778 plus_idx = gen_ir(IL_FLD(start_list_idx), IL_IDX(start_list_idx), 10779 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 10780 IR_Tbl_Idx, mult_idx); 10781 10782 gen_opnd(&opnd1, plus_idx, IR_Tbl_Idx, line, col); 10783 10784 exp_desc = init_exp_desc; 10785 exp_desc.rank = 0; 10786 save_xref_state = xref_state; 10787 xref_state = CIF_No_Usage_Rec; 10788 expr_semantics(&opnd1, &exp_desc); 10789 xref_state = save_xref_state; 10790 10791 COPY_OPND(IL_OPND(list_idx), opnd1); 10792 10793 break; 10794 } 10795 10796 list_idx = IL_NEXT_LIST_IDX(list_idx); 10797 } 10798 10799 COPY_OPND(opnd1, (*element_opnd)); 10800 10801 while (OPND_FLD(opnd1) == IR_Tbl_Idx) { 10802 IR_RANK(OPND_IDX(opnd1)) = 0; 10803 COPY_OPND(opnd1, IR_OPND_L(OPND_IDX(opnd1))); 10804 } 10805 10806 10807 TRACE (Func_Exit, "change_section_to_this_element", NULL); 10808 10809 return; 10810 10811 } /* change_section_to_this_element */ 10812 10813 /******************************************************************************\ 10814 |* *| 10815 |* Description: *| 10816 |* <description> *| 10817 |* *| 10818 |* Input parameters: *| 10819 |* NONE *| 10820 |* *| 10821 |* Output parameters: *| 10822 |* NONE *| 10823 |* *| 10824 |* Returns: *| 10825 |* NOTHING *| 10826 |* *| 10827 \******************************************************************************/ 10828 10829 void gen_if_stmt(opnd_type *cond_opnd, 10830 int true_start_sh_idx, 10831 int true_end_sh_idx, 10832 int false_start_sh_idx, 10833 int false_end_sh_idx, 10834 int line, 10835 int col) 10836 10837 { 10838 int else_idx; 10839 int endif_idx; 10840 int if_idx; 10841 int save_curr_stmt_sh_idx; 10842 int type_idx; 10843 10844 # if defined(_HIGH_LEVEL_IF_FORM) 10845 int if_sh_idx; 10846 int parent_sh_idx; 10847 # else 10848 int label1_idx; 10849 int label2_idx; 10850 # endif 10851 10852 10853 TRACE (Func_Entry, "gen_if_stmt", NULL); 10854 10855 # ifdef _DEBUG 10856 if (SH_PREV_IDX(true_start_sh_idx) == true_end_sh_idx) { 10857 PRINTMSG(line, 626, Internal, col, 10858 "proper true block", "gen_if_stmt"); 10859 } 10860 10861 if (false_start_sh_idx && 10862 SH_PREV_IDX(false_start_sh_idx) != true_end_sh_idx) { 10863 PRINTMSG(line, 626, Internal, col, 10864 "proper false block", "gen_if_stmt"); 10865 } 10866 10867 if (false_start_sh_idx && 10868 SH_PREV_IDX(false_start_sh_idx) == false_end_sh_idx) { 10869 PRINTMSG(line, 626, Internal, col, 10870 "proper false block", "gen_if_stmt"); 10871 } 10872 # endif 10873 10874 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 10875 10876 switch (OPND_FLD((*cond_opnd))) { 10877 case AT_Tbl_Idx: 10878 type_idx = ATD_TYPE_IDX(OPND_IDX((*cond_opnd))); 10879 break; 10880 10881 case IR_Tbl_Idx: 10882 type_idx = IR_TYPE_IDX(OPND_IDX((*cond_opnd))); 10883 break; 10884 10885 case CN_Tbl_Idx: 10886 type_idx = CN_TYPE_IDX(OPND_IDX((*cond_opnd))); 10887 break; 10888 10889 default: 10890 # ifdef _DEBUG 10891 PRINTMSG(line, 626, Internal, col, 10892 "valid logical condition", "gen_if_stmt"); 10893 # endif 10894 break; 10895 } 10896 10897 curr_stmt_sh_idx = true_start_sh_idx; 10898 10899 # if defined(_HIGH_LEVEL_IF_FORM) 10900 10901 if_idx = gen_ir(OPND_FLD((*cond_opnd)), OPND_IDX((*cond_opnd)), 10902 If_Opr, type_idx, line, col, 10903 NO_Tbl_Idx, NULL_IDX); 10904 10905 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 10906 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10907 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx; 10908 10909 if_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 10910 10911 curr_stmt_sh_idx = true_end_sh_idx; 10912 10913 parent_sh_idx = if_sh_idx; 10914 10915 if (false_start_sh_idx) { 10916 10917 curr_stmt_sh_idx = false_start_sh_idx; 10918 10919 else_idx = gen_ir(OPND_FLD((*cond_opnd)), OPND_IDX((*cond_opnd)), 10920 Else_Opr, type_idx, line, col, 10921 NO_Tbl_Idx, NULL_IDX); 10922 10923 gen_sh(Before, Else_Stmt, line, col, FALSE, FALSE, TRUE); 10924 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10925 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = else_idx; 10926 parent_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 10927 10928 curr_stmt_sh_idx = false_end_sh_idx; 10929 10930 } 10931 10932 endif_idx = gen_ir(SH_Tbl_Idx, if_sh_idx, 10933 Endif_Opr, TYPELESS_DEFAULT_TYPE, line, col, 10934 NO_Tbl_Idx, NULL_IDX); 10935 10936 gen_sh(After, End_If_Stmt, line, col, FALSE, FALSE, TRUE); 10937 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10938 SH_IR_IDX(curr_stmt_sh_idx) = endif_idx; 10939 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = parent_sh_idx; 10940 10941 IR_FLD_R(if_idx) = SH_Tbl_Idx; 10942 IR_IDX_R(if_idx) = curr_stmt_sh_idx; 10943 IR_LINE_NUM_R(if_idx) = line; 10944 IR_COL_NUM_R(if_idx) = col; 10945 10946 # else 10947 10948 label1_idx = gen_internal_lbl(line); 10949 10950 if_idx = gen_ir(IR_Tbl_Idx, 10951 gen_ir(OPND_FLD((*cond_opnd)),OPND_IDX((*cond_opnd)), 10952 Not_Opr, type_idx, line, col, 10953 NO_Tbl_Idx, NULL_IDX), 10954 Br_True_Opr, type_idx, line, col, 10955 AT_Tbl_Idx, label1_idx); 10956 10957 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 10958 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx; 10959 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 10960 10961 curr_stmt_sh_idx = true_end_sh_idx; 10962 10963 endif_idx = gen_ir(AT_Tbl_Idx, label1_idx, 10964 Label_Opr, TYPELESS_DEFAULT_TYPE, line, col, 10965 NO_Tbl_Idx, NULL_IDX); 10966 10967 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 10968 SH_IR_IDX(curr_stmt_sh_idx) = endif_idx; 10969 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10970 10971 AT_DEFINED(label1_idx) = TRUE; 10972 ATL_DEF_STMT_IDX(label1_idx) = curr_stmt_sh_idx; 10973 10974 if (false_start_sh_idx) { 10975 curr_stmt_sh_idx = true_end_sh_idx; 10976 10977 label2_idx = gen_internal_lbl(line); 10978 10979 else_idx = gen_ir(NO_Tbl_Idx, NULL_IDX, 10980 Br_Uncond_Opr, type_idx, line, col, 10981 AT_Tbl_Idx, label2_idx); 10982 10983 gen_sh(After, Goto_Stmt, line, col, FALSE, FALSE, TRUE); 10984 SH_IR_IDX(curr_stmt_sh_idx) = else_idx; 10985 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10986 10987 curr_stmt_sh_idx = false_end_sh_idx; 10988 10989 endif_idx = gen_ir(AT_Tbl_Idx, label2_idx, 10990 Label_Opr, TYPELESS_DEFAULT_TYPE, line, col, 10991 NO_Tbl_Idx, NULL_IDX); 10992 10993 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 10994 SH_IR_IDX(curr_stmt_sh_idx) = endif_idx; 10995 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10996 10997 AT_DEFINED(label2_idx) = TRUE; 10998 ATL_DEF_STMT_IDX(label2_idx) = curr_stmt_sh_idx; 10999 } 11000 11001 11002 # endif 11003 11004 11005 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 11006 11007 TRACE (Func_Exit, "gen_if_stmt", NULL); 11008 11009 return; 11010 11011 } /* gen_if_stmt */ 11012 11013 /******************************************************************************\ 11014 |* *| 11015 |* Description: *| 11016 |* <description> *| 11017 |* *| 11018 |* Input parameters: *| 11019 |* NONE *| 11020 |* *| 11021 |* Output parameters: *| 11022 |* NONE *| 11023 |* *| 11024 |* Returns: *| 11025 |* NOTHING *| 11026 |* *| 11027 \******************************************************************************/ 11028 11029 boolean needs_bounds_check(int sub_idx) 11030 11031 { 11032 int base_attr; 11033 int bd_idx; 11034 boolean bound_chk; 11035 int col; 11036 int left_attr; 11037 int line; 11038 11039 TRACE (Func_Entry, "needs_bounds_check", NULL); 11040 11041 # ifdef _DEBUG 11042 if (IR_OPR(sub_idx) != Whole_Subscript_Opr && 11043 IR_OPR(sub_idx) != Section_Subscript_Opr && 11044 IR_OPR(sub_idx) != Subscript_Opr) { 11045 11046 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 11047 "Subscript_Opr", "needs_bounds_check"); 11048 } 11049 # endif 11050 11051 base_attr = find_base_attr(&IR_OPND_L(sub_idx), &line, &col); 11052 left_attr = find_left_attr(&IR_OPND_L(sub_idx)); 11053 bd_idx = ATD_ARRAY_IDX(base_attr); 11054 11055 bound_chk = (cdir_switches.bounds || 11056 ATD_BOUNDS_CHECK(left_attr)) && 11057 !ATD_NOBOUNDS_CHECK(left_attr); 11058 11059 bound_chk &= ! (IR_WHOLE_ARRAY(sub_idx)); 11060 11061 if (IR_BOUNDS_DONE(sub_idx) || 11062 IR_OPR(sub_idx) == Whole_Subscript_Opr || 11063 ATD_CLASS(base_attr) == Compiler_Tmp) { 11064 bound_chk = FALSE; 11065 } 11066 11067 if (BD_RANK(bd_idx) == 1 && 11068 BD_ARRAY_CLASS(bd_idx) == Explicit_Shape && 11069 BD_LB_FLD(bd_idx,1) == CN_Tbl_Idx && 11070 compare_cn_and_value(BD_LB_IDX(bd_idx,1), 1, Eq_Opr) && 11071 BD_UB_FLD(bd_idx,1) == CN_Tbl_Idx && 11072 compare_cn_and_value(BD_UB_IDX(bd_idx,1), 1, Eq_Opr)) { 11073 11074 bound_chk = FALSE; 11075 } 11076 11077 11078 TRACE (Func_Exit, "needs_bounds_check", NULL); 11079 11080 return(bound_chk); 11081 11082 } /* needs_bounds_check */ 11083 11084 /******************************************************************************\ 11085 |* *| 11086 |* Description: *| 11087 |* <description> *| 11088 |* *| 11089 |* Input parameters: *| 11090 |* NONE *| 11091 |* *| 11092 |* Output parameters: *| 11093 |* NONE *| 11094 |* *| 11095 |* Returns: *| 11096 |* NOTHING *| 11097 |* *| 11098 \******************************************************************************/ 11099 11100 void gen_rbounds_condition(opnd_type *cond_opnd, 11101 opnd_type *start_opnd, 11102 opnd_type *end_opnd, 11103 opnd_type *inc_opnd, 11104 opnd_type *lb_opnd, 11105 opnd_type *ub_opnd, 11106 int line, 11107 int col) 11108 11109 { 11110 int and_idx; 11111 int div_idx; 11112 expr_arg_type exp_desc; 11113 int gt_idx; 11114 int lt_idx; 11115 int minus_idx; 11116 int mult_idx; 11117 int or_idx1; 11118 int or_idx2; 11119 int or_idx3; 11120 opnd_type opnd; 11121 int plus_idx; 11122 expr_mode_type save_expr_mode; 11123 cif_usage_code_type save_xref_state; 11124 opnd_type xt_opnd; 11125 11126 11127 TRACE (Func_Entry, "gen_rbounds_condition", NULL); 11128 11129 /* cond_opnd = ((start < lb .or. start > ub) .or. */ 11130 /* (start + (((end - start + inc) / inc) - 1) * inc < lb) .or. */ 11131 /* (start + (((end - start + inc) / inc) - 1) * inc > ub)) .and. */ 11132 /* (((end - start + inc) / inc) > 0) */ 11133 11134 /* start_opnd < lb */ 11135 11136 lt_idx = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)), 11137 Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11138 OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd))); 11139 11140 /* start_opnd > ub */ 11141 11142 gt_idx = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)), 11143 Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11144 OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd))); 11145 11146 11147 11148 or_idx1 = gen_ir(IR_Tbl_Idx, lt_idx, 11149 Or_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11150 IR_Tbl_Idx, gt_idx); 11151 11152 11153 /* start + (((end - start + inc) / inc) - 1) * inc */ 11154 11155 minus_idx = gen_ir(OPND_FLD((*end_opnd)), OPND_IDX((*end_opnd)), 11156 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 11157 OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd))); 11158 11159 plus_idx = gen_ir(IR_Tbl_Idx, minus_idx, 11160 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 11161 OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd))); 11162 11163 div_idx = gen_ir(IR_Tbl_Idx, plus_idx, 11164 Div_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 11165 OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd))); 11166 11167 gen_opnd(&xt_opnd, div_idx, IR_Tbl_Idx, line, col); 11168 copy_subtree(&xt_opnd, &xt_opnd); 11169 11170 minus_idx = gen_ir(IR_Tbl_Idx, div_idx, 11171 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 11172 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 11173 11174 mult_idx = gen_ir(IR_Tbl_Idx, minus_idx, 11175 Mult_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 11176 OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd))); 11177 11178 plus_idx = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)), 11179 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col, 11180 IR_Tbl_Idx, mult_idx); 11181 11182 lt_idx = gen_ir(IR_Tbl_Idx, plus_idx, 11183 Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11184 OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd))); 11185 11186 gen_opnd(&opnd, plus_idx, IR_Tbl_Idx, line, col); 11187 11188 copy_subtree(&opnd, &opnd); 11189 11190 gt_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 11191 Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11192 OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd))); 11193 11194 11195 11196 or_idx2 = gen_ir(IR_Tbl_Idx, lt_idx, 11197 Or_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11198 IR_Tbl_Idx, gt_idx); 11199 11200 11201 or_idx3 = gen_ir(IR_Tbl_Idx, or_idx1, 11202 Or_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11203 IR_Tbl_Idx, or_idx2); 11204 11205 gt_idx = gen_ir(OPND_FLD(xt_opnd), OPND_IDX(xt_opnd), 11206 Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11207 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 11208 11209 and_idx = gen_ir(IR_Tbl_Idx, or_idx3, 11210 And_Opr, LOGICAL_DEFAULT_TYPE, line, col, 11211 IR_Tbl_Idx, gt_idx); 11212 11213 gen_opnd(cond_opnd, and_idx, IR_Tbl_Idx, line, col); 11214 11215 save_xref_state = xref_state; 11216 xref_state = CIF_No_Usage_Rec; 11217 save_expr_mode = expr_mode; 11218 expr_mode = Regular_Expr; 11219 11220 exp_desc = init_exp_desc; 11221 expr_semantics(cond_opnd, &exp_desc); 11222 xref_state = save_xref_state; 11223 expr_mode = save_expr_mode; 11224 11225 TRACE (Func_Exit, "gen_rbounds_condition", NULL); 11226 11227 return; 11228 11229 } /* gen_rbounds_condition */ 11230 11231 /******************************************************************************\ 11232 |* *| 11233 |* Description: *| 11234 |* <description> *| 11235 |* *| 11236 |* Input parameters: *| 11237 |* NONE *| 11238 |* *| 11239 |* Output parameters: *| 11240 |* NONE *| 11241 |* *| 11242 |* Returns: *| 11243 |* NOTHING *| 11244 |* *| 11245 \******************************************************************************/ 11246 11247 void scan_for_ptr_chk(opnd_type *top_opnd) 11248 11249 { 11250 opnd_type dv_opnd; 11251 int ir_idx; 11252 int list_idx; 11253 opnd_type opnd; 11254 11255 TRACE (Func_Entry, "scan_for_ptr_chk", NULL); 11256 11257 switch (OPND_FLD((*top_opnd))) { 11258 case IR_Tbl_Idx: 11259 ir_idx = OPND_IDX((*top_opnd)); 11260 11261 if (IR_OPR(ir_idx) == Dv_Deref_Opr) { 11262 COPY_OPND(dv_opnd, IR_OPND_L(ir_idx)); 11263 gen_runtime_ptr_chk(&dv_opnd); 11264 } 11265 11266 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 11267 scan_for_ptr_chk(&opnd); 11268 11269 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 11270 scan_for_ptr_chk(&opnd); 11271 break; 11272 11273 case IL_Tbl_Idx: 11274 list_idx = OPND_IDX((*top_opnd)); 11275 11276 while (list_idx) { 11277 COPY_OPND(opnd, IL_OPND(list_idx)); 11278 scan_for_ptr_chk(&opnd); 11279 list_idx = IL_NEXT_LIST_IDX(list_idx); 11280 } 11281 break; 11282 } 11283 11284 TRACE (Func_Exit, "scan_for_ptr_chk", NULL); 11285 11286 return; 11287 11288 } /* scan_for_ptr_chk */ 11289 11290 /******************************************************************************\ 11291 |* *| 11292 |* Description: *| 11293 |* <description> *| 11294 |* *| 11295 |* Input parameters: *| 11296 |* NONE *| 11297 |* *| 11298 |* Output parameters: *| 11299 |* NONE *| 11300 |* *| 11301 |* Returns: *| 11302 |* NOTHING *| 11303 |* *| 11304 \******************************************************************************/ 11305 11306 void runtime_ptr_chk_driver(void) 11307 11308 { 11309 opnd_type opnd; 11310 int save_curr_stmt_sh_idx; 11311 11312 TRACE (Func_Entry, "runtime_ptr_chk_driver", NULL); 11313 11314 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 11315 11316 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 11317 11318 while (curr_stmt_sh_idx != NULL_IDX) { 11319 11320 if (SH_IR_IDX(curr_stmt_sh_idx) != NULL_IDX) { 11321 gen_opnd(&opnd, SH_IR_IDX(curr_stmt_sh_idx), IR_Tbl_Idx, 11322 SH_GLB_LINE(curr_stmt_sh_idx), SH_COL_NUM(curr_stmt_sh_idx)); 11323 scan_for_ptr_chk(&opnd); 11324 } 11325 11326 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 11327 } 11328 11329 PRINT_IR_TBL4; 11330 11331 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 11332 11333 TRACE (Func_Exit, "runtime_ptr_chk_driver", NULL); 11334 11335 return; 11336 11337 } /* runtime_ptr_chk_driver */ 11338 11339 /******************************************************************************\ 11340 |* *| 11341 |* Description: *| 11342 |* <description> *| 11343 |* *| 11344 |* Input parameters: *| 11345 |* NONE *| 11346 |* *| 11347 |* Output parameters: *| 11348 |* NONE *| 11349 |* *| 11350 |* Returns: *| 11351 |* NOTHING *| 11352 |* *| 11353 \******************************************************************************/ 11354 11355 void gen_copyin_bounds_stmt(int attr_idx) 11356 11357 { 11358 # if defined(GENERATE_WHIRL) 11359 int col; 11360 int ir_idx; 11361 int line; 11362 11363 TRACE (Func_Entry, "gen_copyin_bounds_stmt", NULL); 11364 11365 line = AT_DEF_LINE(attr_idx); 11366 col = AT_DEF_COLUMN(attr_idx); 11367 11368 ir_idx = gen_ir(AT_Tbl_Idx, attr_idx, 11369 Copyin_Bound_Opr, TYPELESS_DEFAULT_TYPE, line, col, 11370 NO_Tbl_Idx, NULL_IDX); 11371 11372 gen_sh(Before, Directive_Stmt, line, col, FALSE, FALSE, TRUE); 11373 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 11374 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 11375 11376 TRACE (Func_Exit, "gen_copyin_bounds_stmt", NULL); 11377 11378 # endif 11379 return; 11380 11381 } /* gen_copyin_bounds_stmt */ 11382 11383 /******************************************************************************\ 11384 |* *| 11385 |* Description: *| 11386 |* <description> *| 11387 |* *| 11388 |* Input parameters: *| 11389 |* NONE *| 11390 |* *| 11391 |* Output parameters: *| 11392 |* NONE *| 11393 |* *| 11394 |* Returns: *| 11395 |* NOTHING *| 11396 |* *| 11397 \******************************************************************************/ 11398 11399 void gen_dv_access_low_bound(opnd_type *result_opnd, 11400 opnd_type *dv_opnd, 11401 int dim) 11402 11403 { 11404 int attr_idx; 11405 int bd_idx; 11406 int col; 11407 expr_arg_type exp_desc; 11408 int ir_idx; 11409 int line; 11410 cif_usage_code_type save_xref_state; 11411 11412 11413 TRACE (Func_Entry, "gen_dv_access_low_bound", NULL); 11414 11415 attr_idx = find_base_attr(dv_opnd, &line, &col); 11416 11417 # ifdef _DEBUG 11418 if (! ATD_IM_A_DOPE(attr_idx)) { 11419 PRINTMSG(line, 626, Internal, col, 11420 "dope vector" , "gen_dv_low_bound"); 11421 } 11422 # endif 11423 11424 bd_idx = ATD_ARRAY_IDX(attr_idx); 11425 11426 if (bd_idx && 11427 BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) { 11428 11429 gen_opnd(result_opnd, BD_LB_IDX(bd_idx,dim), BD_LB_FLD(bd_idx,dim), 11430 line, col); 11431 11432 if (variable_size_func_expr && 11433 OPND_FLD((*result_opnd)) == AT_Tbl_Idx && 11434 ATD_CLASS(OPND_IDX((*result_opnd))) == Compiler_Tmp && 11435 ATD_FLD(OPND_IDX((*result_opnd))) == IR_Tbl_Idx && 11436 IR_OPR(ATD_TMP_IDX(OPND_IDX((*result_opnd)))) == Asg_Opr) { 11437 11438 while (OPND_FLD((*result_opnd)) == AT_Tbl_Idx && 11439 ATD_CLASS(OPND_IDX((*result_opnd))) == Compiler_Tmp && 11440 ATD_FLD(OPND_IDX((*result_opnd))) == IR_Tbl_Idx && 11441 IR_OPR(ATD_TMP_IDX(OPND_IDX((*result_opnd)))) == Asg_Opr) { 11442 11443 COPY_OPND((*result_opnd), 11444 IR_OPND_R(ATD_TMP_IDX(OPND_IDX((*result_opnd))))); 11445 } 11446 11447 exp_desc.rank = 0; 11448 11449 save_xref_state = xref_state; 11450 xref_state = CIF_No_Usage_Rec; 11451 expr_semantics(result_opnd, &exp_desc); 11452 xref_state = save_xref_state; 11453 } 11454 } 11455 else { 11456 ir_idx = gen_ir(OPND_FLD((*dv_opnd)), OPND_IDX((*dv_opnd)), 11457 Dv_Access_Low_Bound, SA_INTEGER_DEFAULT_TYPE, line, col, 11458 NO_Tbl_Idx, NULL_IDX); 11459 IR_DV_DIM(ir_idx) = dim; 11460 11461 gen_opnd(result_opnd, ir_idx, IR_Tbl_Idx, line, col); 11462 } 11463 11464 TRACE (Func_Exit, "gen_dv_access_low_bound", NULL); 11465 11466 return; 11467 11468 } /* gen_dv_access_low_bound */ 11469 11470 /******************************************************************************\ 11471 |* *| 11472 |* Description: *| 11473 |* <description> *| 11474 |* *| 11475 |* Input parameters: *| 11476 |* NONE *| 11477 |* *| 11478 |* Output parameters: *| 11479 |* NONE *| 11480 |* *| 11481 |* Returns: *| 11482 |* NOTHING *| 11483 |* *| 11484 \******************************************************************************/ 11485 11486 long64 sm_unit_in_bits(int type_idx) 11487 11488 { 11489 long64 bits; 11490 11491 11492 TRACE (Func_Entry, "sm_unit_in_bits", NULL); 11493 11494 # if defined(_SM_UNIT_IS_ELEMENT) 11495 11496 switch (TYP_TYPE(type_idx)) { 11497 case Typeless: 11498 bits = TYP_BIT_LEN(type_idx); 11499 break; 11500 11501 case Integer: 11502 case Logical: 11503 case CRI_Ptr: 11504 case CRI_Ch_Ptr: 11505 case Real: 11506 case Complex: 11507 bits = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 11508 break; 11509 11510 case Character: 11511 11512 # ifdef _DEBUG 11513 if (TYP_FLD(type_idx) != CN_Tbl_Idx) { 11514 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 11515 "constant length character", "sm_unit_in_bits"); 11516 } 11517 # endif 11518 bits = CN_INT_TO_C(TYP_IDX(type_idx)) * 8; 11519 break; 11520 11521 case Structure: 11522 # ifdef _DEBUG 11523 if (ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)) != CN_Tbl_Idx) { 11524 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 11525 "constant length structure", "sm_unit_in_bits"); 11526 } 11527 # endif 11528 bits = CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))); 11529 break; 11530 } 11531 11532 # else 11533 11534 bits = stride_mult_unit_in_bits[TYP_LINEAR(type_idx)]; 11535 11536 # endif 11537 11538 TRACE (Func_Exit, "sm_unit_in_bits", NULL); 11539 11540 return(bits); 11541 11542 } /* sm_unit_in_bits */ 11543 11544 /******************************************************************************\ 11545 |* *| 11546 |* Description: *| 11547 |* Generate a data init or assignment stmt to initialize a temp to a *| 11548 |* constant value. If it is an assignment, generate it a every entry. *| 11549 |* *| 11550 |* Input parameters: *| 11551 |* NONE *| 11552 |* *| 11553 |* Output parameters: *| 11554 |* NONE *| 11555 |* *| 11556 |* Returns: *| 11557 |* NOTHING *| 11558 |* *| 11559 \******************************************************************************/ 11560 11561 void gen_temp_init(int attr_idx, 11562 int cn_idx) 11563 11564 { 11565 int col; 11566 int entry_attr_idx; 11567 int entry_list_idx; 11568 int entry_sh_idx; 11569 int ir_idx; 11570 int line; 11571 opnd_type opnd; 11572 int sh_idx; 11573 int type_idx; 11574 11575 TRACE (Func_Entry, "gen_temp_init", NULL); 11576 11577 type_idx = ATD_TYPE_IDX(attr_idx); 11578 line = AT_DEF_LINE(attr_idx); 11579 col = AT_DEF_COLUMN(attr_idx); 11580 11581 if (SB_RUNTIME_INIT(ATD_STOR_BLK_IDX(attr_idx))) { 11582 11583 /* The var is on the stack, or is automatic, a darg or a func */ 11584 /* result. Generate runtime code for the initialization. */ 11585 11586 ir_idx = gen_ir(AT_Tbl_Idx, attr_idx, 11587 Asg_Opr, type_idx, line, col, 11588 CN_Tbl_Idx, cn_idx); 11589 11590 gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, line, col); 11591 11592 sh_idx = ntr_sh_tbl(); 11593 SH_STMT_TYPE(sh_idx) = Assignment_Stmt; 11594 SH_GLB_LINE(sh_idx) = line; 11595 SH_COL_NUM(sh_idx) = col; 11596 SH_COMPILER_GEN(sh_idx) = TRUE; 11597 SH_P2_SKIP_ME(sh_idx) = TRUE; 11598 11599 SH_IR_IDX(sh_idx) = ir_idx; 11600 11601 insert_sh_chain_after_entries(sh_idx, sh_idx); 11602 } 11603 else { 11604 ir_idx = gen_ir(AT_Tbl_Idx, attr_idx, 11605 Init_Opr, TYPELESS_DEFAULT_TYPE, line, col, 11606 IL_Tbl_Idx, gen_il(3, 11607 FALSE, 11608 line, 11609 col, 11610 CN_Tbl_Idx, 11611 cn_idx, 11612 CN_Tbl_Idx, 11613 CN_INTEGER_ONE_IDX, 11614 CN_Tbl_Idx, 11615 CN_INTEGER_ZERO_IDX)); 11616 11617 gen_sh(After, 11618 Type_Init_Stmt, 11619 line, 11620 col, 11621 FALSE, 11622 FALSE, 11623 TRUE); 11624 11625 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 11626 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 11627 11628 } 11629 11630 11631 TRACE (Func_Exit, "gen_temp_init", NULL); 11632 11633 return; 11634 11635 } /* gen_temp_init */
1.7.6.1 
