|
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_dcls.c 5.7 09/29/99 17:38:13\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 00046 # include "globals.m" 00047 # include "tokens.m" 00048 # include "sytb.m" 00049 # include "s_globals.m" 00050 # include "debug.m" 00051 00052 # include "globals.h" 00053 # include "tokens.h" 00054 # include "sytb.h" 00055 # include "s_globals.h" 00056 00057 00058 /*********************************************************\ 00059 |* Globals used between decl_semantics and attr_semantics | 00060 \*********************************************************/ 00061 00062 int allocatable_list_idx; 00063 int alt_entry_equiv_blk; 00064 int alt_entry_equiv_grp; 00065 int init_sh_start_idx; 00066 int init_sh_end_idx; 00067 int namelist_list_idx; 00068 int number_of_allocatables; 00069 int pointee_based_blk; 00070 int reshape_array_list; 00071 00072 00073 /*****************************************************************\ 00074 |* Function prototypes of static functions declared in this file *| 00075 \*****************************************************************/ 00076 00077 static void assign_offsets_for_equiv_groups(void); 00078 static void attr_semantics(int, boolean); 00079 static void bound_resolution(int); 00080 static boolean compare_darg_or_rslt_types(int, int); 00081 static void compare_duplicate_interface_bodies(int); 00082 static void compare_entry_to_func_rslt(int, int); 00083 static boolean darg_in_entry_list(int, int); 00084 static void deallocate_local_allocatables(void); 00085 static void distribution_resolution(int); 00086 static void equivalence_semantics(void); 00087 static void gen_assumed_shape_copy(opnd_type *); 00088 static int gen_auto_length(int, opnd_type *); 00089 static void gen_branch_around_ir(int, int, int); 00090 static int gen_darg_branch_test(int); 00091 static boolean gen_ir_at_this_entry(int, int); 00092 static void gen_present_ir(int, int, int); 00093 static void gen_single_automatic_allocate(int); 00094 static void gen_tmp_eq_zero_ir(int); 00095 static void insert_argchck_calls(int, int); 00096 static void insert_sh_after_entries(int, int, int, boolean, boolean); 00097 static void linearize_list_for_equiv(int); 00098 static int merge_entry_lists(int, int); 00099 static int merge_entry_list_count(int, int); 00100 static void merge_equivalence_groups1(void); 00101 static void merge_equivalence_groups2(void); 00102 static boolean must_reassign_XT_temp(opnd_type *); 00103 static void namelist_resolution(int); 00104 static int ntr_bnds_sh_tmp_list(opnd_type *, int, int, boolean, int); 00105 static void reshape_array_semantics(void); 00106 static void tmp_il_resolution(int); 00107 static void tmp_ir_resolution(int); 00108 static void verify_interface (int); 00109 static void gen_allocatable_ptr_ptee(int); 00110 static int set_up_bd_tmps(int, int, int, int, boolean); 00111 00112 # if defined(_TARGET_WORD_ADDRESS) || \ 00113 (defined(_HEAP_REQUEST_IN_WORDS) && defined(_TARGET_BYTE_ADDRESS)) 00114 static void gen_word_align_byte_length_ir(opnd_type *); 00115 # endif 00116 00117 # if !defined(_SINGLE_ALLOCS_FOR_AUTOMATIC) 00118 static void gen_multiple_automatic_allocate(int); 00119 # endif 00120 00121 # if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) 00122 # pragma inline create_equiv_stor_blk 00123 # else 00124 # pragma _CRI inline create_equiv_stor_blk 00125 # endif 00126 00127 00128 /******************************************************************************\ 00129 |* *| 00130 |* Description: *| 00131 |* Perform semantic checks for EQUIVALENCE statements. *| 00132 |* *| 00133 |* Input parameters: *| 00134 |* NONE *| 00135 |* *| 00136 |* Output parameters: *| 00137 |* NONE *| 00138 |* *| 00139 |* Returns: *| 00140 |* NONE *| 00141 |* *| 00142 \******************************************************************************/ 00143 static void equivalence_semantics(void) 00144 { 00145 00146 int attr_idx; 00147 boolean automatic; 00148 int common_attr_idx; 00149 int common_sb_idx; 00150 boolean default_numeric_sequence; 00151 boolean default_numeric_type; 00152 boolean default_character_sequence; 00153 boolean default_character_type; 00154 int group; 00155 int il_idx; 00156 int ir_idx; 00157 boolean is_volatile; 00158 int item; 00159 int list_idx; 00160 int new_idx; 00161 int nondefault_sequence_type; 00162 int nondefault_intrinsic_type; 00163 int offset_idx; 00164 boolean ok; 00165 opnd_type opnd; 00166 expr_arg_type opnd_desc; 00167 long_type result[MAX_WORDS_FOR_INTEGER]; 00168 cif_usage_code_type save_xref_state; 00169 int sb_idx; 00170 int subscript_count; 00171 int substring_list; 00172 int type_idx; 00173 00174 00175 TRACE (Func_Entry, "equivalence_semantics", NULL); 00176 00177 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 00178 00179 while (group != NULL_IDX) { 00180 item = group; 00181 common_attr_idx = NULL_IDX; 00182 common_sb_idx = NULL_IDX; 00183 00184 while (item != NULL_IDX) { 00185 00186 if (ATD_IN_COMMON(EQ_ATTR_IDX(item))) { 00187 00188 if (common_sb_idx == NULL_IDX) { 00189 common_attr_idx = EQ_ATTR_IDX(item); 00190 common_sb_idx = ATD_STOR_BLK_IDX(common_attr_idx); 00191 } 00192 else if (common_sb_idx != ATD_STOR_BLK_IDX(common_attr_idx)) { 00193 00194 /* Two different items from the same common */ 00195 /* block are equivalenced together. */ 00196 00197 PRINTMSG(EQ_LINE_NUM(item), 826, Error, EQ_COLUMN_NUM(item), 00198 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00199 AT_OBJ_NAME_PTR(common_attr_idx)); 00200 } 00201 00202 if (SB_BLK_HAS_NPES(common_sb_idx)) { 00203 PRINTMSG(EQ_LINE_NUM(item), 1228, Error, EQ_COLUMN_NUM(item), 00204 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00205 SB_BLANK_COMMON(common_sb_idx) ? 00206 "" : SB_NAME_PTR(common_sb_idx)); 00207 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 00208 } 00209 00210 # if 0 00211 if (SB_ALIGN_SYMBOL(common_sb_idx) || 00212 SB_FILL_SYMBOL(common_sb_idx)) { 00213 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 00214 PRINTMSG(EQ_LINE_NUM(item), 1488, Error, EQ_COLUMN_NUM(item), 00215 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00216 SB_NAME_PTR(common_sb_idx), 00217 SB_ALIGN_SYMBOL(common_sb_idx) ? "ALIGN_SYMBOL" : 00218 "FILL_SYMBOL"); 00219 } 00220 # endif 00221 } 00222 # if 0 00223 else if (SB_MODULE(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))) && 00224 (SB_ALIGN_SYMBOL(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))) || 00225 SB_FILL_SYMBOL(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))))) { 00226 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 00227 PRINTMSG(EQ_LINE_NUM(item), 1489, Error, EQ_COLUMN_NUM(item), 00228 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00229 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)), 00230 SB_ALIGN_SYMBOL(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))) ? 00231 "ALIGN_SYMBOL" : "FILL_SYMBOL"); 00232 } 00233 # endif 00234 00235 if (EQ_OPND_FLD(item) == NO_Tbl_Idx) { 00236 00237 /* if stand alone name, then offset is set to 0 */ 00238 00239 NTR_IR_LIST_TBL(new_idx); 00240 EQ_LIST_IDX(item) = new_idx; 00241 IL_FLD(new_idx) = CN_Tbl_Idx; 00242 IL_IDX(new_idx) = CN_INTEGER_ZERO_IDX; 00243 IL_LINE_NUM(new_idx) = 1; 00244 IL_COL_NUM(new_idx) = 0; 00245 } 00246 else if ((!EQ_SUBSTRINGED(item) && 00247 ATD_ARRAY_IDX(EQ_ATTR_IDX(item)) == NULL_IDX) || 00248 (EQ_SUBSTRINGED(item) && 00249 TYP_TYPE(ATD_TYPE_IDX(EQ_ATTR_IDX(item))) != Character)) { 00250 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 00251 PRINTMSG(EQ_LINE_NUM(item), 840, Error, 00252 EQ_COLUMN_NUM(item), 00253 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00254 NTR_IR_LIST_TBL(new_idx); 00255 EQ_LIST_IDX(item) = new_idx; 00256 IL_FLD(new_idx) = CN_Tbl_Idx; 00257 IL_IDX(new_idx) = CN_INTEGER_ZERO_IDX; 00258 IL_LINE_NUM(new_idx) = 1; 00259 IL_COL_NUM(new_idx) = 0; 00260 } 00261 else { 00262 00263 /* this is true only if something follows the object */ 00264 /* that is a subscript and or substring */ 00265 00266 OPND_FLD(opnd) = EQ_OPND_FLD(item); 00267 OPND_IDX(opnd) = EQ_OPND_IDX(item); 00268 OPND_LINE_NUM(opnd) = EQ_LINE_NUM(item); 00269 OPND_COL_NUM(opnd) = EQ_COLUMN_NUM(item); 00270 opnd_desc.rank = 0; 00271 expr_mode = Initialization_Expr; 00272 save_xref_state = xref_state; 00273 xref_state = CIF_Symbol_Reference; 00274 attr_idx = find_left_attr(&opnd); 00275 ATD_PARENT_OBJECT(attr_idx) = TRUE; 00276 ok = expr_semantics(&opnd, &opnd_desc); 00277 xref_state = save_xref_state; 00278 expr_mode = Regular_Expr; 00279 ATD_PARENT_OBJECT(attr_idx) = FALSE; 00280 00281 if (!ok) { 00282 EQ_LIST_IDX(item)= NULL_IDX; 00283 EQ_ERROR(item) = TRUE; 00284 item = EQ_NEXT_EQUIV_OBJ(item); 00285 continue; 00286 } 00287 00288 /* Break the subscripts and substrings up. */ 00289 00290 subscript_count = 0; 00291 substring_list = NULL_IDX; 00292 00293 ir_idx = (OPND_FLD(opnd) == IR_Tbl_Idx) ? OPND_IDX(opnd): NULL_IDX; 00294 00295 if (ir_idx != NULL_IDX && 00296 (IR_OPR(ir_idx) == Substring_Opr || 00297 IR_OPR(ir_idx) == Whole_Substring_Opr)) { 00298 EQ_SUBSTRINGED(item) = TRUE; 00299 substring_list = IR_IDX_R(ir_idx); 00300 ir_idx = (IR_FLD_L(ir_idx) == IR_Tbl_Idx) ? IR_IDX_L(ir_idx) : 00301 NULL_IDX; 00302 } 00303 00304 if (ir_idx != NULL_IDX && 00305 IR_OPR(ir_idx) == Whole_Subscript_Opr) { 00306 ir_idx = (IR_FLD_L(ir_idx) == IR_Tbl_Idx) ? IR_IDX_L(ir_idx) : 00307 NULL_IDX; 00308 } 00309 00310 if (ir_idx != NULL_IDX && 00311 (IR_OPR(ir_idx) == Section_Subscript_Opr || 00312 IR_OPR(ir_idx) == Struct_Opr)) { 00313 00314 if (IR_OPR(ir_idx) == Section_Subscript_Opr) { 00315 PRINTMSG(EQ_LINE_NUM(item), 250, Error, EQ_COLUMN_NUM(item)); 00316 } 00317 else { 00318 PRINTMSG(EQ_LINE_NUM(item), 1537, Error, EQ_COLUMN_NUM(item)); 00319 } 00320 00321 00322 EQ_LIST_IDX(item) = NULL_IDX; 00323 EQ_ERROR(item) = TRUE; 00324 item = EQ_NEXT_EQUIV_OBJ(item); 00325 continue; 00326 } 00327 00328 if (ir_idx != NULL_IDX && 00329 (IR_OPR(ir_idx) == Subscript_Opr || 00330 IR_OPR(ir_idx) == Whole_Subscript_Opr || 00331 IR_OPR(ir_idx) == Section_Subscript_Opr)) { 00332 subscript_count = IR_LIST_CNT_R(ir_idx); 00333 EQ_LIST_IDX(item) = IR_IDX_R(ir_idx); 00334 } 00335 00336 if (substring_list != NULL_IDX) { /* Add the substring list */ 00337 00338 if (EQ_LIST_IDX(item) == NULL_IDX) { 00339 EQ_LIST_IDX(item) = substring_list; 00340 } 00341 else { 00342 il_idx = EQ_LIST_IDX(item); 00343 00344 while (IL_NEXT_LIST_IDX(il_idx) != NULL_IDX) { 00345 il_idx = IL_NEXT_LIST_IDX(il_idx); 00346 } 00347 IL_NEXT_LIST_IDX(il_idx) = substring_list; 00348 } 00349 00350 il_idx = IL_NEXT_LIST_IDX(substring_list); /* End substring*/ 00351 il_idx = IL_NEXT_LIST_IDX(il_idx); 00352 00353 /* il_idx is now the character length in the substring. */ 00354 /* This is not needed, but a NULL entry is, so clear it. */ 00355 /* But check for a zero length substring first. */ 00356 00357 if (IL_FLD(il_idx) == CN_Tbl_Idx) { 00358 type_idx = CG_LOGICAL_DEFAULT_TYPE; 00359 00360 folder_driver((char *) &CN_CONST(IL_IDX(il_idx)), 00361 CN_TYPE_IDX(IL_IDX(il_idx)), 00362 (char *) &CN_CONST(CN_INTEGER_ZERO_IDX), 00363 CN_TYPE_IDX(CN_INTEGER_ZERO_IDX), 00364 result, 00365 &type_idx, 00366 EQ_LINE_NUM(item), 00367 EQ_COLUMN_NUM(item), 00368 2, 00369 Le_Opr); 00370 00371 if (THIS_IS_TRUE(result, type_idx)) { 00372 PRINTMSG(EQ_LINE_NUM(item), 1627,Error,EQ_COLUMN_NUM(item)); 00373 } 00374 } 00375 IL_OPND(il_idx) = null_opnd; 00376 } 00377 else if (EQ_LIST_IDX(item) != NULL_IDX) { 00378 00379 /* Just have subscripts. Find end of list and add NULL */ 00380 00381 il_idx = EQ_LIST_IDX(item); 00382 00383 while (IL_NEXT_LIST_IDX(il_idx) != NULL_IDX) { 00384 il_idx = IL_NEXT_LIST_IDX(il_idx); 00385 } 00386 NTR_IR_LIST_TBL(new_idx); 00387 IL_NEXT_LIST_IDX(il_idx) = new_idx; 00388 IL_OPND(new_idx) = null_opnd; 00389 IL_LINE_NUM(new_idx) = EQ_LINE_NUM(item); 00390 IL_COL_NUM(new_idx) = EQ_COLUMN_NUM(item); 00391 } 00392 00393 EQ_OPND_FLD(item) = NO_Tbl_Idx; 00394 EQ_OPND_IDX(item) = NULL_IDX; 00395 00396 if (ATD_ARRAY_IDX(EQ_ATTR_IDX(item)) > 0) { 00397 00398 if (! dump_flags.no_dimension_padding && 00399 subscript_count < BD_RANK(ATD_ARRAY_IDX(EQ_ATTR_IDX(item)))){ 00400 PRINTMSG(EQ_LINE_NUM(item), 375, Warning, 00401 EQ_COLUMN_NUM(item)); 00402 } 00403 else if (subscript_count > 00404 BD_RANK(ATD_ARRAY_IDX(EQ_ATTR_IDX(item)))) { 00405 PRINTMSG(EQ_LINE_NUM(item), 204, Error, 00406 EQ_COLUMN_NUM(item)); 00407 00408 /* Do not want to call linearize_list_for_equiv because the */ 00409 /* rank of the array is less than the number of dimension. */ 00410 00411 item = EQ_NEXT_EQUIV_OBJ(item); 00412 continue; 00413 } 00414 } 00415 00416 linearize_list_for_equiv(item); 00417 } 00418 00419 item = EQ_NEXT_EQUIV_OBJ(item); 00420 } 00421 group = EQ_NEXT_EQUIV_GRP(group); 00422 } 00423 00424 merge_equivalence_groups1(); 00425 00426 assign_offsets_for_equiv_groups(); 00427 00428 merge_equivalence_groups2(); 00429 00430 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 00431 00432 while (group != NULL_IDX) { 00433 item = group; 00434 sb_idx = NULL_IDX; 00435 automatic = FALSE; 00436 is_volatile = FALSE; 00437 00438 while (item != NULL_IDX) { 00439 00440 if (EQ_ERROR(item)) { 00441 item = EQ_NEXT_EQUIV_OBJ(item); 00442 continue; 00443 } 00444 00445 attr_idx = EQ_ATTR_IDX(item); 00446 00447 if (!EQ_SEARCH_DONE(item) && 00448 (ATD_CLASS(EQ_ATTR_IDX(item)) == Variable && 00449 ATD_EQUIV_LIST(EQ_ATTR_IDX(item)) != NULL_IDX)) { 00450 00451 /* This attr is in this equivalence group more than once. */ 00452 /* All these items need to have the same offset. We make */ 00453 /* the assumption that the constant table shares entries, */ 00454 /* so all these offset indexes should be the same. If */ 00455 /* they are not, issue an error. */ 00456 00457 list_idx = ATD_EQUIV_LIST(EQ_ATTR_IDX(item)); 00458 offset_idx = EQ_OFFSET_IDX(item); 00459 EQ_SEARCH_DONE(item) = TRUE; 00460 00461 while (list_idx != NULL_IDX) { 00462 00463 if (fold_relationals(EQ_OFFSET_IDX(AL_EQ_IDX(list_idx)), 00464 offset_idx, 00465 Ne_Opr)) { 00466 00467 PRINTMSG(EQ_LINE_NUM(item), 528, Error, 00468 EQ_COLUMN_NUM(item), 00469 AT_OBJ_NAME_PTR(attr_idx)); 00470 } 00471 00472 list_idx = AL_NEXT_IDX(list_idx); 00473 } 00474 } 00475 00476 if (sb_idx != NULL_IDX && sb_idx != ATD_STOR_BLK_IDX(attr_idx) && 00477 SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)) && 00478 SB_IS_COMMON(sb_idx)) { 00479 PRINTMSG(EQ_LINE_NUM(item), 823, Error, 00480 EQ_COLUMN_NUM(item), 00481 SB_BLANK_COMMON(sb_idx) ? 00482 "" : SB_NAME_PTR(sb_idx), 00483 SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx)) ? 00484 "" : SB_NAME_PTR(ATD_STOR_BLK_IDX(attr_idx))); 00485 } 00486 00487 automatic |= ATD_STACK(attr_idx); 00488 is_volatile |= ATD_VOLATILE(attr_idx); 00489 00490 /* if item is in a common block move all items to that block */ 00491 00492 if (SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx))) { 00493 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 00494 00495 /* If any item is in a common block and dalign is not */ 00496 /* specified on the commandline, none of the items in */ 00497 /* the equivalence group can be double aligned. */ 00498 00499 EQ_DO_NOT_DALIGN(group) = !cmd_line_flags.dalign; 00500 } 00501 else if (SB_HOSTED_STATIC(ATD_STOR_BLK_IDX(attr_idx))) { 00502 00503 if (sb_idx == NULL_IDX || !SB_IS_COMMON(sb_idx)) { 00504 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 00505 } 00506 } 00507 else if (SB_HOSTED_STACK(ATD_STOR_BLK_IDX(attr_idx))) { 00508 00509 if (sb_idx == NULL_IDX || 00510 (!SB_IS_COMMON(sb_idx) && !SB_HOSTED_STATIC(sb_idx))) { 00511 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 00512 } 00513 } 00514 else if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Static || 00515 SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Static_Named || 00516 SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Static_Local) { 00517 00518 if (sb_idx == NULL_IDX) { 00519 00520 /* if no storage block yet and item is in @DATA */ 00521 /* move all items to @DATA */ 00522 00523 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 00524 } 00525 } 00526 00527 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 00528 !cmd_line_flags.dalign && 00529 ATT_DCL_NUMERIC_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) { 00530 EQ_DO_NOT_DALIGN(group) = TRUE; 00531 } 00532 00533 item = EQ_NEXT_EQUIV_OBJ(item); 00534 } 00535 00536 if (sb_idx == NULL_IDX) { 00537 sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group), Stack); 00538 } 00539 00540 # if defined(_SEPARATE_NONCOMMON_EQUIV_GROUPS) 00541 00542 else if (SB_HOSTED_STATIC(sb_idx)) { 00543 sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group), Static); 00544 SB_HOSTED_STATIC(sb_idx) = TRUE; 00545 } 00546 else if (SB_HOSTED_STACK(sb_idx)) { 00547 sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group), Stack); 00548 SB_HOSTED_STACK(sb_idx) = TRUE; 00549 } 00550 else if ((SB_BLK_TYPE(sb_idx) == Static || 00551 SB_BLK_TYPE(sb_idx) == Static_Named || 00552 SB_BLK_TYPE(sb_idx) == Static_Local) && 00553 !SB_MODULE(sb_idx)) { 00554 sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group),SB_BLK_TYPE(sb_idx)); 00555 } 00556 # endif 00557 00558 SB_EQUIVALENCED(sb_idx) = TRUE; 00559 00560 if (SB_PAD_BLK(sb_idx) && !SB_IS_COMMON(sb_idx)) { 00561 PRINTMSG(EQ_LINE_NUM(group), 1352, Warning, EQ_COLUMN_NUM(group)); 00562 } 00563 00564 item = group; 00565 default_numeric_sequence = FALSE; 00566 default_numeric_type = FALSE; 00567 default_character_sequence = FALSE; 00568 default_character_type = FALSE; 00569 nondefault_sequence_type = NULL_IDX; 00570 nondefault_intrinsic_type = NULL_IDX; 00571 00572 /* An item in an equivalence group can be one of 6 type categories */ 00573 /* according to the standard. The standard only allows mixing of */ 00574 /* certain categories and Cray allows a few extra extensions. */ 00575 00576 /* The categories are: */ 00577 /* default_numeric_sequence -> A derived type whose components */ 00578 /* are all default numeric types. */ 00579 /* default_numeric_type -> The type must be a default */ 00580 /* numeric type. (Not character, */ 00581 /* derived type, or CRI pointer.) */ 00582 /* default_character_sequence -> A derived type whose components */ 00583 /* are all default character types.*/ 00584 /* default_character_type -> The type is default character. */ 00585 /* nondefault_sequence_type -> A derived type with mixed */ 00586 /* components, both numeric and */ 00587 /* character or non-default numeric*/ 00588 /* nondefault_intrinsic_type -> The type is not a default type. */ 00589 00590 00591 while (item != NULL_IDX) { 00592 00593 if (EQ_ERROR(item)) { 00594 item = EQ_NEXT_EQUIV_OBJ(item); 00595 continue; 00596 } 00597 00598 ATD_VOLATILE(EQ_ATTR_IDX(item)) = is_volatile; 00599 00600 if (SB_IS_COMMON(sb_idx)) { 00601 00602 if (ATD_SAVED(EQ_ATTR_IDX(item))) { 00603 00604 /* An object with the SAVE attribute may not be */ 00605 /* equivalenced to an object in a common block. */ 00606 00607 PRINTMSG(EQ_LINE_NUM(item), 1256, Error, EQ_COLUMN_NUM(item), 00608 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00609 "SAVE"); 00610 } 00611 00612 if (ATD_STACK(EQ_ATTR_IDX(item))) { 00613 00614 /* An object with the AUTOMATIC attribute may not be */ 00615 /* equivalenced to an object in a common block. */ 00616 00617 PRINTMSG(EQ_LINE_NUM(item), 1256, Error, EQ_COLUMN_NUM(item), 00618 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00619 "AUTOMATIC"); 00620 } 00621 00622 if (TYP_TYPE(ATD_TYPE_IDX(EQ_ATTR_IDX(item))) == Structure && 00623 ATT_DEFAULT_INITIALIZED(TYP_IDX( 00624 ATD_TYPE_IDX(EQ_ATTR_IDX(item))))) { 00625 PRINTMSG(EQ_LINE_NUM(item), 1591, Error, EQ_COLUMN_NUM(item), 00626 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00627 AT_OBJ_NAME_PTR(TYP_IDX( 00628 ATD_TYPE_IDX(EQ_ATTR_IDX(item))))); 00629 } 00630 } 00631 else if (automatic && !ATD_STACK(EQ_ATTR_IDX(item))) { 00632 00633 /* All must have the automatic attribute. */ 00634 00635 PRINTMSG(EQ_LINE_NUM(item), 1257, Error, EQ_COLUMN_NUM(item), 00636 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00637 "AUTOMATIC", "AUTOMATIC"); 00638 } 00639 00640 ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item)) = sb_idx; 00641 type_idx = ATD_TYPE_IDX(EQ_ATTR_IDX(item)); 00642 00643 if (TYP_TYPE(type_idx) == Structure) { 00644 00645 if (!ATT_SEQUENCE_SET(TYP_IDX(type_idx))) { 00646 PRINTMSG(EQ_LINE_NUM(item), 294, Error, 00647 EQ_COLUMN_NUM(item), 00648 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00649 } 00650 00651 if (ATT_POINTER_CPNT(TYP_IDX(type_idx))) { 00652 PRINTMSG(EQ_LINE_NUM(item), 354, Error, 00653 EQ_COLUMN_NUM(item), 00654 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00655 } 00656 00657 if (ATT_CHAR_SEQ(TYP_IDX(type_idx))) { 00658 00659 /* default_character_sequence */ 00660 00661 if (default_numeric_sequence || default_numeric_type) { 00662 PRINTMSG(EQ_LINE_NUM(item), 1239, Error, 00663 EQ_COLUMN_NUM(item), 00664 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00665 } 00666 else if (nondefault_sequence_type != NULL_IDX) { 00667 PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error, 00668 EQ_COLUMN_NUM(nondefault_sequence_type), 00669 AT_OBJ_NAME_PTR(EQ_ATTR_IDX( 00670 nondefault_sequence_type))); 00671 } 00672 else if (nondefault_intrinsic_type != NULL_IDX) { 00673 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error, 00674 EQ_COLUMN_NUM(nondefault_intrinsic_type), 00675 AT_OBJ_NAME_PTR(EQ_ATTR_IDX( 00676 nondefault_intrinsic_type))); 00677 } 00678 else { 00679 default_character_sequence = TRUE; 00680 } 00681 } 00682 else if (!ATT_NON_DEFAULT_CPNT(TYP_IDX(type_idx)) && 00683 ATT_DCL_NUMERIC_SEQ(TYP_IDX(type_idx))) { 00684 00685 /* default_numeric_sequence */ 00686 00687 if (default_character_sequence || default_character_type) { 00688 PRINTMSG(EQ_LINE_NUM(item), 1240, Error, 00689 EQ_COLUMN_NUM(item), 00690 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00691 } 00692 else if (nondefault_sequence_type != NULL_IDX) { 00693 PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error, 00694 EQ_COLUMN_NUM(nondefault_sequence_type), 00695 AT_OBJ_NAME_PTR(EQ_ATTR_IDX( 00696 nondefault_sequence_type))); 00697 } 00698 else if (nondefault_intrinsic_type != NULL_IDX) { 00699 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error, 00700 EQ_COLUMN_NUM(nondefault_intrinsic_type), 00701 AT_OBJ_NAME_PTR(EQ_ATTR_IDX( 00702 nondefault_intrinsic_type))); 00703 } 00704 00705 else { 00706 00707 # if defined(_ACCEPT_CMD_s_32) 00708 if (cmd_line_flags.s_default32) { 00709 PRINTMSG(EQ_LINE_NUM(item), 1244, Warning, 00710 EQ_COLUMN_NUM(item), 00711 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)), 00712 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 00713 } 00714 # endif 00715 default_numeric_sequence = TRUE; 00716 } 00717 } 00718 else { /* nondefault sequence type */ 00719 00720 if (default_character_sequence || default_character_type) { 00721 PRINTMSG(EQ_LINE_NUM(item), 1240, Error, 00722 EQ_COLUMN_NUM(item), 00723 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00724 } 00725 else if (default_numeric_sequence || default_numeric_type) { 00726 PRINTMSG(EQ_LINE_NUM(item), 1239, Error, 00727 EQ_COLUMN_NUM(item), 00728 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00729 } 00730 else if (nondefault_intrinsic_type != NULL_IDX) { 00731 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error, 00732 EQ_COLUMN_NUM(nondefault_intrinsic_type), 00733 AT_OBJ_NAME_PTR(EQ_ATTR_IDX( 00734 nondefault_intrinsic_type))); 00735 } 00736 #if 0 00737 /* 28Feb01[sos] : deleted for PV 816483 */ 00738 else if (nondefault_sequence_type != NULL_IDX && 00739 !compare_derived_types(type_idx, 00740 ATD_TYPE_IDX(EQ_ATTR_IDX(nondefault_sequence_type)))) { 00741 PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error, 00742 EQ_COLUMN_NUM(nondefault_sequence_type), 00743 AT_OBJ_NAME_PTR( 00744 EQ_ATTR_IDX(nondefault_sequence_type))); 00745 } 00746 #endif 00747 else { 00748 nondefault_sequence_type = item; 00749 } 00750 } 00751 } 00752 else if (TYP_TYPE(type_idx) == Character) { 00753 00754 if (default_numeric_sequence) { 00755 PRINTMSG(EQ_LINE_NUM(item), 1239, Error, 00756 EQ_COLUMN_NUM(item), 00757 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00758 } 00759 else if (default_numeric_type) { 00760 PRINTMSG(EQ_LINE_NUM(item), 522, Ansi, 00761 EQ_COLUMN_NUM(item)); 00762 default_character_type = TRUE; 00763 } 00764 else if (nondefault_sequence_type != NULL_IDX) { 00765 PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error, 00766 EQ_COLUMN_NUM(nondefault_sequence_type), 00767 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_sequence_type))); 00768 } 00769 else if (nondefault_intrinsic_type != NULL_IDX) { 00770 # if 0 00771 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error, 00772 EQ_COLUMN_NUM(nondefault_intrinsic_type), 00773 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_intrinsic_type))); 00774 # endif 00775 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 522, Ansi, 00776 EQ_COLUMN_NUM(nondefault_intrinsic_type)); 00777 default_character_type = TRUE; 00778 } 00779 else { 00780 default_character_type = TRUE; 00781 } 00782 } 00783 else if (TYP_DESC(type_idx) == Default_Typed || 00784 TYP_LINEAR(type_idx) == INTEGER_DEFAULT_TYPE || 00785 TYP_LINEAR(type_idx) == LOGICAL_DEFAULT_TYPE || 00786 TYP_LINEAR(type_idx) == REAL_DEFAULT_TYPE || 00787 TYP_LINEAR(type_idx) == DOUBLE_DEFAULT_TYPE || 00788 TYP_LINEAR(type_idx) == COMPLEX_DEFAULT_TYPE) { 00789 00790 if (default_character_sequence) { 00791 PRINTMSG(EQ_LINE_NUM(item), 1240, Error, 00792 EQ_COLUMN_NUM(item), 00793 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00794 } 00795 else if (default_character_type) { 00796 PRINTMSG(EQ_LINE_NUM(item), 522, Ansi, 00797 EQ_COLUMN_NUM(item)); 00798 default_numeric_type = TRUE; 00799 } 00800 else if (nondefault_sequence_type != NULL_IDX) { 00801 PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error, 00802 EQ_COLUMN_NUM(nondefault_sequence_type), 00803 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_sequence_type))); 00804 } 00805 else if (nondefault_intrinsic_type != NULL_IDX) { 00806 # if 0 00807 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error, 00808 EQ_COLUMN_NUM(nondefault_intrinsic_type), 00809 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_intrinsic_type))); 00810 # endif 00811 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1097, Ansi, 00812 EQ_COLUMN_NUM(nondefault_intrinsic_type)); 00813 default_numeric_type = TRUE; 00814 } 00815 else { 00816 default_numeric_type = TRUE; 00817 } 00818 } 00819 else { 00820 00821 if (default_character_sequence) { 00822 PRINTMSG(EQ_LINE_NUM(item), 1240, Error, 00823 EQ_COLUMN_NUM(item), 00824 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00825 } 00826 else if (default_character_type) { 00827 PRINTMSG(EQ_LINE_NUM(item), 522, Ansi, EQ_COLUMN_NUM(item)); 00828 nondefault_intrinsic_type = item; 00829 } 00830 else if (default_numeric_type) { 00831 # if 0 00832 PRINTMSG(EQ_LINE_NUM(item), 1239, Error, 00833 EQ_COLUMN_NUM(item), 00834 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00835 # endif 00836 PRINTMSG(EQ_LINE_NUM(item), 1097, Ansi, EQ_COLUMN_NUM(item)); 00837 nondefault_intrinsic_type = item; 00838 } 00839 else if (default_numeric_sequence) { 00840 PRINTMSG(EQ_LINE_NUM(item), 1239, Error, 00841 EQ_COLUMN_NUM(item), 00842 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 00843 } 00844 #if 0 00845 /* 28Feb01[sos] : deleted for PV 816483 */ 00846 else if (nondefault_sequence_type != NULL_IDX) { 00847 PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error, 00848 EQ_COLUMN_NUM(nondefault_sequence_type), 00849 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_sequence_type))); 00850 } 00851 #endif 00852 else if (nondefault_intrinsic_type != NULL_IDX && 00853 TYP_LINEAR(ATD_TYPE_IDX( 00854 EQ_ATTR_IDX(nondefault_intrinsic_type))) != 00855 TYP_LINEAR(type_idx)) { 00856 # if 0 00857 PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error, 00858 EQ_COLUMN_NUM(nondefault_intrinsic_type), 00859 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_intrinsic_type))); 00860 # endif 00861 PRINTMSG(EQ_LINE_NUM(item), 1097, Ansi, EQ_COLUMN_NUM(item)); 00862 nondefault_intrinsic_type = item; 00863 } 00864 else { 00865 nondefault_intrinsic_type = item; 00866 } 00867 } 00868 00869 item = EQ_NEXT_EQUIV_OBJ(item); 00870 } 00871 00872 group = EQ_NEXT_EQUIV_GRP(group); 00873 } 00874 00875 TRACE (Func_Exit, "equivalence_semantics", NULL); 00876 00877 return; 00878 00879 } /* equivalence_semantics */ 00880 00881 /******************************************************************************\ 00882 |* *| 00883 |* Description: *| 00884 |* Linearize an EQUIVALENCE subscript/substring reference. *| 00885 |* *| 00886 |* Input parameters: *| 00887 |* NONE *| 00888 |* *| 00889 |* Output parameters: *| 00890 |* NONE *| 00891 |* *| 00892 |* Returns: *| 00893 |* NONE *| 00894 |* *| 00895 \******************************************************************************/ 00896 static void linearize_list_for_equiv(int item) 00897 { 00898 int attr_idx; 00899 int bd_idx; 00900 size_offset_type bit_offset; 00901 int dim; 00902 int l_idx; 00903 int list_idx; 00904 size_offset_type left; 00905 size_offset_type result; 00906 size_offset_type right; 00907 int start_expr_idx; 00908 int trail_l_idx; 00909 00910 00911 TRACE (Func_Entry, "linearize_list_for_equiv", NULL); 00912 00913 attr_idx = EQ_ATTR_IDX(item); 00914 list_idx = EQ_LIST_IDX(item); 00915 bit_offset.fld = CN_Tbl_Idx; 00916 bit_offset.idx = CN_INTEGER_ZERO_IDX; 00917 00918 if (list_idx != NULL_IDX) { 00919 00920 if (!EQ_SUBSTRINGED(item)) { 00921 00922 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 00923 bd_idx = ATD_ARRAY_IDX(attr_idx); 00924 dim = 1; 00925 l_idx = list_idx; 00926 00927 while (l_idx != NULL_IDX && IL_FLD(l_idx) != NO_Tbl_Idx) { 00928 right.fld = BD_LB_FLD(bd_idx,dim); 00929 right.idx = BD_LB_IDX(bd_idx,dim); 00930 left.fld = IL_FLD(l_idx); 00931 left.idx = IL_IDX(l_idx); 00932 00933 if (!size_offset_binary_calc(&left, &right, Minus_Opr, &result)){ 00934 break; 00935 } 00936 00937 left.fld = BD_SM_FLD(bd_idx,dim); 00938 left.idx = BD_SM_IDX(bd_idx,dim); 00939 00940 if (!size_offset_binary_calc(&left, &result, Mult_Opr, &result)){ 00941 break; 00942 } 00943 00944 if (!size_offset_binary_calc(&bit_offset, 00945 &result, 00946 Plus_Opr, 00947 &bit_offset)) { 00948 break; 00949 } 00950 00951 l_idx = IL_NEXT_LIST_IDX(l_idx); 00952 dim++; 00953 } 00954 } 00955 } 00956 else { /* it is substringed */ 00957 00958 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 00959 l_idx = list_idx; 00960 00961 while (l_idx != NULL_IDX && IL_FLD(l_idx) != NO_Tbl_Idx) { 00962 trail_l_idx = l_idx; 00963 l_idx = IL_NEXT_LIST_IDX(l_idx); 00964 } 00965 00966 start_expr_idx = IL_PREV_LIST_IDX(trail_l_idx); 00967 00968 left.fld = IL_FLD(start_expr_idx); 00969 left.idx = IL_IDX(start_expr_idx); 00970 right.fld = CN_Tbl_Idx; 00971 right.idx = CN_INTEGER_ONE_IDX; 00972 00973 size_offset_binary_calc(&left, &right, Minus_Opr, &bit_offset); 00974 00975 IL_FLD(start_expr_idx) = NO_Tbl_Idx; 00976 00977 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 00978 00979 if (IL_FLD(list_idx) == NO_Tbl_Idx) { 00980 AT_DCL_ERR(attr_idx) = TRUE; 00981 PRINTMSG(IL_LINE_NUM(list_idx), 250, Error, 00982 IL_COL_NUM(list_idx)); 00983 } 00984 00985 bd_idx = ATD_ARRAY_IDX(attr_idx); 00986 dim = 1; 00987 l_idx = list_idx; 00988 00989 while (l_idx != NULL_IDX && IL_FLD(l_idx) != NO_Tbl_Idx) { 00990 00991 left.fld = IL_FLD(l_idx); 00992 left.idx = IL_IDX(l_idx); 00993 right.fld = BD_LB_FLD(bd_idx, dim); 00994 right.idx = BD_LB_IDX(bd_idx, dim); 00995 00996 if (!size_offset_binary_calc(&left, 00997 &right, 00998 Minus_Opr, 00999 &result)) { 01000 break; 01001 } 01002 01003 left.fld = BD_SM_FLD(bd_idx, dim); 01004 left.idx = BD_SM_IDX(bd_idx, dim); 01005 01006 if (!size_offset_binary_calc(&left, 01007 &result, 01008 Mult_Opr, 01009 &result)) { 01010 break; 01011 } 01012 01013 if (!size_offset_binary_calc(&bit_offset, 01014 &result, 01015 Plus_Opr, 01016 &bit_offset)) { 01017 break; 01018 } 01019 01020 l_idx = IL_NEXT_LIST_IDX(l_idx); 01021 dim = dim + 1; 01022 } 01023 } 01024 } 01025 } /* it is substringed */ 01026 } 01027 01028 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 01029 result.fld = CN_Tbl_Idx; 01030 result.idx = CN_INTEGER_CHAR_BIT_IDX; 01031 } 01032 else { 01033 result.fld = CN_Tbl_Idx; 01034 result.idx = CN_INTEGER_BITS_PER_WORD_IDX; 01035 01036 # if defined(_TARGET_OS_MAX) || defined(_WHIRL_HOST64_TARGET64) 01037 01038 /* Complex_4 does not go here because it is aligned for 64 bits. */ 01039 /* The stride multiplier for one of these types is based on 32 bits */ 01040 /* not the standard 64 bits. (MPP only) */ 01041 01042 if (PACK_HALF_WORD_TEST_CONDITION(ATD_TYPE_IDX(attr_idx))) { 01043 C_TO_F_INT(result.constant, 01044 TARGET_BITS_PER_WORD / 2, 01045 CG_INTEGER_DEFAULT_TYPE); 01046 result.fld = NO_Tbl_Idx; 01047 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 01048 } 01049 # endif 01050 01051 # if defined(_INTEGER_1_AND_2) 01052 01053 if (on_off_flags.integer_1_and_2) { 01054 01055 if (PACK_8_BIT_TEST_CONDITION(ATD_TYPE_IDX(attr_idx))) { 01056 C_TO_F_INT(result.constant, 8, CG_INTEGER_DEFAULT_TYPE); 01057 result.fld = NO_Tbl_Idx; 01058 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 01059 } 01060 else if (PACK_16_BIT_TEST_CONDITION(ATD_TYPE_IDX(attr_idx))) { 01061 C_TO_F_INT(result.constant, 16, CG_INTEGER_DEFAULT_TYPE); 01062 result.fld = NO_Tbl_Idx; 01063 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 01064 } 01065 } 01066 01067 # endif 01068 } 01069 01070 size_offset_binary_calc(&bit_offset, &result, Mult_Opr, &bit_offset); 01071 01072 if (bit_offset.fld == NO_Tbl_Idx) { 01073 IL_FLD(list_idx) = CN_Tbl_Idx; 01074 IL_IDX(list_idx) = ntr_const_tbl(bit_offset.type_idx, 01075 FALSE, 01076 bit_offset.constant); 01077 } 01078 else { 01079 IL_FLD(list_idx) = bit_offset.fld; 01080 IL_IDX(list_idx) = bit_offset.idx; 01081 } 01082 01083 IL_LINE_NUM(list_idx) = 1; 01084 IL_COL_NUM(list_idx) = 0; 01085 01086 TRACE (Func_Exit, "linearize_list_for_equiv", NULL); 01087 01088 return; 01089 01090 } /* linearize_list_for_equiv */ 01091 01092 01093 /******************************************************************************\ 01094 |* *| 01095 |* Description: *| 01096 |* This merge routine will search through two equivalence groups at a *| 01097 |* time. If an identical object is found in both groups those two *| 01098 |* groups are merged into one equivalence group. Identical means *| 01099 |* that we are looking at the same attr and the bit offset value is *| 01100 |* identical on these two objects. Because we are merging only when *| 01101 |* the offsets on the two objects are identical there is no need to *| 01102 |* adjust offsets for the objects in the merged groups. *| 01103 |* *| 01104 |* Input parameters: *| 01105 |* NONE *| 01106 |* *| 01107 |* Output parameters: *| 01108 |* NONE *| 01109 |* *| 01110 |* Returns: *| 01111 |* NONE *| 01112 |* *| 01113 \******************************************************************************/ 01114 static void merge_equivalence_groups1(void) 01115 { 01116 01117 int group; 01118 int group_end; 01119 int item; 01120 int list_idx; 01121 int list_item; 01122 int prev_group; 01123 01124 01125 TRACE (Func_Entry, "merge_equivalence_groups1", NULL); 01126 01127 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 01128 01129 while (group != NULL_IDX) { 01130 01131 if (EQ_MERGED(group)) { 01132 01133 /* This group has been merged with a previous */ 01134 /* group, so remove it from the group list. */ 01135 01136 EQ_NEXT_EQUIV_GRP(prev_group) = EQ_NEXT_EQUIV_GRP(group); 01137 } 01138 else { 01139 group_end = EQ_GRP_END_IDX(group); 01140 item = group; 01141 01142 while (item != NULL_IDX) { 01143 01144 if (EQ_ERROR(item)) { 01145 item = EQ_NEXT_EQUIV_OBJ(item); 01146 continue; 01147 } 01148 01149 if (EQ_SEARCH_DONE(item)) { 01150 01151 /* This item has been merged into this group because it */ 01152 /* Matches another item in this group. Do not search */ 01153 /* again. It is a waste of time because we've already */ 01154 /* searched all occurences of this item. We will not */ 01155 /* come across this eq item in this routine again, */ 01156 /* because we are doing only one pass through all */ 01157 /* groups and items, so turn off the flag so it can be */ 01158 /* used in the group2 merge later on. */ 01159 01160 EQ_SEARCH_DONE(item) = FALSE; 01161 } 01162 else if (ATD_CLASS(EQ_ATTR_IDX(item)) == Variable && 01163 ATD_EQUIV_LIST(EQ_ATTR_IDX(item)) != NULL_IDX) { 01164 01165 /* This attr is in more than one equivalence group. */ 01166 01167 list_idx = ATD_EQUIV_LIST(EQ_ATTR_IDX(item)); 01168 01169 while (list_idx != NULL_IDX) { 01170 list_item = AL_EQ_IDX(list_idx); 01171 01172 if (list_item != item && EQ_GRP_IDX(list_item) != group && 01173 (IL_IDX(EQ_LIST_IDX(list_item)) == 01174 IL_IDX(EQ_LIST_IDX(item)))) { 01175 01176 /* Same attr with same offset. Merge them. Do not */ 01177 /* merge if this item is already in this group. */ 01178 01179 /* 1) Mark list item to prevent researching. */ 01180 /* 2) Merge the new group to the end of the old. */ 01181 /* 3) Mark the merged group as merged, so it can */ 01182 /* be removed from the group list. */ 01183 /* 4) Set EQ_GRP_IDX for all members of new group. */ 01184 01185 EQ_SEARCH_DONE(list_item) = TRUE; 01186 EQ_NEXT_EQUIV_OBJ(group_end) = EQ_GRP_IDX(list_item); 01187 EQ_MERGED(EQ_GRP_IDX(list_item)) = TRUE; 01188 01189 group_end = EQ_GRP_END_IDX(EQ_GRP_IDX(list_item)); 01190 list_item = EQ_GRP_IDX(list_item); /* Group start */ 01191 01192 while (list_item != NULL_IDX) { 01193 EQ_GRP_IDX(list_item) = group; 01194 list_item = EQ_NEXT_EQUIV_OBJ(list_item); 01195 } 01196 } 01197 list_idx = AL_NEXT_IDX(list_idx); 01198 } 01199 } 01200 item = EQ_NEXT_EQUIV_OBJ(item); 01201 } 01202 EQ_GRP_END_IDX(group) = group_end; 01203 prev_group = group; 01204 } 01205 group = EQ_NEXT_EQUIV_GRP(group); 01206 } 01207 01208 TRACE (Func_Exit, "merge_equivalence_groups1", NULL); 01209 01210 return; 01211 01212 } /* merge_equivalence_groups1 */ 01213 01214 01215 /******************************************************************************\ 01216 |* *| 01217 |* Description: *| 01218 |* This merge routine is slightly different than *| 01219 |* merge_equivalence_groups1 in that two groups are merged if they *| 01220 |* contain an identical object regardless of the offset attached to *| 01221 |* that object. At this point we know that the offsets attached to *| 01222 |* the objects are different so we will have to adjust all the offsets *| 01223 |* in one of the two groups by the difference in the offsets of the *| 01224 |* two identical objects. *| 01225 |* *| 01226 |* Input parameters: *| 01227 |* NONE *| 01228 |* *| 01229 |* Output parameters: *| 01230 |* NONE *| 01231 |* *| 01232 |* Returns: *| 01233 |* NONE *| 01234 |* *| 01235 \******************************************************************************/ 01236 static void merge_equivalence_groups2(void) 01237 { 01238 boolean adjust; 01239 size_offset_type adjust_by; 01240 int group; 01241 int group_end; 01242 int item; 01243 size_offset_type left; 01244 int list_idx; 01245 int list_item; 01246 int prev_group; 01247 size_offset_type result; 01248 size_offset_type right; 01249 01250 01251 TRACE (Func_Entry, "merge_equivalence_groups2", NULL); 01252 01253 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 01254 01255 while (group != NULL_IDX) { 01256 01257 if (EQ_MERGED(group)) { 01258 01259 /* This group has been merged with a previous */ 01260 /* group, so remove it from the group list. */ 01261 01262 EQ_NEXT_EQUIV_GRP(prev_group) = EQ_NEXT_EQUIV_GRP(group); 01263 } 01264 else { 01265 group_end = EQ_GRP_END_IDX(group); 01266 item = group; 01267 01268 while (item != NULL_IDX) { 01269 01270 if (EQ_ERROR(item)) { 01271 item = EQ_NEXT_EQUIV_OBJ(item); 01272 continue; 01273 } 01274 01275 if (ATD_CLASS(EQ_ATTR_IDX(item)) == Variable && 01276 ATD_EQUIV_LIST(EQ_ATTR_IDX(item)) != NULL_IDX) { 01277 01278 /* This attr is in more than one equivalence group. */ 01279 01280 list_idx = ATD_EQUIV_LIST(EQ_ATTR_IDX(item)); 01281 01282 while (list_idx != NULL_IDX) { 01283 list_item = AL_EQ_IDX(list_idx); 01284 01285 if (list_item != item && EQ_GRP_IDX(list_item) != group) { 01286 01287 /* Do not merge if item is already in this group. */ 01288 01289 /* 1) Merge the new group to the end of the old. */ 01290 /* 2) Mark the merged group as merged, so it can */ 01291 /* be removed from the group list. */ 01292 /* 3) Adjust the offsets for all groups if the */ 01293 /* offsets are different. */ 01294 01295 if (EQ_OFFSET_IDX(list_item) != EQ_OFFSET_IDX(item) || 01296 EQ_OFFSET_FLD(list_item) != EQ_OFFSET_FLD(item)) { 01297 left.fld = EQ_OFFSET_FLD(list_item); 01298 left.idx = EQ_OFFSET_IDX(list_item); 01299 right.fld = EQ_OFFSET_FLD(item); 01300 right.idx = EQ_OFFSET_IDX(item); 01301 01302 if (!size_offset_binary_calc(&left, 01303 &right, 01304 Minus_Opr, 01305 &adjust_by)) { 01306 adjust = FALSE; 01307 break; 01308 } 01309 adjust = TRUE; 01310 } 01311 else { 01312 adjust = FALSE; 01313 } 01314 01315 EQ_NEXT_EQUIV_OBJ(group_end) = EQ_GRP_IDX(list_item); 01316 EQ_MERGED(EQ_GRP_IDX(list_item)) = TRUE; 01317 01318 group_end = EQ_GRP_END_IDX(EQ_GRP_IDX(list_item)); 01319 list_item = EQ_GRP_IDX(list_item); /* Group start */ 01320 01321 if (adjust) { 01322 01323 while (list_item != NULL_IDX) { 01324 EQ_GRP_IDX(list_item)= group; 01325 left.fld = EQ_OFFSET_FLD(list_item); 01326 left.idx = EQ_OFFSET_IDX(list_item); 01327 01328 if (!size_offset_binary_calc(&left, 01329 &adjust_by, 01330 Minus_Opr, 01331 &result)) { 01332 break; 01333 } 01334 01335 if (result.fld == NO_Tbl_Idx) { 01336 EQ_OFFSET_FLD(list_item) = CN_Tbl_Idx; 01337 EQ_OFFSET_IDX(list_item) = ntr_const_tbl( 01338 result.type_idx, 01339 FALSE, 01340 result.constant); 01341 } 01342 else { 01343 EQ_OFFSET_FLD(list_item) = result.fld; 01344 EQ_OFFSET_IDX(list_item) = result.idx; 01345 } 01346 01347 list_item = EQ_NEXT_EQUIV_OBJ(list_item); 01348 } 01349 } 01350 else { 01351 while (list_item != NULL_IDX) { 01352 EQ_GRP_IDX(list_item) = group; 01353 list_item = EQ_NEXT_EQUIV_OBJ(list_item); 01354 } 01355 } 01356 } 01357 list_idx = AL_NEXT_IDX(list_idx); 01358 } 01359 } 01360 item = EQ_NEXT_EQUIV_OBJ(item); 01361 } 01362 EQ_GRP_END_IDX(group) = group_end; 01363 prev_group = group; 01364 } 01365 group = EQ_NEXT_EQUIV_GRP(group); 01366 } 01367 01368 TRACE (Func_Exit, "merge_equivalence_groups2", NULL); 01369 01370 return; 01371 01372 } /* merge_equivalence_groups2 */ 01373 01374 /******************************************************************************\ 01375 |* *| 01376 |* Description: *| 01377 |* Assign offsets to the items in equivalence groups. *| 01378 |* *| 01379 |* Input parameters: *| 01380 |* NONE *| 01381 |* *| 01382 |* Output parameters: *| 01383 |* NONE *| 01384 |* *| 01385 |* Returns: *| 01386 |* NONE *| 01387 |* *| 01388 \******************************************************************************/ 01389 static void assign_offsets_for_equiv_groups(void) 01390 { 01391 int group; 01392 int item; 01393 size_offset_type largest_offset; 01394 size_offset_type result; 01395 01396 01397 TRACE (Func_Entry, "assign_offsets_for_equiv_groups", NULL); 01398 01399 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 01400 01401 while (group != NULL_IDX) { 01402 01403 item = group; 01404 largest_offset.idx = CN_INTEGER_ZERO_IDX; 01405 largest_offset.fld = CN_Tbl_Idx; 01406 01407 while (item != NULL_IDX) { 01408 01409 if (!EQ_ERROR(item) && 01410 IL_IDX(EQ_LIST_IDX(item)) != CN_INTEGER_ZERO_IDX && 01411 fold_relationals(IL_IDX(EQ_LIST_IDX(item)), 01412 largest_offset.idx, 01413 Ge_Opr)) { 01414 largest_offset.fld = IL_FLD(EQ_LIST_IDX(item)); 01415 largest_offset.idx = IL_IDX(EQ_LIST_IDX(item)); 01416 } 01417 01418 item = EQ_NEXT_EQUIV_OBJ(item); 01419 } 01420 01421 if (largest_offset.idx != CN_INTEGER_ZERO_IDX) { 01422 01423 /* If the largest is zero - then they are all zero, */ 01424 /* so we don't need to do the subtraction. */ 01425 01426 item = group; 01427 01428 while (item != NULL_IDX) { 01429 01430 if (EQ_ERROR(item)) { 01431 item = EQ_NEXT_EQUIV_OBJ(item); 01432 continue; 01433 } 01434 01435 /* largest_offset_idx - IL_IDX(EQ_LIST_IDX(item)) */ 01436 01437 if (fold_relationals(IL_IDX(EQ_LIST_IDX(item)), 01438 CN_INTEGER_ZERO_IDX, 01439 Eq_Opr)) { 01440 EQ_OFFSET_FLD(item) = largest_offset.fld; 01441 EQ_OFFSET_IDX(item) = largest_offset.idx; 01442 } 01443 else { 01444 result.fld = IL_FLD(EQ_LIST_IDX(item)); 01445 result.idx = IL_IDX(EQ_LIST_IDX(item)); 01446 01447 if (size_offset_binary_calc(&largest_offset, 01448 &result, 01449 Minus_Opr, 01450 &result)) { 01451 01452 if (result.fld == NO_Tbl_Idx) { 01453 EQ_OFFSET_FLD(item) = CN_Tbl_Idx; 01454 EQ_OFFSET_IDX(item) = ntr_const_tbl(result.type_idx, 01455 FALSE, 01456 result.constant); 01457 } 01458 else { 01459 EQ_OFFSET_FLD(item) = result.fld; 01460 EQ_OFFSET_IDX(item) = result.idx; 01461 } 01462 } 01463 else { 01464 break; 01465 } 01466 } 01467 item = EQ_NEXT_EQUIV_OBJ(item); 01468 } 01469 } 01470 01471 group = EQ_NEXT_EQUIV_GRP(group); 01472 } 01473 01474 01475 TRACE (Func_Exit, "assign_offsets_for_equiv_groups", NULL); 01476 01477 return; 01478 01479 } /* assign_offsets_for_equiv_groups */ 01480 01481 /******************************************************************************\ 01482 |* *| 01483 |* Description: *| 01484 |* This routine resolves the lower and upper bounds to a constant or a *| 01485 |* temp. Calculate the extent and stride multiplier for each dimension. *| 01486 |* *| 01487 |* Input parameters: *| 01488 |* attr_idx -> Index to attribute for array. *| 01489 |* *| 01490 |* Output parameters: *| 01491 |* NONE *| 01492 |* *| 01493 |* Returns: *| 01494 |* NONE *| 01495 |* *| 01496 \******************************************************************************/ 01497 void array_dim_resolution(int attr_idx, 01498 boolean need_const_array) 01499 { 01500 bd_array_size_type array_size_type; 01501 int at_idx; 01502 int bd_idx; 01503 int column; 01504 int cvrt_idx; 01505 int dim; 01506 int entry_count; 01507 int entry_list; 01508 expr_arg_type expr_desc; 01509 int extent_entry_idx = NULL_IDX; 01510 fld_type extent_fld; 01511 int extent_idx; 01512 int ir_idx; 01513 boolean is_interface; 01514 int len_ir_idx; 01515 int length_idx; 01516 int length_entry_idx = NULL_IDX; 01517 int line; 01518 int mult_idx; 01519 int new_bd_idx; 01520 int next_ir_idx; 01521 opnd_type opnd; 01522 int sh_idx; 01523 int stride_entry_idx = NULL_IDX; 01524 int stride_entry_count; 01525 size_offset_type stride; 01526 int type; 01527 enum bd_array_values ffmm; 01528 01529 TRACE (Func_Entry, "array_dim_resolution", NULL); 01530 01531 is_interface = SCP_IS_INTERFACE(curr_scp_idx); 01532 bd_idx = ATD_ARRAY_IDX(attr_idx); 01533 01534 ffmm = BD_ARRAY_CLASS(bd_idx); 01535 01536 if (ATD_CLASS(attr_idx) == Function_Result) { 01537 entry_list = ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)); 01538 } 01539 else { 01540 entry_list = ATD_NO_ENTRY_LIST(attr_idx); 01541 } 01542 01543 if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) { 01544 01545 /* This is called by PARAMETER processing. This must be an explicit */ 01546 /* shape constant size array. PARAMETER processing will issue the */ 01547 /* error. If this is needed elsewhere, it will come through again */ 01548 /* during decl_semantics. */ 01549 01550 if (need_const_array) { 01551 goto EXIT; 01552 } 01553 01554 if (ATD_CLASS(attr_idx) == Compiler_Tmp && ATD_IM_A_DOPE(attr_idx)) { 01555 goto EXIT; /* everything is ok */ 01556 } 01557 01558 01559 if (ATD_CLASS(attr_idx) == Dummy_Argument && !ATD_POINTER(attr_idx)) { 01560 01561 /* Don't convert intrinsic dargs to assumed shape */ 01562 01563 if (ATD_INTRIN_DARG(attr_idx)) { 01564 goto EXIT; 01565 } 01566 01567 new_bd_idx = reserve_array_ntry(BD_RANK(bd_idx)); 01568 BD_RANK(new_bd_idx) = BD_RANK(bd_idx); 01569 BD_DCL_ERR(new_bd_idx) = BD_DCL_ERR(bd_idx); 01570 BD_ARRAY_CLASS(new_bd_idx) = Assumed_Shape; 01571 BD_ARRAY_SIZE(new_bd_idx) = Constant_Size; 01572 BD_LINE_NUM(new_bd_idx) = BD_LINE_NUM(bd_idx); 01573 BD_COLUMN_NUM(new_bd_idx) = BD_COLUMN_NUM(bd_idx); 01574 01575 for (dim = 1; dim <= BD_RANK(new_bd_idx); dim++) { 01576 BD_LB_FLD(new_bd_idx, dim) = CN_Tbl_Idx; 01577 BD_LB_IDX(new_bd_idx, dim) = CN_INTEGER_ONE_IDX; 01578 } 01579 01580 bd_idx = ntr_array_in_bd_tbl(new_bd_idx); 01581 BD_ARRAY_SIZE(bd_idx) = Constant_Size; 01582 BD_RESOLVED(bd_idx) = TRUE; 01583 ATD_ARRAY_IDX(attr_idx) = bd_idx; 01584 01585 if (ATD_IGNORE_TKR(attr_idx)) { 01586 AT_DCL_ERR(attr_idx) = TRUE; 01587 PRINTMSG(AT_DEF_LINE(attr_idx), 1459, Error, 01588 AT_DEF_COLUMN(attr_idx), 01589 AT_OBJ_NAME_PTR(attr_idx), 01590 "IGNORE_TKR", 01591 "assumed-shape DIMENSION"); 01592 } 01593 01594 # if defined(_TARGET_OS_MAX) 01595 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) { 01596 AT_DCL_ERR(attr_idx) = TRUE; 01597 PRINTMSG(BD_LINE_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 1583, Error, 01598 BD_COLUMN_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 01599 "co-array dimensions", 01600 "assumed-shape arrays"); 01601 } 01602 # endif 01603 } 01604 else if (!ATD_POINTER(attr_idx) && !ATD_ALLOCATABLE(attr_idx)) { 01605 AT_DCL_ERR(attr_idx) = TRUE; 01606 01607 if (ATD_CLASS(attr_idx) == Function_Result) { 01608 PRINTMSG(AT_DEF_LINE(attr_idx), 571, Error, 01609 AT_DEF_COLUMN(attr_idx), 01610 AT_OBJ_NAME_PTR(attr_idx)); 01611 } 01612 else { 01613 PRINTMSG(AT_DEF_LINE(attr_idx), 353, Error, 01614 AT_DEF_COLUMN(attr_idx), 01615 AT_OBJ_NAME_PTR(attr_idx)); 01616 } 01617 } 01618 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character && 01619 TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Var_Len_Char) { 01620 entry_list = merge_entry_lists(entry_list, 01621 ATD_NO_ENTRY_LIST(TYP_IDX(ATD_TYPE_IDX(attr_idx)))); 01622 01623 if (entry_list != NULL_IDX && 01624 (SCP_ALT_ENTRY_CNT(curr_scp_idx)+1) == AL_ENTRY_COUNT(entry_list)){ 01625 PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error, 01626 AT_DEF_COLUMN(attr_idx), 01627 AT_OBJ_NAME_PTR(attr_idx)); 01628 AT_DCL_ERR(attr_idx) = TRUE; 01629 } 01630 } 01631 /* here add keep Deferred_Shape array in "array" form instead of 01632 generating dope vector */ 01633 else { 01634 01635 if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) { 01636 01637 BD_RESOLVED(bd_idx) = TRUE; 01638 BD_ARRAY_SIZE(bd_idx) = Unknown_Size; 01639 BD_ARRAY_CLASS(bd_idx)=Deferred_Shape1; 01640 /* BD_ARRAY_CLASS(bd_idx)=Deferred_Shape; */ 01641 01642 01643 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 01644 #if 0 /*FMZ Sept 2005 */ 01645 BD_LB_FLD(bd_idx,dim) = CN_Tbl_Idx; 01646 BD_LB_IDX(bd_idx, dim) = CN_INTEGER_ONE_IDX; 01647 #else 01648 BD_LB_FLD(bd_idx,dim) = NO_Tbl_Idx; 01649 #endif 01650 BD_UB_FLD(bd_idx, dim) = NO_Tbl_Idx; 01651 BD_XT_FLD(bd_idx, dim) = NO_Tbl_Idx; 01652 01653 } 01654 BD_LEN_FLD(bd_idx) = NO_Tbl_Idx; 01655 01656 } 01657 01658 } 01659 01660 goto EXIT; 01661 } 01662 01663 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) { 01664 01665 /* This is called by PARAMETER processing. This must be an explicit */ 01666 /* shape constant size array. PARAMETER processing will issue the */ 01667 /* error. If this is needed elsewhere, it will come through again */ 01668 /* during decl_semantics. */ 01669 01670 if (need_const_array) { 01671 goto EXIT; 01672 } 01673 01674 /* These must always be dummy arguments, so they can never be automatic */ 01675 01676 /* ATD_IM_A_DOPE(attr_idx) = TRUE; */ 01677 01678 if (!BD_RESOLVED(bd_idx)) { 01679 BD_RESOLVED(bd_idx) = TRUE; 01680 array_size_type = Constant_Size; 01681 length_entry_idx = NULL_IDX; 01682 01683 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 01684 01685 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01686 at_idx = BD_LB_IDX(bd_idx, dim); 01687 01688 if (ATD_CLASS(at_idx) == Constant) { 01689 BD_LB_FLD(bd_idx, dim) = CN_Tbl_Idx; 01690 BD_LB_IDX(bd_idx, dim) = ATD_CONST_IDX(at_idx); 01691 } 01692 else if (ATD_SYMBOLIC_CONSTANT(at_idx)) { 01693 array_size_type = Symbolic_Constant_Size; 01694 } 01695 else { 01696 length_entry_idx = merge_entry_lists( 01697 length_entry_idx, 01698 ATD_NO_ENTRY_LIST(BD_LB_IDX(bd_idx,dim))); 01699 array_size_type = Var_Len_Array; 01700 } 01701 } 01702 } 01703 01704 BD_ARRAY_SIZE(bd_idx) = array_size_type; 01705 01706 if (length_entry_idx != NULL_IDX) { 01707 entry_count = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1; 01708 01709 if (entry_count == AL_ENTRY_COUNT(length_entry_idx)) { 01710 01711 /* Error if problem with lower and/or upper bounds coming in */ 01712 /* different entry points. Bounds for this array declaration */ 01713 /* cannot be calculated at any entry point, because dummy args */ 01714 /* used in the expression do not enter at all the same points. */ 01715 01716 PRINTMSG(AT_DEF_LINE(attr_idx), 660, Error, 01717 AT_DEF_COLUMN(attr_idx), 01718 AT_OBJ_NAME_PTR(attr_idx)); 01719 AT_DCL_ERR(attr_idx) = TRUE; 01720 } 01721 else { 01722 01723 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character && 01724 TYP_FLD(ATD_TYPE_IDX(attr_idx)) == AT_Tbl_Idx) { 01725 01726 length_entry_idx = merge_entry_lists(length_entry_idx, 01727 ATD_NO_ENTRY_LIST(TYP_IDX(ATD_TYPE_IDX(attr_idx)))); 01728 01729 if (entry_count == AL_ENTRY_COUNT(length_entry_idx)) { 01730 01731 /* Bounds for this array declaration cannot be calculated*/ 01732 /* at any entry point, because dummy arguments used in */ 01733 /* the expression do not enter at all the same points. */ 01734 01735 PRINTMSG(AT_DEF_LINE(attr_idx), 661, Error, 01736 AT_DEF_COLUMN(attr_idx), 01737 AT_OBJ_NAME_PTR(attr_idx)); 01738 AT_DCL_ERR(attr_idx) = TRUE; 01739 } 01740 } 01741 01742 if (!AT_DCL_ERR(attr_idx) && entry_list != NULL_IDX) { 01743 length_entry_idx = merge_entry_lists(length_entry_idx, 01744 entry_list); 01745 01746 if (length_entry_idx != NULL_IDX && 01747 entry_count == AL_ENTRY_COUNT(length_entry_idx)) { 01748 01749 /* This array and its bounds variables do not enter at */ 01750 /* the same entry point. */ 01751 01752 PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error, 01753 AT_DEF_COLUMN(attr_idx), 01754 AT_OBJ_NAME_PTR(attr_idx)); 01755 AT_DCL_ERR(attr_idx) = TRUE; 01756 } 01757 } 01758 } 01759 } 01760 } 01761 01762 if (ATD_CLASS(attr_idx) != Dummy_Argument || ATD_POINTER(attr_idx)) { 01763 AT_DCL_ERR(attr_idx) = TRUE; 01764 PRINTMSG(AT_DEF_LINE(attr_idx), 351, Error, 01765 AT_DEF_COLUMN(attr_idx), 01766 AT_OBJ_NAME_PTR(attr_idx)); 01767 } 01768 01769 goto EXIT; 01770 } 01771 01772 /* If this array bounds entry has already been resolved, skip the section */ 01773 /* that calculates the extent, length, and stride multiplier. */ 01774 /* The only array entries that are shared are of the same type. Each attr */ 01775 /* will have to calculate it's own automatic stuff. */ 01776 01777 if (BD_RESOLVED(bd_idx)) { 01778 goto NEXT; 01779 } 01780 01781 array_size_type = Constant_Size; 01782 01783 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 01784 01785 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01786 01787 if (ATD_CLASS(BD_LB_IDX(bd_idx, dim)) == Constant) { 01788 BD_LB_FLD(bd_idx, dim) = CN_Tbl_Idx; 01789 BD_LB_IDX(bd_idx, dim) = ATD_CONST_IDX(BD_LB_IDX(bd_idx, dim)); 01790 } 01791 else if (ATD_SYMBOLIC_CONSTANT(BD_LB_IDX(bd_idx, dim))) { 01792 array_size_type = Symbolic_Constant_Size; 01793 } 01794 else { 01795 array_size_type = Var_Len_Array; 01796 OPND_FLD(opnd) = BD_LB_FLD(bd_idx, dim); 01797 OPND_IDX(opnd) = BD_LB_IDX(bd_idx, dim); 01798 OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx); 01799 OPND_COL_NUM(opnd) = BD_COLUMN_NUM(bd_idx); 01800 } 01801 } 01802 01803 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01804 01805 if (ATD_CLASS(BD_UB_IDX(bd_idx, dim)) == Constant) { 01806 BD_UB_FLD(bd_idx, dim) = CN_Tbl_Idx; 01807 BD_UB_IDX(bd_idx, dim) = ATD_CONST_IDX(BD_UB_IDX(bd_idx, dim)); 01808 } 01809 else if (ATD_SYMBOLIC_CONSTANT(BD_UB_IDX(bd_idx, dim))) { 01810 01811 if (array_size_type != Var_Len_Array) { 01812 array_size_type = Symbolic_Constant_Size; 01813 } 01814 } 01815 else { 01816 array_size_type = Var_Len_Array; 01817 OPND_FLD(opnd) = BD_UB_FLD(bd_idx, dim); 01818 OPND_IDX(opnd) = BD_UB_IDX(bd_idx, dim); 01819 OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx); 01820 OPND_COL_NUM(opnd) = BD_COLUMN_NUM(bd_idx); 01821 } 01822 } 01823 } 01824 01825 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size) { 01826 01827 /* This is called by PARAMETER processing. This must be an explicit */ 01828 /* shape constant size array. PARAMETER processing will issue the */ 01829 /* error. If this is needed elsewhere, it will come through again */ 01830 /* during decl_semantics. */ 01831 01832 if (need_const_array) { 01833 goto EXIT; 01834 } 01835 01836 BD_ARRAY_SIZE(bd_idx) = array_size_type; 01837 } 01838 else { 01839 BD_ARRAY_SIZE(bd_idx) = array_size_type; 01840 01841 if (array_size_type == Var_Len_Array) { 01842 01843 BD_ARRAY_SIZE(bd_idx) = Var_Len_Array; 01844 01845 /* This is called by PARAMETER processing. This must be an explicit */ 01846 /* shape constant size array. PARAMETER processing will issue the */ 01847 /* error. If this is needed elsewhere, it will come through again */ 01848 /* during decl_semantics. */ 01849 01850 if (need_const_array) { 01851 goto EXIT; 01852 } 01853 01854 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Function && 01855 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Subroutine) { 01856 PRINTMSG(AT_DEF_LINE(attr_idx), 131, Error, 01857 AT_DEF_COLUMN(attr_idx), 01858 AT_OBJ_NAME_PTR(attr_idx)); 01859 BD_DCL_ERR(bd_idx) = TRUE; 01860 } 01861 } 01862 } 01863 01864 BD_RESOLVED(bd_idx) = TRUE; 01865 01866 set_stride_for_first_dim(ATD_TYPE_IDX(attr_idx), &stride); 01867 01868 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character && 01869 stride.fld == AT_Tbl_Idx && 01870 ATD_NO_ENTRY_LIST(stride.idx) != NULL_IDX) { 01871 stride_entry_idx = merge_entry_lists(NULL_IDX, 01872 ATD_NO_ENTRY_LIST(stride.idx)); 01873 } 01874 else { 01875 stride_entry_idx = NULL_IDX; 01876 } 01877 01878 NTR_IR_TBL(len_ir_idx); 01879 IR_TYPE_IDX(len_ir_idx) = SA_INTEGER_DEFAULT_TYPE; 01880 01881 BD_LEN_IDX(bd_idx) = len_ir_idx; /* Save this so it can be folded */ 01882 BD_LEN_FLD(bd_idx) = IR_Tbl_Idx; 01883 length_entry_idx = NULL_IDX; 01884 line = BD_LINE_NUM(bd_idx); 01885 column = BD_COLUMN_NUM(bd_idx); 01886 01887 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 01888 BD_SM_FLD(bd_idx, dim) = stride.fld; 01889 BD_SM_IDX(bd_idx, dim) = stride.idx; 01890 01891 if (extent_entry_idx != NULL_IDX) { 01892 free_attr_list(extent_entry_idx); 01893 extent_entry_idx = NULL_IDX; 01894 } 01895 01896 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01897 at_idx = BD_LB_IDX(bd_idx, dim); 01898 01899 if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) { 01900 extent_entry_idx = merge_entry_lists(NULL_IDX, 01901 ATD_NO_ENTRY_LIST(at_idx)); 01902 } 01903 } 01904 01905 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01906 at_idx = BD_UB_IDX(bd_idx, dim); 01907 01908 if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) { 01909 extent_entry_idx = merge_entry_lists(extent_entry_idx, 01910 ATD_NO_ENTRY_LIST(at_idx)); 01911 } 01912 } 01913 01914 if (BD_LB_FLD(bd_idx, dim) == CN_Tbl_Idx && 01915 fold_relationals(BD_LB_IDX(bd_idx, dim), 01916 CN_INTEGER_ONE_IDX, 01917 Eq_Opr)) { 01918 01919 /* If the lb is a one, just use the ub for the extent */ 01920 01921 extent_fld = BD_UB_FLD(bd_idx, dim); 01922 extent_idx = BD_UB_IDX(bd_idx, dim); 01923 } 01924 else { 01925 /* # if 0 cannot get ride of it.Because array initialize need BD_XT valuses to be correct!!!*/ 01926 NTR_IR_TBL(ir_idx); /* Create 1 - lower */ 01927 IR_OPR(ir_idx) = Minus_Opr; 01928 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 01929 IR_FLD_L(ir_idx) = CN_Tbl_Idx; 01930 IR_IDX_L(ir_idx) = CN_INTEGER_ONE_IDX; 01931 IR_LINE_NUM_L(ir_idx) = line; 01932 IR_COL_NUM_L(ir_idx) = column; 01933 IR_FLD_R(ir_idx) = BD_LB_FLD(bd_idx, dim); 01934 IR_IDX_R(ir_idx) = BD_LB_IDX(bd_idx, dim); 01935 IR_LINE_NUM_R(ir_idx) = line; 01936 IR_COL_NUM_R(ir_idx) = column; 01937 IR_LINE_NUM(ir_idx) = line; 01938 IR_COL_NUM(ir_idx) = column; 01939 01940 NTR_IR_TBL(next_ir_idx); /* Upper + (1 - lower) */ 01941 IR_OPR(next_ir_idx) = Plus_Opr; 01942 IR_TYPE_IDX(next_ir_idx) = SA_INTEGER_DEFAULT_TYPE; 01943 IR_IDX_L(next_ir_idx) = BD_UB_IDX(bd_idx, dim); 01944 IR_FLD_L(next_ir_idx) = BD_UB_FLD(bd_idx, dim); 01945 IR_LINE_NUM_L(next_ir_idx) = line; 01946 IR_COL_NUM_L(next_ir_idx) = column; 01947 IR_FLD_R(next_ir_idx) = IR_Tbl_Idx; 01948 IR_IDX_R(next_ir_idx) = ir_idx; 01949 IR_LINE_NUM_R(next_ir_idx) = line; 01950 IR_COL_NUM_R(next_ir_idx) = column; 01951 IR_LINE_NUM(next_ir_idx) = line; 01952 IR_COL_NUM(next_ir_idx) = column; 01953 01954 if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) { 01955 IR_OPR(next_ir_idx) = Symbolic_Plus_Opr; 01956 IR_OPR(ir_idx) = Symbolic_Minus_Opr; 01957 extent_idx = gen_compiler_tmp(line, column, Priv, TRUE); 01958 extent_fld = AT_Tbl_Idx; 01959 01960 ATD_SYMBOLIC_CONSTANT(extent_idx) = TRUE; 01961 ATD_TYPE_IDX(extent_idx) = SA_INTEGER_DEFAULT_TYPE; 01962 ATD_FLD(extent_idx) = IR_Tbl_Idx; 01963 ATD_TMP_IDX(extent_idx) = next_ir_idx; 01964 01965 01966 /* KAY - Some of this may be folded if they are both not */ 01967 /* symbolic constants. */ 01968 } 01969 else { 01970 01971 OPND_FLD(opnd) = IR_Tbl_Idx; 01972 OPND_IDX(opnd) = next_ir_idx; 01973 OPND_LINE_NUM(opnd) = stmt_start_line; 01974 OPND_COL_NUM(opnd) = stmt_start_col; 01975 01976 sh_idx = ntr_sh_tbl(); 01977 SH_GLB_LINE(sh_idx) = stmt_start_line; 01978 SH_COL_NUM(sh_idx) = stmt_start_col; 01979 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 01980 SH_COMPILER_GEN(sh_idx) = TRUE; 01981 SH_P2_SKIP_ME(sh_idx) = TRUE; 01982 01983 expr_desc.rank = 0; 01984 xref_state = CIF_No_Usage_Rec; 01985 01986 /* This is in terms of tmps - so it will never */ 01987 /* generate more than one statement. */ 01988 01989 issue_overflow_msg_719 = FALSE; 01990 01991 if (!expr_semantics(&opnd, &expr_desc)) { 01992 01993 if (need_to_issue_719) { 01994 01995 need_to_issue_719 = FALSE; 01996 PRINTMSG(AT_DEF_LINE(attr_idx), 951, Error, 01997 AT_DEF_COLUMN(attr_idx), 01998 dim, 01999 AT_OBJ_NAME_PTR(attr_idx)); 02000 } 02001 AT_DCL_ERR(attr_idx) = TRUE; 02002 } 02003 02004 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 02005 extent_fld = CN_Tbl_Idx; 02006 extent_idx = OPND_IDX(opnd); 02007 FREE_SH_NODE(sh_idx); 02008 } 02009 else { 02010 extent_fld = AT_Tbl_Idx; 02011 extent_idx = ntr_bnds_sh_tmp_list(&opnd, 02012 extent_entry_idx, 02013 is_interface ? NULL_IDX:sh_idx, 02014 FALSE, 02015 SA_INTEGER_DEFAULT_TYPE); 02016 } 02017 } 02018 } 02019 02020 if (extent_fld == CN_Tbl_Idx) { 02021 02022 if (compare_cn_and_value(extent_idx, 0, Lt_Opr)) { 02023 extent_idx = CN_INTEGER_ZERO_IDX; 02024 } 02025 } 02026 else { /* Generate tmp = max(0, extent) */ 02027 02028 OPND_FLD(opnd) = extent_fld; 02029 OPND_IDX(opnd) = extent_idx; 02030 OPND_LINE_NUM(opnd) = line; 02031 OPND_COL_NUM(opnd) = column; 02032 02033 gen_tmp_equal_max_zero(&opnd, 02034 SA_INTEGER_DEFAULT_TYPE, 02035 extent_entry_idx, 02036 (BD_ARRAY_SIZE(bd_idx)==Symbolic_Constant_Size), 02037 is_interface); 02038 extent_fld = OPND_FLD(opnd); 02039 extent_idx = OPND_IDX(opnd); 02040 /* # endif */ 02041 # if 0 02042 extent_fld = BD_UB_FLD(bd_idx,dim); /* April */ 02043 extent_idx = BD_UB_IDX(bd_idx,dim); 02044 # endif 02045 } 02046 BD_XT_FLD(bd_idx, dim) = extent_fld; 02047 BD_XT_IDX(bd_idx, dim) = extent_idx; 02048 02049 /* STRIDE = STRIDE * (EXTENT of previous dimension) */ 02050 /* Fix stride for next dimension. */ 02051 /* Calculate length. */ 02052 02053 if (dim < BD_RANK(bd_idx)) { 02054 NTR_IR_TBL(ir_idx); /* Create Stride * Extent */ 02055 IR_OPR(ir_idx) = Mult_Opr; 02056 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 02057 IR_LINE_NUM(ir_idx) = BD_LINE_NUM(bd_idx); 02058 IR_COL_NUM(ir_idx) = BD_COLUMN_NUM(bd_idx); 02059 IR_FLD_L(ir_idx) = stride.fld; 02060 IR_IDX_L(ir_idx) = stride.idx; 02061 IR_LINE_NUM_L(ir_idx) = BD_LINE_NUM(bd_idx); 02062 IR_COL_NUM_L(ir_idx) = BD_COLUMN_NUM(bd_idx); 02063 IR_FLD_R(ir_idx) = extent_fld; 02064 IR_IDX_R(ir_idx) = extent_idx; 02065 IR_LINE_NUM_R(ir_idx) = BD_LINE_NUM(bd_idx); 02066 IR_COL_NUM_R(ir_idx) = BD_COLUMN_NUM(bd_idx); 02067 02068 if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) { 02069 IR_OPR(ir_idx) = Symbolic_Mult_Opr; 02070 stride.fld = AT_Tbl_Idx; 02071 stride.idx = gen_compiler_tmp(line, column, Priv, TRUE); 02072 02073 ATD_TYPE_IDX(stride.idx) = SA_INTEGER_DEFAULT_TYPE; 02074 ATD_FLD(stride.idx) = IR_Tbl_Idx; 02075 ATD_TMP_IDX(stride.idx) = ir_idx; 02076 ATD_SYMBOLIC_CONSTANT(stride.idx) = TRUE; 02077 } 02078 else { 02079 OPND_FLD(opnd) = IR_Tbl_Idx; 02080 OPND_IDX(opnd) = ir_idx; 02081 OPND_LINE_NUM(opnd) = stmt_start_line; 02082 OPND_COL_NUM(opnd) = stmt_start_col; 02083 02084 sh_idx = ntr_sh_tbl(); 02085 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 02086 SH_COMPILER_GEN(sh_idx) = TRUE; 02087 SH_P2_SKIP_ME(sh_idx) = TRUE; 02088 SH_GLB_LINE(sh_idx) = stmt_start_line; 02089 SH_COL_NUM(sh_idx) = stmt_start_col; 02090 02091 expr_desc.rank = 0; 02092 xref_state = CIF_No_Usage_Rec; 02093 02094 expr_semantics(&opnd, &expr_desc); 02095 02096 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 02097 stride.fld = CN_Tbl_Idx; 02098 stride.idx = OPND_IDX(opnd); 02099 FREE_SH_NODE(sh_idx); 02100 } 02101 else { 02102 02103 if (!is_interface) { 02104 02105 /* Stride must be non-constant, if extent is non-constant */ 02106 02107 if (extent_entry_idx != NULL_IDX) { 02108 stride_entry_idx = merge_entry_lists(stride_entry_idx, 02109 extent_entry_idx); 02110 length_entry_idx = merge_entry_lists(length_entry_idx, 02111 extent_entry_idx); 02112 } 02113 } 02114 02115 stride.fld = AT_Tbl_Idx; 02116 stride.idx = ntr_bnds_sh_tmp_list(&opnd, 02117 stride_entry_idx, 02118 (is_interface) ? NULL_IDX: sh_idx, 02119 FALSE, 02120 SA_INTEGER_DEFAULT_TYPE); 02121 } 02122 } 02123 02124 NTR_IR_TBL(mult_idx); /* Create length = extent * extent */ 02125 IR_LINE_NUM(mult_idx) = BD_LINE_NUM(bd_idx); 02126 IR_COL_NUM(mult_idx) = BD_COLUMN_NUM(bd_idx); 02127 02128 if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) { 02129 IR_OPR(mult_idx) = Symbolic_Mult_Opr; 02130 } 02131 else { 02132 IR_OPR(mult_idx) = Mult_Opr; 02133 } 02134 02135 IR_TYPE_IDX(mult_idx) = SA_INTEGER_DEFAULT_TYPE; 02136 IR_IDX_R(len_ir_idx) = mult_idx; 02137 IR_FLD_R(len_ir_idx) = IR_Tbl_Idx; 02138 IR_LINE_NUM_R(len_ir_idx) = BD_LINE_NUM(bd_idx); 02139 IR_COL_NUM_R(len_ir_idx) = BD_COLUMN_NUM(bd_idx); 02140 IR_IDX_L(mult_idx) = extent_idx; 02141 IR_FLD_L(mult_idx) = extent_fld; 02142 IR_LINE_NUM_L(mult_idx) = BD_LINE_NUM(bd_idx); 02143 IR_COL_NUM_L(mult_idx) = BD_COLUMN_NUM(bd_idx); 02144 len_ir_idx = mult_idx; 02145 } 02146 else if (dim == 1) { 02147 02148 /* Last dimension is the only dimension, so length = xtent */ 02149 02150 BD_LEN_FLD(bd_idx) = extent_fld; 02151 BD_LEN_IDX(bd_idx) = extent_idx; 02152 length_entry_idx = extent_entry_idx; 02153 stride_entry_idx = merge_entry_lists(stride_entry_idx, 02154 extent_entry_idx); 02155 extent_entry_idx = NULL_IDX; /* List now pointed by length.. */ 02156 02157 if (length_entry_idx != NULL_IDX) { /* Alt entries - need tmp = 0 */ 02158 gen_tmp_eq_zero_ir(extent_idx); 02159 } 02160 } 02161 02162 /* Last dimension */ 02163 02164 else if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) { 02165 IR_IDX_R(len_ir_idx) = extent_idx; 02166 IR_FLD_R(len_ir_idx) = extent_fld; 02167 IR_LINE_NUM_R(len_ir_idx) = BD_LINE_NUM(bd_idx); 02168 IR_COL_NUM_R(len_ir_idx) = BD_COLUMN_NUM(bd_idx); 02169 OPND_FLD(opnd) = IR_FLD_R(BD_LEN_IDX(bd_idx)); 02170 OPND_IDX(opnd) = IR_IDX_R(BD_LEN_IDX(bd_idx)); 02171 02172 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 02173 BD_LEN_IDX(bd_idx) = gen_compiler_tmp(line, column, Priv, TRUE); 02174 02175 ATD_TYPE_IDX(BD_LEN_IDX(bd_idx)) = SA_INTEGER_DEFAULT_TYPE; 02176 ATD_FLD(BD_LEN_IDX(bd_idx)) = OPND_FLD(opnd); 02177 ATD_TMP_IDX(BD_LEN_IDX(bd_idx)) = OPND_IDX(opnd); 02178 02179 ATD_SYMBOLIC_CONSTANT(BD_LEN_IDX(bd_idx)) = TRUE; 02180 } 02181 else { 02182 IR_IDX_R(len_ir_idx) = extent_idx; 02183 IR_FLD_R(len_ir_idx) = extent_fld; 02184 IR_LINE_NUM_R(len_ir_idx) = BD_LINE_NUM(bd_idx); 02185 IR_COL_NUM_R(len_ir_idx) = BD_COLUMN_NUM(bd_idx); 02186 OPND_FLD(opnd) = IR_FLD_R(BD_LEN_IDX(bd_idx)); 02187 OPND_IDX(opnd) = IR_IDX_R(BD_LEN_IDX(bd_idx)); 02188 OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx); 02189 OPND_COL_NUM(opnd) = BD_COLUMN_NUM(bd_idx); 02190 02191 sh_idx = ntr_sh_tbl(); 02192 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 02193 SH_COMPILER_GEN(sh_idx) = TRUE; 02194 SH_P2_SKIP_ME(sh_idx) = TRUE; 02195 SH_GLB_LINE(sh_idx) = stmt_start_line; 02196 SH_COL_NUM(sh_idx) = stmt_start_col; 02197 02198 /* expr_semantics needs curr_stmt_sh_idx set to something valid. */ 02199 /* It does not need SH_IR_IDX(curr_stmt_sh_idx) set to something. */ 02200 02201 expr_desc.rank = 0; 02202 xref_state = CIF_No_Usage_Rec; 02203 02204 # if defined(_CHECK_MAX_MEMORY) 02205 02206 if (!target_t3e) { 02207 issue_overflow_msg_719 = FALSE; 02208 } 02209 # endif 02210 02211 if (!expr_semantics(&opnd, &expr_desc)) { 02212 02213 if (need_to_issue_719) { 02214 02215 /* We have overflowed - Reattempt with a bigger int type */ 02216 02217 if (OPND_FLD(opnd) == IR_Tbl_Idx) { 02218 IR_TYPE_IDX(OPND_IDX(opnd)) = SA_INTEGER_DEFAULT_TYPE; 02219 02220 switch (IR_FLD_L(OPND_IDX(opnd))) { 02221 case AT_Tbl_Idx: 02222 type = TYP_LINEAR(ATD_TYPE_IDX(IR_IDX_L(OPND_IDX(opnd)))); 02223 break; 02224 02225 case IR_Tbl_Idx: 02226 type = TYP_LINEAR(IR_TYPE_IDX(IR_IDX_L(OPND_IDX(opnd)))); 02227 break; 02228 02229 case CN_Tbl_Idx: 02230 type = TYP_LINEAR(CN_TYPE_IDX(IR_IDX_L(OPND_IDX(opnd)))); 02231 break; 02232 } 02233 02234 if (type < SA_INTEGER_DEFAULT_TYPE) { 02235 NTR_IR_TBL(cvrt_idx); 02236 IR_OPR(cvrt_idx) = Cvrt_Opr; 02237 IR_TYPE_IDX(cvrt_idx) = SA_INTEGER_DEFAULT_TYPE; 02238 IR_LINE_NUM(cvrt_idx) = BD_LINE_NUM(bd_idx); 02239 IR_COL_NUM(cvrt_idx) = BD_COLUMN_NUM(bd_idx); 02240 COPY_OPND(IR_OPND_L(cvrt_idx), IR_OPND_L(OPND_IDX(opnd))); 02241 IR_FLD_L(OPND_IDX(opnd)) = IR_Tbl_Idx; 02242 IR_IDX_L(OPND_IDX(opnd)) = cvrt_idx; 02243 } 02244 02245 switch (IR_FLD_R(OPND_IDX(opnd))) { 02246 case AT_Tbl_Idx: 02247 type = TYP_LINEAR(ATD_TYPE_IDX(IR_IDX_R(OPND_IDX(opnd)))); 02248 break; 02249 02250 case IR_Tbl_Idx: 02251 type = TYP_LINEAR(IR_TYPE_IDX(IR_IDX_R(OPND_IDX(opnd)))); 02252 break; 02253 02254 case CN_Tbl_Idx: 02255 type = TYP_LINEAR(CN_TYPE_IDX(IR_IDX_R(OPND_IDX(opnd)))); 02256 break; 02257 } 02258 02259 if (type < SA_INTEGER_DEFAULT_TYPE) { 02260 NTR_IR_TBL(cvrt_idx); 02261 IR_OPR(cvrt_idx) = Cvrt_Opr; 02262 IR_TYPE_IDX(cvrt_idx) = SA_INTEGER_DEFAULT_TYPE; 02263 IR_LINE_NUM(cvrt_idx) = BD_LINE_NUM(bd_idx); 02264 IR_COL_NUM(cvrt_idx) = BD_COLUMN_NUM(bd_idx); 02265 COPY_OPND(IR_OPND_L(cvrt_idx), IR_OPND_R(OPND_IDX(opnd))); 02266 IR_FLD_R(OPND_IDX(opnd)) = IR_Tbl_Idx; 02267 IR_IDX_R(OPND_IDX(opnd)) = cvrt_idx; 02268 } 02269 need_to_issue_719 = FALSE; 02270 } 02271 02272 if (!expr_semantics(&opnd, &expr_desc)) { 02273 02274 if (!target_t3e) { 02275 AT_DCL_ERR(attr_idx) = TRUE; 02276 } 02277 } 02278 } 02279 else if (!target_t3e) { 02280 AT_DCL_ERR(attr_idx) = TRUE; 02281 } 02282 02283 if (need_to_issue_719) { 02284 need_to_issue_719 = FALSE; 02285 AT_DCL_ERR(attr_idx) = TRUE; 02286 ISSUE_STORAGE_SIZE_EXCEEDED_MSG(attr_idx, Error); 02287 } 02288 } 02289 02290 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 02291 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx; 02292 BD_LEN_IDX(bd_idx) = OPND_IDX(opnd); 02293 FREE_SH_NODE(sh_idx); 02294 } 02295 else { 02296 02297 if (!is_interface) { 02298 02299 if (extent_entry_idx != NULL_IDX) { 02300 stride_entry_idx = merge_entry_lists(stride_entry_idx, 02301 extent_entry_idx); 02302 length_entry_idx = merge_entry_lists(length_entry_idx, 02303 extent_entry_idx); 02304 } 02305 } 02306 02307 length_idx = ntr_bnds_sh_tmp_list(&opnd, 02308 length_entry_idx, 02309 (is_interface) ? NULL_IDX:sh_idx, 02310 TRUE, 02311 SA_INTEGER_DEFAULT_TYPE); 02312 BD_LEN_IDX(bd_idx) = length_idx; 02313 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 02314 } 02315 } 02316 } 02317 02318 /* After the dimensions are processed, stride_entry_idx contains a list */ 02319 /* of all bad entry points, for the array - including all extents and */ 02320 /* type information. Stride is calculated from the (previous dimension's */ 02321 /* extent) * (previous dimension's stride). A stride_entry_idx is made */ 02322 /* for the last dimension, even though actual stride isn't calculated for */ 02323 /* this dimension. */ 02324 02325 if (stride_entry_idx != NULL_IDX) { 02326 entry_count = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1; 02327 02328 if (length_entry_idx != NULL_IDX && 02329 entry_count == AL_ENTRY_COUNT(length_entry_idx)) { 02330 02331 /* Error if problem with lower and/or upper bounds coming in */ 02332 /* different entry points. Bounds for this array declaration */ 02333 /* cannot be calculated at any entry point, because dummy args */ 02334 /* used in the expression do not enter at all the same points. */ 02335 02336 PRINTMSG(AT_DEF_LINE(attr_idx), 660, Error, 02337 AT_DEF_COLUMN(attr_idx), 02338 AT_OBJ_NAME_PTR(attr_idx)); 02339 AT_DCL_ERR(attr_idx) = TRUE; 02340 } 02341 else if (entry_count == AL_ENTRY_COUNT(stride_entry_idx)) { 02342 02343 /* If the length is okay, but there's a problem with the */ 02344 /* stride, that means that it's a character and a bound */ 02345 /* forming the char length, doesn't enter the same as all */ 02346 /* the dimension bounds. Bounds for this array declaration */ 02347 /* cannot be calculated at any entry point, because dummy args */ 02348 /* used in the expression de not enter at all the same points. */ 02349 02350 PRINTMSG(AT_DEF_LINE(attr_idx), 661, Error, 02351 AT_DEF_COLUMN(attr_idx), 02352 AT_OBJ_NAME_PTR(attr_idx)); 02353 AT_DCL_ERR(attr_idx) = TRUE; 02354 } 02355 else if (entry_list != NULL_IDX) { 02356 stride_entry_count = merge_entry_list_count(stride_entry_idx, 02357 entry_list); 02358 02359 if (entry_count == stride_entry_count) { 02360 02361 /* This array and its bound variables do not enter at the */ 02362 /* same entry point. */ 02363 02364 PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error, 02365 AT_DEF_COLUMN(attr_idx), 02366 AT_OBJ_NAME_PTR(attr_idx)); 02367 AT_DCL_ERR(attr_idx) = TRUE; 02368 } 02369 } 02370 } 02371 02372 NEXT: 02373 02374 /* Every array must have the following semantic checks. So even if the */ 02375 /* bounds for the array are already resolved, it still must get these */ 02376 /* checks. */ 02377 02378 if (BD_ARRAY_CLASS(bd_idx) == Explicit_Shape && 02379 BD_ARRAY_SIZE(bd_idx) == Constant_Size) { 02380 02381 /* Check so the item does not exceed max storage size. Do it here, */ 02382 /* even though it is also done in final_decl_semantics because this */ 02383 /* may be a constant array involved in data or parameter statements or */ 02384 /* it may get folded. */ 02385 02386 stor_bit_size_of(attr_idx, TRUE, TRUE); 02387 } 02388 else if (need_const_array) { 02389 02390 /* Need an explicit_shape constant size array for parameter processing */ 02391 /* An error will be issued in PARAMETER processing if this isn't a */ 02392 /* constant size array. */ 02393 02394 /* This if block is intentionally blank. */ 02395 } 02396 else { 02397 02398 if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) { 02399 fnd_semantic_err(Obj_Sym_Constant_Arr, 02400 AT_DEF_LINE(attr_idx), 02401 AT_DEF_COLUMN(attr_idx), 02402 attr_idx, 02403 TRUE); 02404 02405 if (ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX) { 02406 SB_BLK_HAS_NPES(ATD_STOR_BLK_IDX(attr_idx)) = TRUE; 02407 } 02408 02409 if (cmd_line_flags.malleable) { 02410 PRINTMSG(AT_DEF_LINE(attr_idx), 1232, Error, 02411 AT_DEF_COLUMN(attr_idx)); 02412 } 02413 } 02414 02415 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size) { 02416 02417 /* This is called by PARAMETER processing. This must be an explicit */ 02418 /* shape constant size array. PARAMETER processing will issue the */ 02419 /* error. If this is needed elsewhere, it will come through again */ 02420 /* during decl_semantics. */ 02421 02422 if (ATD_CLASS(attr_idx) == CRI__Pointee) { 02423 02424 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 02425 AT_DCL_ERR(attr_idx) = TRUE; 02426 PRINTMSG(AT_DEF_LINE(attr_idx), 1419, Error, 02427 AT_DEF_COLUMN(attr_idx), 02428 AT_OBJ_NAME_PTR(attr_idx)); 02429 } 02430 } 02431 else if (ATD_CLASS(attr_idx) != Dummy_Argument) { 02432 02433 /* Must be dummy arg or CRI pointee. */ 02434 02435 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 02436 AT_DCL_ERR(attr_idx) = TRUE; 02437 PRINTMSG(AT_DEF_LINE(attr_idx), 501, Error, 02438 AT_DEF_COLUMN(attr_idx), 02439 AT_OBJ_NAME_PTR(attr_idx)); 02440 } 02441 else { 02442 AT_DCL_ERR(attr_idx) = TRUE; 02443 PRINTMSG(AT_DEF_LINE(attr_idx), 500, Error, 02444 AT_DEF_COLUMN(attr_idx), 02445 AT_OBJ_NAME_PTR(attr_idx)); 02446 } 02447 } 02448 02449 # if defined(_TARGET_OS_MAX) 02450 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) { 02451 AT_DCL_ERR(attr_idx) = TRUE; 02452 PRINTMSG(BD_LINE_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 1583, Error, 02453 BD_COLUMN_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 02454 "co-array dimensions", 02455 "assumed-size arrays"); 02456 } 02457 # endif 02458 } 02459 else if (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) { 02460 fnd_semantic_err(Obj_Var_Len_Arr, 02461 AT_DEF_LINE(attr_idx), 02462 AT_DEF_COLUMN(attr_idx), 02463 attr_idx, 02464 TRUE); 02465 02466 if (ATD_CLASS(attr_idx) == Variable) { 02467 02468 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) { 02469 AT_DCL_ERR(attr_idx) = TRUE; 02470 PRINTMSG(AT_DEF_LINE(attr_idx), 1577, Error, 02471 AT_DEF_COLUMN(attr_idx), 02472 AT_OBJ_NAME_PTR(attr_idx)); 02473 } 02474 else { 02475 ATD_AUTOMATIC(attr_idx) = TRUE; 02476 } 02477 02478 if (stride_entry_idx != NULL_IDX) { 02479 PRINTMSG(AT_DEF_LINE(attr_idx), 1046, Caution, 02480 AT_DEF_COLUMN(attr_idx), 02481 AT_OBJ_NAME_PTR(attr_idx)); 02482 } 02483 } 02484 } 02485 } 02486 02487 02488 EXIT: 02489 02490 if (stride_entry_idx != NULL_IDX) { 02491 free_attr_list(stride_entry_idx); 02492 } 02493 02494 if (length_entry_idx != NULL_IDX) { 02495 free_attr_list(length_entry_idx); 02496 } 02497 02498 if (ATD_CLASS(attr_idx) == Function_Result) { 02499 ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) = entry_list; 02500 } 02501 else { 02502 ATD_NO_ENTRY_LIST(attr_idx) = entry_list; 02503 } 02504 02505 TRACE (Func_Exit, "array_dim_resolution", NULL); 02506 02507 return; 02508 02509 } /* array_dim_resolution */ 02510 02511 /******************************************************************************\ 02512 |* *| 02513 |* Description: *| 02514 |* This routine resolves the lower and upper bounds to a constant or a *| 02515 |* temp. Calculate the extent and stride multiplier for each dimension. *| 02516 |* *| 02517 |* Input parameters: *| 02518 |* attr_idx -> Index to attribute for array. *| 02519 |* *| 02520 |* Output parameters: *| 02521 |* NONE *| 02522 |* *| 02523 |* Returns: *| 02524 |* NONE *| 02525 |* *| 02526 \******************************************************************************/ 02527 02528 void pe_array_dim_resolution(int attr_idx) 02529 02530 { 02531 bd_array_size_type array_size_type; 02532 int at_idx; 02533 int bd_idx; 02534 int dim; 02535 int entry_count; 02536 int entry_list; 02537 expr_arg_type expr_desc; 02538 int extent_entry_idx = NULL_IDX; 02539 fld_type extent_fld; 02540 int extent_idx; 02541 int ir_idx; 02542 boolean is_interface; 02543 int len_ir_idx; 02544 int length_idx; 02545 int length_entry_idx = NULL_IDX; 02546 int mult_idx; 02547 int next_ir_idx; 02548 opnd_type opnd; 02549 int sh_idx; 02550 int stride_entry_idx = NULL_IDX; 02551 int stride_entry_count; 02552 size_offset_type stride; 02553 02554 02555 TRACE (Func_Entry, "pe_array_dim_resolution", NULL); 02556 02557 is_interface = SCP_IS_INTERFACE(curr_scp_idx); 02558 bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 02559 02560 if (ATD_CLASS(attr_idx) == Function_Result) { 02561 entry_list = ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)); 02562 } 02563 else { 02564 entry_list = ATD_NO_ENTRY_LIST(attr_idx); 02565 } 02566 02567 if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape || 02568 BD_ARRAY_CLASS(bd_idx) == Deferred_Shape1 ) { 02569 02570 if (! ATD_ALLOCATABLE(attr_idx)) { 02571 PRINTMSG(AT_DEF_LINE(attr_idx), 1587, Error, AT_DEF_COLUMN(attr_idx), 02572 AT_OBJ_NAME_PTR(attr_idx)); 02573 BD_DCL_ERR(bd_idx) = TRUE; 02574 AT_DCL_ERR(attr_idx) = TRUE; 02575 } 02576 BD_RESOLVED(bd_idx) = TRUE; 02577 BD_ARRAY_SIZE(bd_idx) = Unknown_Size; 02578 BD_ARRAY_CLASS(bd_idx)= Deferred_Shape1; 02579 02580 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 02581 BD_LB_FLD(bd_idx,dim) = CN_Tbl_Idx; 02582 BD_LB_IDX(bd_idx,dim) = CN_INTEGER_ONE_IDX; 02583 BD_UB_FLD(bd_idx,dim) = NO_Tbl_Idx; 02584 BD_XT_FLD(bd_idx,dim) = NO_Tbl_Idx; 02585 } 02586 02587 BD_LEN_FLD(bd_idx) = NO_Tbl_Idx; 02588 02589 goto EXIT; 02590 } 02591 02592 /* If this array bounds entry has already been resolved, skip the section */ 02593 /* that calculates the extent, length, and stride multiplier. */ 02594 /* The only array entries that are shared are of the same type. Each attr */ 02595 /* will have to calculate it's own automatic stuff. */ 02596 02597 if (BD_RESOLVED(bd_idx)) { 02598 goto NEXT; 02599 } 02600 02601 array_size_type = Constant_Size; 02602 02603 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 02604 02605 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 02606 02607 if (ATD_CLASS(BD_LB_IDX(bd_idx, dim)) == Constant) { 02608 BD_LB_FLD(bd_idx, dim) = CN_Tbl_Idx; 02609 BD_LB_IDX(bd_idx, dim) = ATD_CONST_IDX(BD_LB_IDX(bd_idx, dim)); 02610 } 02611 else if (ATD_SYMBOLIC_CONSTANT(BD_LB_IDX(bd_idx, dim))) { 02612 array_size_type = Symbolic_Constant_Size; 02613 } 02614 else { 02615 array_size_type = Var_Len_Array; 02616 } 02617 } 02618 02619 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 02620 02621 if (ATD_CLASS(BD_UB_IDX(bd_idx, dim)) == Constant) { 02622 BD_UB_FLD(bd_idx, dim) = CN_Tbl_Idx; 02623 BD_UB_IDX(bd_idx, dim) = ATD_CONST_IDX(BD_UB_IDX(bd_idx, dim)); 02624 } 02625 else if (ATD_SYMBOLIC_CONSTANT(BD_UB_IDX(bd_idx, dim))) { 02626 02627 if (array_size_type != Var_Len_Array) { 02628 array_size_type = Symbolic_Constant_Size; 02629 } 02630 } 02631 else { 02632 array_size_type = Var_Len_Array; 02633 } 02634 } 02635 } 02636 02637 /* fzhao if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size ) { */ 02638 02639 if (BD_ARRAY_CLASS(bd_idx) != Assumed_Size ) { 02640 PRINTMSG(AT_DEF_LINE(attr_idx),1576,Error, 02641 AT_DEF_COLUMN(attr_idx)); 02642 AT_DCL_ERR(attr_idx) = TRUE; 02643 02644 /* This is called by PARAMETER processing. This must be an explicit */ 02645 /* shape constant size array. PARAMETER processing will issue the */ 02646 /* error. If this is needed elsewhere, it will come through again */ 02647 /* during decl_semantics. */ 02648 02649 BD_ARRAY_SIZE(bd_idx) = array_size_type; 02650 } 02651 else { 02652 BD_ARRAY_SIZE(bd_idx) = array_size_type; 02653 02654 if (array_size_type == Var_Len_Array) { 02655 02656 BD_ARRAY_SIZE(bd_idx) = Var_Len_Array; 02657 02658 /* This is called by PARAMETER processing. This must be an explicit */ 02659 /* shape constant size array. PARAMETER processing will issue the */ 02660 /* error. If this is needed elsewhere, it will come through again */ 02661 /* during decl_semantics. */ 02662 02663 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Function && 02664 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Subroutine) { 02665 PRINTMSG(AT_DEF_LINE(attr_idx), 131, Error, 02666 AT_DEF_COLUMN(attr_idx), 02667 AT_OBJ_NAME_PTR(attr_idx)); 02668 BD_DCL_ERR(bd_idx) = TRUE; 02669 } 02670 } 02671 } 02672 02673 BD_RESOLVED(bd_idx) = TRUE; 02674 02675 /* stride for first pe dim is always 1 */ 02676 02677 stride.fld = CN_Tbl_Idx; 02678 stride.idx = CN_INTEGER_ONE_IDX; 02679 02680 stride_entry_idx = NULL_IDX; 02681 02682 NTR_IR_TBL(len_ir_idx); 02683 IR_TYPE_IDX(len_ir_idx) = INTEGER_DEFAULT_TYPE; 02684 02685 BD_LEN_IDX(bd_idx) = len_ir_idx; /* Save this so it can be folded */ 02686 BD_LEN_FLD(bd_idx) = IR_Tbl_Idx; 02687 length_entry_idx = NULL_IDX; 02688 02689 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 02690 BD_SM_FLD(bd_idx, dim) = stride.fld; 02691 BD_SM_IDX(bd_idx, dim) = stride.idx; 02692 02693 if (extent_entry_idx != NULL_IDX) { 02694 free_attr_list(extent_entry_idx); 02695 extent_entry_idx = NULL_IDX; 02696 } 02697 02698 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 02699 at_idx = BD_LB_IDX(bd_idx, dim); 02700 02701 if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) { 02702 extent_entry_idx = merge_entry_lists(NULL_IDX, 02703 ATD_NO_ENTRY_LIST(at_idx)); 02704 } 02705 } 02706 02707 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 02708 at_idx = BD_UB_IDX(bd_idx, dim); 02709 02710 if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) { 02711 extent_entry_idx = merge_entry_lists(extent_entry_idx, 02712 ATD_NO_ENTRY_LIST(at_idx)); 02713 } 02714 } 02715 02716 if (BD_LB_FLD(bd_idx, dim) == CN_Tbl_Idx && 02717 fold_relationals(BD_LB_IDX(bd_idx, dim), 02718 CN_INTEGER_ONE_IDX, 02719 Eq_Opr)) { 02720 02721 /* If the lb is a one, just use the ub for the extent */ 02722 02723 extent_fld = BD_UB_FLD(bd_idx, dim); 02724 extent_idx = BD_UB_IDX(bd_idx, dim); 02725 } 02726 else { 02727 NTR_IR_TBL(ir_idx); /* Create 1 - lower */ 02728 IR_OPR(ir_idx) = Minus_Opr; 02729 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 02730 IR_FLD_L(ir_idx) = CN_Tbl_Idx; 02731 IR_IDX_L(ir_idx) = CN_INTEGER_ONE_IDX; 02732 IR_LINE_NUM_L(ir_idx) = BD_LINE_NUM(bd_idx); 02733 IR_COL_NUM_L(ir_idx) = BD_COLUMN_NUM(bd_idx); 02734 IR_FLD_R(ir_idx) = BD_LB_FLD(bd_idx, dim); 02735 IR_IDX_R(ir_idx) = BD_LB_IDX(bd_idx, dim); 02736 IR_LINE_NUM_R(ir_idx) = BD_LINE_NUM(bd_idx); 02737 IR_COL_NUM_R(ir_idx) = BD_COLUMN_NUM(bd_idx); 02738 IR_LINE_NUM(ir_idx) = BD_LINE_NUM(bd_idx); 02739 IR_COL_NUM(ir_idx) = BD_COLUMN_NUM(bd_idx); 02740 02741 NTR_IR_TBL(next_ir_idx); /* Upper + (1 - lower) */ 02742 IR_OPR(next_ir_idx) = Plus_Opr; 02743 IR_TYPE_IDX(next_ir_idx) = INTEGER_DEFAULT_TYPE; 02744 IR_IDX_L(next_ir_idx) = BD_UB_IDX(bd_idx, dim); 02745 IR_FLD_L(next_ir_idx) = BD_UB_FLD(bd_idx, dim); 02746 IR_LINE_NUM_L(next_ir_idx) = BD_LINE_NUM(bd_idx); 02747 IR_COL_NUM_L(next_ir_idx) = BD_COLUMN_NUM(bd_idx); 02748 IR_FLD_R(next_ir_idx) = IR_Tbl_Idx; 02749 IR_IDX_R(next_ir_idx) = ir_idx; 02750 IR_LINE_NUM_R(next_ir_idx) = BD_LINE_NUM(bd_idx); 02751 IR_COL_NUM_R(next_ir_idx) = BD_COLUMN_NUM(bd_idx); 02752 IR_LINE_NUM(next_ir_idx) = BD_LINE_NUM(bd_idx); 02753 IR_COL_NUM(next_ir_idx) = BD_COLUMN_NUM(bd_idx); 02754 02755 if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) { 02756 IR_OPR(next_ir_idx) = Symbolic_Plus_Opr; 02757 IR_OPR(ir_idx) = Symbolic_Minus_Opr; 02758 extent_idx = gen_compiler_tmp(BD_LINE_NUM(bd_idx), 02759 BD_COLUMN_NUM(bd_idx), 02760 Priv, TRUE); 02761 extent_fld = AT_Tbl_Idx; 02762 02763 ATD_SYMBOLIC_CONSTANT(extent_idx) = TRUE; 02764 ATD_TYPE_IDX(extent_idx) = CG_INTEGER_DEFAULT_TYPE; 02765 ATD_FLD(extent_idx) = IR_Tbl_Idx; 02766 ATD_TMP_IDX(extent_idx) = next_ir_idx; 02767 02768 02769 /* KAY - Some of this may be folded if they are both not */ 02770 /* symbolic constants. */ 02771 } 02772 else { 02773 02774 OPND_FLD(opnd) = IR_Tbl_Idx; 02775 OPND_IDX(opnd) = next_ir_idx; 02776 OPND_LINE_NUM(opnd) = stmt_start_line; 02777 OPND_COL_NUM(opnd) = stmt_start_col; 02778 02779 sh_idx = ntr_sh_tbl(); 02780 SH_GLB_LINE(sh_idx) = stmt_start_line; 02781 SH_COL_NUM(sh_idx) = stmt_start_col; 02782 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 02783 SH_COMPILER_GEN(sh_idx) = TRUE; 02784 SH_P2_SKIP_ME(sh_idx) = TRUE; 02785 02786 expr_desc.rank = 0; 02787 xref_state = CIF_No_Usage_Rec; 02788 02789 /* This is in terms of tmps - so it will never */ 02790 /* generate more than one statement. */ 02791 02792 if (!expr_semantics(&opnd, &expr_desc)) { 02793 PRINTMSG(AT_DEF_LINE(attr_idx), 951, Error, 02794 AT_DEF_COLUMN(attr_idx), 02795 dim, 02796 AT_OBJ_NAME_PTR(attr_idx)); 02797 AT_DCL_ERR(attr_idx) = TRUE; 02798 } 02799 02800 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 02801 extent_fld = CN_Tbl_Idx; 02802 extent_idx = OPND_IDX(opnd); 02803 FREE_SH_NODE(sh_idx); 02804 } 02805 else { 02806 extent_fld = AT_Tbl_Idx; 02807 extent_idx = ntr_bnds_sh_tmp_list(&opnd, 02808 extent_entry_idx, 02809 (is_interface) ? NULL_IDX:sh_idx, 02810 FALSE, 02811 SA_INTEGER_DEFAULT_TYPE); 02812 } 02813 } 02814 } 02815 02816 if (extent_fld == CN_Tbl_Idx) { 02817 02818 if (compare_cn_and_value(extent_idx, 0, Lt_Opr)) { 02819 extent_idx = CN_INTEGER_ZERO_IDX; 02820 } 02821 } 02822 else { /* Generate tmp = max(0, extent) */ 02823 02824 OPND_FLD(opnd) = extent_fld; 02825 OPND_IDX(opnd) = extent_idx; 02826 OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx); 02827 OPND_COL_NUM(opnd) = BD_COLUMN_NUM(bd_idx); 02828 02829 gen_tmp_equal_max_zero(&opnd, 02830 INTEGER_DEFAULT_TYPE, 02831 extent_entry_idx, 02832 (BD_ARRAY_SIZE(bd_idx)==Symbolic_Constant_Size), 02833 is_interface); 02834 02835 extent_fld = OPND_FLD(opnd); 02836 extent_idx = OPND_IDX(opnd); 02837 } 02838 02839 BD_XT_FLD(bd_idx, dim) = extent_fld; 02840 BD_XT_IDX(bd_idx, dim) = extent_idx; 02841 02842 /* STRIDE = STRIDE * (EXTENT of previous dimension) */ 02843 /* Fix stride for next dimension. */ 02844 /* Calculate length. */ 02845 02846 if (dim < BD_RANK(bd_idx)) { 02847 NTR_IR_TBL(ir_idx); /* Create Stride * Extent */ 02848 IR_OPR(ir_idx) = Mult_Opr; 02849 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 02850 IR_LINE_NUM(ir_idx) = BD_LINE_NUM(bd_idx); 02851 IR_COL_NUM(ir_idx) = BD_COLUMN_NUM(bd_idx); 02852 IR_FLD_L(ir_idx) = stride.fld; 02853 IR_IDX_L(ir_idx) = stride.idx; 02854 IR_LINE_NUM_L(ir_idx) = BD_LINE_NUM(bd_idx); 02855 IR_COL_NUM_L(ir_idx) = BD_COLUMN_NUM(bd_idx); 02856 IR_FLD_R(ir_idx) = extent_fld; 02857 IR_IDX_R(ir_idx) = extent_idx; 02858 IR_LINE_NUM_R(ir_idx) = BD_LINE_NUM(bd_idx); 02859 IR_COL_NUM_R(ir_idx) = BD_COLUMN_NUM(bd_idx); 02860 02861 if ((extent_fld == AT_Tbl_Idx && ATD_SYMBOLIC_CONSTANT(extent_idx)) || 02862 (stride.fld == AT_Tbl_Idx && ATD_SYMBOLIC_CONSTANT(stride.idx))) { 02863 IR_OPR(ir_idx) = Symbolic_Mult_Opr; 02864 stride.fld = AT_Tbl_Idx; 02865 stride.idx = gen_compiler_tmp(BD_LINE_NUM(bd_idx), 02866 BD_COLUMN_NUM(bd_idx), 02867 Priv, TRUE); 02868 02869 ATD_TYPE_IDX(stride.idx) = CG_INTEGER_DEFAULT_TYPE; 02870 ATD_FLD(stride.idx) = IR_Tbl_Idx; 02871 ATD_TMP_IDX(stride.idx) = ir_idx; 02872 ATD_SYMBOLIC_CONSTANT(stride.idx) = TRUE; 02873 } 02874 else { 02875 OPND_FLD(opnd) = IR_Tbl_Idx; 02876 OPND_IDX(opnd) = ir_idx; 02877 OPND_LINE_NUM(opnd) = stmt_start_line; 02878 OPND_COL_NUM(opnd) = stmt_start_col; 02879 02880 sh_idx = ntr_sh_tbl(); 02881 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 02882 SH_COMPILER_GEN(sh_idx) = TRUE; 02883 SH_P2_SKIP_ME(sh_idx) = TRUE; 02884 SH_GLB_LINE(sh_idx) = stmt_start_line; 02885 SH_COL_NUM(sh_idx) = stmt_start_col; 02886 02887 expr_desc.rank = 0; 02888 xref_state = CIF_No_Usage_Rec; 02889 02890 expr_semantics(&opnd, &expr_desc); 02891 02892 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 02893 stride.fld = CN_Tbl_Idx; 02894 stride.idx = OPND_IDX(opnd); 02895 FREE_SH_NODE(sh_idx); 02896 } 02897 else { 02898 02899 if (!is_interface) { 02900 02901 /* Stride must be non-constant, if extent is non-constant */ 02902 02903 if (extent_entry_idx != NULL_IDX) { 02904 stride_entry_idx = merge_entry_lists(stride_entry_idx, 02905 extent_entry_idx); 02906 length_entry_idx = merge_entry_lists(length_entry_idx, 02907 extent_entry_idx); 02908 } 02909 } 02910 02911 stride.fld = AT_Tbl_Idx; 02912 stride.idx = ntr_bnds_sh_tmp_list(&opnd, 02913 stride_entry_idx, 02914 is_interface ? NULL_IDX:sh_idx, 02915 FALSE, 02916 SA_INTEGER_DEFAULT_TYPE); 02917 } 02918 } 02919 02920 NTR_IR_TBL(mult_idx); /* Create length = extent * extent */ 02921 IR_LINE_NUM(mult_idx) = BD_LINE_NUM(bd_idx); 02922 IR_COL_NUM(mult_idx) = BD_COLUMN_NUM(bd_idx); 02923 IR_OPR(mult_idx) = (extent_fld == AT_Tbl_Idx && 02924 ATD_SYMBOLIC_CONSTANT(extent_idx)) ? 02925 Symbolic_Mult_Opr : Mult_Opr; 02926 IR_TYPE_IDX(mult_idx) = INTEGER_DEFAULT_TYPE; 02927 IR_IDX_R(len_ir_idx) = mult_idx; 02928 IR_FLD_R(len_ir_idx) = IR_Tbl_Idx; 02929 IR_LINE_NUM_R(len_ir_idx) = BD_LINE_NUM(bd_idx); 02930 IR_COL_NUM_R(len_ir_idx) = BD_COLUMN_NUM(bd_idx); 02931 IR_IDX_L(mult_idx) = extent_idx; 02932 IR_FLD_L(mult_idx) = extent_fld; 02933 IR_LINE_NUM_L(mult_idx) = BD_LINE_NUM(bd_idx); 02934 IR_COL_NUM_L(mult_idx) = BD_COLUMN_NUM(bd_idx); 02935 len_ir_idx = mult_idx; 02936 } 02937 else if (dim == 1) { 02938 02939 /* Last dimension is the only dimension, so length = xtent */ 02940 02941 BD_LEN_FLD(bd_idx) = extent_fld; 02942 BD_LEN_IDX(bd_idx) = extent_idx; 02943 length_entry_idx = extent_entry_idx; 02944 stride_entry_idx = merge_entry_lists(stride_entry_idx, 02945 extent_entry_idx); 02946 02947 extent_entry_idx = NULL_IDX; /* Now length holds list */ 02948 02949 if (length_entry_idx != NULL_IDX) { /* Alt entries - need tmp = 0 */ 02950 gen_tmp_eq_zero_ir(extent_idx); 02951 } 02952 } 02953 02954 /* Last dimension */ 02955 02956 else if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) { 02957 IR_IDX_R(len_ir_idx) = extent_idx; 02958 IR_FLD_R(len_ir_idx) = extent_fld; 02959 IR_LINE_NUM_R(len_ir_idx) = BD_LINE_NUM(bd_idx); 02960 IR_COL_NUM_R(len_ir_idx) = BD_COLUMN_NUM(bd_idx); 02961 02962 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 02963 BD_LEN_IDX(bd_idx) = gen_compiler_tmp(BD_LINE_NUM(bd_idx), 02964 BD_COLUMN_NUM(bd_idx), 02965 Priv, TRUE); 02966 ATD_TYPE_IDX(BD_LEN_IDX(bd_idx)) = CG_INTEGER_DEFAULT_TYPE; 02967 ATD_FLD(BD_LEN_IDX(bd_idx)) = IR_FLD_R(BD_LEN_IDX(bd_idx)); 02968 ATD_TMP_IDX(BD_LEN_IDX(bd_idx)) = IR_IDX_R(BD_LEN_IDX(bd_idx)); 02969 02970 ATD_SYMBOLIC_CONSTANT(BD_LEN_IDX(bd_idx)) = TRUE; 02971 } 02972 else { 02973 IR_IDX_R(len_ir_idx) = extent_idx; 02974 IR_FLD_R(len_ir_idx) = extent_fld; 02975 IR_LINE_NUM_R(len_ir_idx) = BD_LINE_NUM(bd_idx); 02976 IR_COL_NUM_R(len_ir_idx) = BD_COLUMN_NUM(bd_idx); 02977 OPND_FLD(opnd) = IR_FLD_R(BD_LEN_IDX(bd_idx)); 02978 OPND_IDX(opnd) = IR_IDX_R(BD_LEN_IDX(bd_idx)); 02979 OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx); 02980 OPND_COL_NUM(opnd) = BD_COLUMN_NUM(bd_idx); 02981 02982 sh_idx = ntr_sh_tbl(); 02983 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 02984 SH_COMPILER_GEN(sh_idx) = TRUE; 02985 SH_P2_SKIP_ME(sh_idx) = TRUE; 02986 SH_GLB_LINE(sh_idx) = stmt_start_line; 02987 SH_COL_NUM(sh_idx) = stmt_start_col; 02988 02989 /* expr_semantics needs curr_stmt_sh_idx set to something valid. */ 02990 /* It does not need SH_IR_IDX(curr_stmt_sh_idx) set to something. */ 02991 02992 expr_desc.rank = 0; 02993 xref_state = CIF_No_Usage_Rec; 02994 02995 if (!expr_semantics(&opnd, &expr_desc)) { 02996 02997 # if defined(_CHECK_MAX_MEMORY) 02998 02999 if (!target_t3e) { 03000 AT_DCL_ERR(attr_idx) = TRUE; 03001 } 03002 # endif 03003 } 03004 03005 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 03006 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx; 03007 BD_LEN_IDX(bd_idx) = OPND_IDX(opnd); 03008 FREE_SH_NODE(sh_idx); 03009 } 03010 else { 03011 03012 if (!is_interface) { 03013 03014 if (extent_entry_idx != NULL_IDX) { 03015 stride_entry_idx = merge_entry_lists(stride_entry_idx, 03016 extent_entry_idx); 03017 length_entry_idx = merge_entry_lists(length_entry_idx, 03018 extent_entry_idx); 03019 } 03020 } 03021 03022 length_idx = ntr_bnds_sh_tmp_list(&opnd, 03023 length_entry_idx, 03024 (is_interface) ? NULL_IDX:sh_idx, 03025 TRUE, 03026 SA_INTEGER_DEFAULT_TYPE); 03027 BD_LEN_IDX(bd_idx) = length_idx; 03028 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 03029 } 03030 } 03031 } 03032 03033 /* After the dimensions are processed, stride_entry_idx contains a list */ 03034 /* of all bad entry points, for the array - including all extents and */ 03035 /* type information. Stride is calculated from the (previous dimension's */ 03036 /* extent) * (previous dimension's stride). A stride_entry_idx is made */ 03037 /* for the last dimension, even though actual stride isn't calculated for */ 03038 /* this dimension. */ 03039 03040 if (stride_entry_idx != NULL_IDX) { 03041 entry_count = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1; 03042 03043 if (length_entry_idx != NULL_IDX && 03044 entry_count == AL_ENTRY_COUNT(length_entry_idx)) { 03045 03046 /* Error if problem with lower and/or upper bounds coming in */ 03047 /* different entry points. Bounds for this array declaration */ 03048 /* cannot be calculated at any entry point, because dummy args */ 03049 /* used in the expression do not enter at all the same points. */ 03050 03051 PRINTMSG(AT_DEF_LINE(attr_idx), 660, Error, 03052 AT_DEF_COLUMN(attr_idx), 03053 AT_OBJ_NAME_PTR(attr_idx)); 03054 AT_DCL_ERR(attr_idx) = TRUE; 03055 } 03056 else if (entry_count == AL_ENTRY_COUNT(stride_entry_idx)) { 03057 03058 /* If the length is okay, but there's a problem with the */ 03059 /* stride, that means that it's a character and a bound */ 03060 /* forming the char length, doesn't enter the same as all */ 03061 /* the dimension bounds. Bounds for this array declaration */ 03062 /* cannot be calculated at any entry point, because dummy args */ 03063 /* used in the expression de not enter at all the same points. */ 03064 03065 PRINTMSG(AT_DEF_LINE(attr_idx), 661, Error, 03066 AT_DEF_COLUMN(attr_idx), 03067 AT_OBJ_NAME_PTR(attr_idx)); 03068 AT_DCL_ERR(attr_idx) = TRUE; 03069 } 03070 else if (entry_list != NULL_IDX) { 03071 stride_entry_count = merge_entry_list_count(stride_entry_idx, 03072 entry_list); 03073 03074 if (entry_count == stride_entry_count) { 03075 03076 /* This array and its bound variables do not enter at the */ 03077 /* same entry point. */ 03078 03079 PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error, 03080 AT_DEF_COLUMN(attr_idx), 03081 AT_OBJ_NAME_PTR(attr_idx)); 03082 AT_DCL_ERR(attr_idx) = TRUE; 03083 } 03084 } 03085 } 03086 03087 NEXT: 03088 03089 /* Every array must have the following semantic checks. So even if the */ 03090 /* bounds for the array are already resolved, it still must get these */ 03091 /* checks. */ 03092 03093 # if 0 03094 if (BD_ARRAY_CLASS(bd_idx) != Assumed_Size) { 03095 PRINTMSG(AT_DEF_LINE(attr_idx), 1576, Error, 03096 AT_DEF_COLUMN(attr_idx)); 03097 AT_DCL_ERR(attr_idx) = TRUE; 03098 } 03099 # endif 03100 03101 EXIT: 03102 03103 if (stride_entry_idx != NULL_IDX) { 03104 free_attr_list(stride_entry_idx); 03105 } 03106 03107 if (length_entry_idx != NULL_IDX) { 03108 free_attr_list(length_entry_idx); 03109 } 03110 03111 if (ATD_CLASS(attr_idx) == Function_Result) { 03112 ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) = entry_list; 03113 } 03114 else { 03115 ATD_NO_ENTRY_LIST(attr_idx) = entry_list; 03116 } 03117 03118 TRACE (Func_Exit, "pe_array_dim_resolution", NULL); 03119 03120 return; 03121 03122 } /* pe_array_dim_resolution */ 03123 03124 /******************************************************************************\ 03125 |* *| 03126 |* Description: *| 03127 |* It does semantic checking and tries to fold the bound. If the bound *| 03128 |* folds to a constant, ATD_FLD(tmp) is set to CN_Tbl_Idx and *| 03129 |* ATD_TMP_IDX(tmp) is set to the constant table index of the constant. *| 03130 |* AT_REFERENCED(tmp) = Not_Referenced, so the temp doesn't get added to *| 03131 |* the IR stream at entry point processing. array_dim_resolution and *| 03132 |* char_len_resolution then check ATD_FLD(tmp). If it is CN_Tbl_Idx *| 03133 |* the item resolves to a constant bounded item. If it doesn't resolve *| 03134 |* to a folded item, ATD_FLD(tmp) = SH_Tbl_Idx and ATD_TMP_IDX(tmp) *| 03135 |* is the index to the first statement header for the bound. A bound *| 03136 |* may have more than one statement, after going through expr_semantics. *| 03137 |* The statements are all linked together. *| 03138 |* *| 03139 |* Assumption: All non-interface blocks have a valid curr_stmt_sh_idx *| 03140 |* It is set to the Entry SH when decl_semantics is called. All bounds *| 03141 |* IR SH's go in following this and curr_stmt_sh_idx is advanced. *| 03142 |* *| 03143 |* Input parameters: *| 03144 |* NONE *| 03145 |* *| 03146 |* Output parameters: *| 03147 |* NONE *| 03148 |* *| 03149 |* Returns: *| 03150 |* NONE *| 03151 |* *| 03152 \******************************************************************************/ 03153 static void bound_resolution(int attr_idx) 03154 03155 { 03156 boolean ansi; 03157 msg_lvl_type save_msg_level; 03158 int start_sh_idx; 03159 03160 03161 TRACE (Func_Entry, "bound_resolution", NULL); 03162 03163 if (ATD_CLASS(attr_idx) == Constant) { 03164 03165 /* Intentionally blank */ 03166 } 03167 else if (AT_REFERENCED(attr_idx) == Not_Referenced) { 03168 03169 /* These are tmps that are only here, because CIF generation is on. */ 03170 /* These are shared tmps and normally would not have been kept */ 03171 /* around. Call expr_semantics with them, so the proper CIF calls */ 03172 /* can be generated and then free the IR. */ 03173 03174 xref_state = CIF_Symbol_Reference; 03175 cif_tmp_so_no_msg = TRUE; 03176 no_func_expansion = TRUE; 03177 save_msg_level = cmd_line_flags.msg_lvl_suppressed; 03178 ansi = on_off_flags.issue_ansi_messages; 03179 cmd_line_flags.msg_lvl_suppressed = Error_Lvl; 03180 03181 bound_semantics(attr_idx, FALSE); /* Don't get stmts */ 03182 03183 if (ATD_CLASS(attr_idx) != Constant) { 03184 ATD_TMP_IDX(attr_idx) = NULL_IDX; 03185 ATD_FLD(attr_idx) = NO_Tbl_Idx; 03186 } 03187 03188 AT_REFERENCED(attr_idx) = Not_Referenced; 03189 AT_DEFINED(attr_idx) = FALSE; 03190 no_func_expansion = FALSE; 03191 cmd_line_flags.msg_lvl_suppressed = save_msg_level; 03192 on_off_flags.issue_ansi_messages = ansi; 03193 cif_tmp_so_no_msg = FALSE; 03194 } 03195 else { 03196 03197 if (ATD_TMP_SEMANTICS_DONE(attr_idx)) { 03198 03199 /* These are tmps that were folded during pass1, because they were */ 03200 /* referenced in a bound for a parameterized character or array. */ 03201 /* These did not fold to a constant, so they must be sent thru */ 03202 /* expression semantics, so that everything gets folded and/or */ 03203 /* expanded correctly. Stop message issuing, because it has been */ 03204 /* done once already. */ 03205 03206 save_msg_level = cmd_line_flags.msg_lvl_suppressed; 03207 ansi = on_off_flags.issue_ansi_messages; 03208 cmd_line_flags.msg_lvl_suppressed = Error_Lvl; 03209 03210 /* If this isn't an interface block - generate stmts after */ 03211 /* curr_stmt_sh_idx for this bound. */ 03212 03213 start_sh_idx = bound_semantics(attr_idx, 03214 !SCP_IS_INTERFACE(curr_scp_idx)); 03215 03216 cmd_line_flags.msg_lvl_suppressed = save_msg_level; 03217 on_off_flags.issue_ansi_messages = ansi; 03218 } 03219 else { 03220 03221 /* If this isn't an interface block - generate stmts after */ 03222 /* curr_stmt_sh_idx for this bound. */ 03223 03224 xref_state = CIF_Symbol_Reference; 03225 start_sh_idx = bound_semantics(attr_idx, 03226 !SCP_IS_INTERFACE(curr_scp_idx)); 03227 } 03228 03229 if (ATD_CLASS(attr_idx) != Constant && 03230 !ATD_SYMBOLIC_CONSTANT(attr_idx) && 03231 SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX) { 03232 03233 /* Enter the code at each alternate entry. We do generate tmp = 0 */ 03234 /* code, because the bounds can be referenced for whole subscript */ 03235 /* and whole substring references. These are all bounds tmps for */ 03236 /* arrays (upper or lower) or character length. We do not have to */ 03237 /* worry about OPTIONAL dummy arguments here because it is illegal */ 03238 /* to use an OPTIONAL dummy argument in a bound expression. Start */ 03239 /* the copy at SH_PREV_IDX(start_sh_idx) and end at curr_stmt_sh_idx.*/ 03240 03241 insert_sh_after_entries(attr_idx, 03242 SH_PREV_IDX(start_sh_idx), 03243 curr_stmt_sh_idx, 03244 TRUE, 03245 TRUE); /* Advance ATP_FIRST_SH_IDX */ 03246 } 03247 } 03248 03249 TRACE (Func_Exit, "bound_resolution", NULL); 03250 03251 return; 03252 03253 } /* bound_resolution */ 03254 03255 /******************************************************************************\ 03256 |* *| 03257 |* Description: *| 03258 |* This routine calls expr_semantics for a declaration bound and *| 03259 |* handles semantic checking. If the bounds folds to a constant, *| 03260 |* ATD_FLD(tmp) is set to CN_Tbl_Idx and ATD_TMP_IDX(tmp) is set to the *| 03261 |* constant table index of the constant. AT_REFERENCED(tmp) = *| 03262 |* Not_Referenced, so the temp does not get used in other phases of *| 03263 |* compilation. *| 03264 |* Also, if non-constant a cvrt opr will be added if necessary to set *| 03265 |* the type to the correct size/addresss/offset type. *| 03266 |* *| 03267 |* Input parameters: *| 03268 |* attr_idx - Index of bound tmp to call expr_semantics for. *| 03269 |* insert_in_SH_stream - TRUE if IR should be inserted in IR stream. *| 03270 |* *| 03271 |* Output parameters: *| 03272 |* NONE *| 03273 |* *| 03274 |* Returns: *| 03275 |* bound_sh_idx - Index of statement header for bound. *| 03276 |* *| 03277 \******************************************************************************/ 03278 int bound_semantics(int attr_idx, 03279 boolean insert_in_SH_stream) 03280 03281 { 03282 int bound_sh_idx; 03283 expr_arg_type expr_desc; 03284 int list_idx; 03285 fld_type new_fld; 03286 int new_ir_idx; 03287 opnd_type opnd; 03288 int save_sh_idx; 03289 int type_idx; 03290 03291 03292 TRACE (Func_Entry, "bound_semantics", NULL); 03293 03294 if (AT_OBJ_CLASS(attr_idx) != Data_Obj || 03295 ATD_CLASS(attr_idx) != Compiler_Tmp) { 03296 return(NULL_IDX); 03297 } 03298 03299 expr_mode = Specification_Expr; 03300 expr_desc.rank = 0; 03301 ATD_TMP_SEMANTICS_DONE(attr_idx) = TRUE; 03302 03303 /* Save a copy of the IR. If this does not fold to a constant, we need */ 03304 /* to keep the IR before it goes through expr_semantics. This ir is used, */ 03305 /* if this bound is part of a description of an interface for a function. */ 03306 /* (Interface block, internal function or module procedure function.) */ 03307 03308 gen_opnd(&opnd, ATD_TMP_IDX(attr_idx), (fld_type) ATD_FLD(attr_idx), 03309 stmt_start_line, stmt_start_col); 03310 copy_subtree(&opnd, &opnd); 03311 new_ir_idx = OPND_IDX(opnd); 03312 new_fld = OPND_FLD(opnd); 03313 03314 /* Create a stmt header to link the IR to. This way if expr_semantics */ 03315 /* generates some statements, they get attached where they need to be. */ 03316 03317 bound_sh_idx = ntr_sh_tbl(); 03318 SH_IR_IDX(bound_sh_idx) = ATD_TMP_IDX(attr_idx); 03319 SH_STMT_TYPE(bound_sh_idx) = Automatic_Base_Size_Stmt; 03320 SH_COMPILER_GEN(bound_sh_idx) = TRUE; 03321 SH_P2_SKIP_ME(bound_sh_idx) = TRUE; 03322 SH_GLB_LINE(bound_sh_idx) = stmt_start_line; 03323 SH_COL_NUM(bound_sh_idx) = stmt_start_col; 03324 save_sh_idx = curr_stmt_sh_idx; 03325 curr_stmt_sh_idx = bound_sh_idx; 03326 03327 # if defined(GENERATE_WHIRL) 03328 03329 if (ATD_TMP_HAS_CVRT_OPR(attr_idx)) { 03330 03331 /* Need to do expr_semantics without the cvrt to do error checking */ 03332 03333 COPY_OPND(opnd, IR_OPND_L(IR_IDX_R(ATD_TMP_IDX(attr_idx)))); 03334 } 03335 else { 03336 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx))); 03337 } 03338 # else 03339 03340 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx))); 03341 # endif 03342 03343 if (!expr_semantics(&opnd, &expr_desc)) { 03344 03345 /* There were problems with this expression. Replace it with a */ 03346 /* constant one. Constant bound processing will free the IR. */ 03347 03348 OPND_IDX(opnd) = CN_INTEGER_ONE_IDX; 03349 OPND_FLD(opnd) = CN_Tbl_Idx; 03350 OPND_LINE_NUM(opnd) = stmt_start_line; 03351 OPND_COL_NUM(opnd) = stmt_start_col; 03352 03353 /* This is a newly created list after each call to expr_semantics.*/ 03354 /* It contains dargs found in this specification expression. */ 03355 03356 free_attr_list(SCP_TMP_LIST(curr_scp_idx)); 03357 SCP_TMP_LIST(curr_scp_idx) = NULL_IDX; /* Clear in case of list */ 03358 } 03359 else if (expr_desc.rank != 0) { 03360 PRINTMSG(AT_DEF_LINE(attr_idx), 907, Error, 03361 AT_DEF_COLUMN(attr_idx)); 03362 AT_DCL_ERR(attr_idx) = TRUE; 03363 } 03364 else if (expr_desc.type != Integer) { 03365 03366 /* The tmp must be integer. This must be its first pass thru and no */ 03367 /* no previous error messages must have been issued about this tmp. */ 03368 03369 if (expr_desc.linear_type == Typeless_4 || 03370 expr_desc.linear_type == Typeless_8) { 03371 PRINTMSG(AT_DEF_LINE(attr_idx), 221, Ansi, 03372 AT_DEF_COLUMN(attr_idx)); 03373 } 03374 else if (expr_desc.linear_type == Short_Typeless_Const) { 03375 PRINTMSG(AT_DEF_LINE(attr_idx), 221, Ansi, 03376 AT_DEF_COLUMN(attr_idx)); 03377 OPND_IDX(opnd) = cast_typeless_constant(OPND_IDX(opnd), 03378 INTEGER_DEFAULT_TYPE, 03379 OPND_LINE_NUM(opnd), 03380 OPND_COL_NUM(opnd)); 03381 expr_desc.type_idx = INTEGER_DEFAULT_TYPE; 03382 expr_desc.type = Integer; 03383 expr_desc.linear_type = INTEGER_DEFAULT_TYPE; 03384 03385 } 03386 else { 03387 03388 if (!AT_DCL_ERR(attr_idx)) { 03389 03390 if (expr_desc.linear_type == Long_Typeless) { 03391 03392 /* hollerith too long */ 03393 03394 PRINTMSG(AT_DEF_LINE(attr_idx), 1133, Error, 03395 AT_DEF_COLUMN(attr_idx)); 03396 } 03397 else { /* bad type */ 03398 PRINTMSG(AT_DEF_LINE(attr_idx), 488, Error, 03399 AT_DEF_COLUMN(attr_idx), 03400 get_basic_type_str(expr_desc.type_idx)); 03401 } 03402 AT_DCL_ERR(attr_idx) = TRUE; 03403 } 03404 03405 /* There were problems with this expression. Replace with a one. */ 03406 03407 OPND_IDX(opnd) = CN_INTEGER_ONE_IDX; 03408 OPND_FLD(opnd) = CN_Tbl_Idx; 03409 OPND_LINE_NUM(opnd) = AT_DEF_LINE(attr_idx); 03410 OPND_COL_NUM(opnd) = AT_DEF_COLUMN(attr_idx); 03411 03412 /* This is a newly created list after each call to expr_semantics.*/ 03413 /* It contains dargs found in this specification expression. */ 03414 03415 free_attr_list(SCP_TMP_LIST(curr_scp_idx)); 03416 SCP_TMP_LIST(curr_scp_idx) = NULL_IDX; /* Clear in case of list */ 03417 } 03418 } 03419 else if (expr_desc.has_symbolic) { 03420 03421 /* This expression contains a reference to a symbolic constant. */ 03422 03423 /* Determine if this is a symbolic constant expression or not. */ 03424 /* If this is a symbolic constant expression, ATD_SYMBOLIC_CONSTANT */ 03425 /* will be set on the compiler temp. */ 03426 03427 ATD_SYMBOLIC_CONSTANT(attr_idx) = expr_is_symbolic_constant(&opnd); 03428 } 03429 03430 # if defined(GENERATE_WHIRL) 03431 03432 else if (ATD_TMP_HAS_CVRT_OPR(attr_idx)) { 03433 COPY_OPND(IR_OPND_L(IR_IDX_R(ATD_TMP_IDX(attr_idx))), opnd); 03434 03435 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 03436 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx))); 03437 expr_semantics(&opnd, &expr_desc); 03438 } 03439 else { 03440 COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx))); 03441 } 03442 } 03443 # endif 03444 03445 if (OPND_FLD(opnd) == CN_Tbl_Idx) { 03446 03447 /* Folded to a constant. NOTE: Cannot free IR, because IR can */ 03448 /* be shared and you could free IR that is used in other places. */ 03449 03450 /* Change the tmp to a constant, so it gets folded whenever it is */ 03451 /* referenced. AT_DEFINED is left clear. It is set on declared */ 03452 /* parameters, so that parameter constants can be differentiated */ 03453 /* from compiler tmp constants. CIF wants all parameters, whether */ 03454 /* they are referenced or not, so AT_DEFINED is used to tell the */ 03455 /* difference between them. */ 03456 03457 CLEAR_VARIANT_ATTR_INFO(attr_idx, Data_Obj); 03458 03459 ATD_CLASS(attr_idx) = Constant; 03460 AT_TYPED(attr_idx) = TRUE; 03461 ATD_TYPE_IDX(attr_idx) = CN_TYPE_IDX(OPND_IDX(opnd)); 03462 AT_REFERENCED(attr_idx) = Not_Referenced; /* Temp not used */ 03463 AT_DEFINED(attr_idx) = FALSE; /* Temp not defined */ 03464 ATD_CONST_IDX(attr_idx) = OPND_IDX(opnd); 03465 ATD_FLD(attr_idx) = CN_Tbl_Idx; 03466 curr_stmt_sh_idx = save_sh_idx; 03467 FREE_SH_NODE(bound_sh_idx); 03468 bound_sh_idx = NULL_IDX; 03469 } 03470 else if (ATD_SYMBOLIC_CONSTANT(attr_idx)) { 03471 03472 /* This is a symbolic constant expression. A temp holds it. */ 03473 03474 curr_stmt_sh_idx = save_sh_idx; 03475 FREE_SH_NODE(bound_sh_idx); 03476 bound_sh_idx = NULL_IDX; 03477 ATD_FLD(attr_idx) = OPND_FLD(opnd); 03478 ATD_TMP_IDX(attr_idx) = OPND_IDX(opnd); 03479 } 03480 else { 03481 03482 if (OPND_FLD(opnd) == AT_Tbl_Idx) { 03483 03484 if (AT_IS_DARG(OPND_IDX(opnd))) { 03485 03486 /* CIF wants to know if a bound is made up of just one dummy */ 03487 /* argument. NO expression. AT_CIF_USE_IN_BND is set when */ 03488 /* this is found for a dummy argument. */ 03489 03490 AT_CIF_USE_IN_BND(OPND_IDX(opnd)) = TRUE; 03491 } 03492 03493 /* Let PDGCS know if a temp is set to one var. Give them */ 03494 /* the link between them. Use ATD_DEFINING_ATTR_IDX. */ 03495 03496 ATD_DEFINING_ATTR_IDX(attr_idx) = OPND_IDX(opnd); 03497 } 03498 03499 /* Make sure this is set to the correct addressing/offset type. */ 03500 03501 type_idx = check_type_for_size_address(&opnd); 03502 03503 COPY_OPND(IR_OPND_R(ATD_TMP_IDX(attr_idx)), opnd); 03504 03505 /* Reset type if necessary on the Asg_Opr and bound tmp. */ 03506 03507 ATD_TYPE_IDX(attr_idx) = type_idx; 03508 IR_TYPE_IDX(ATD_TMP_IDX(attr_idx)) = type_idx; 03509 03510 /* SCP_TMP_LIST contains a list of dummy args referenced in this */ 03511 /* expression. If there are NO alternate entries, SCP_TMP_LIST */ 03512 /* will always be NULL. */ 03513 03514 if (SCP_TMP_LIST(curr_scp_idx) != NULL_IDX) { 03515 03516 /* Convert the bounds list of dargs that are used in this */ 03517 /* expression, but do not come in at every entry point, into */ 03518 /* a list of entry points where this expression cannot be. */ 03519 03520 list_idx = SCP_TMP_LIST(curr_scp_idx); 03521 03522 while (list_idx != NULL_IDX) { 03523 ATD_NO_ENTRY_LIST(attr_idx) = 03524 merge_entry_lists(ATD_NO_ENTRY_LIST(attr_idx), 03525 (AT_OBJ_CLASS(AL_ATTR_IDX(list_idx)) == Data_Obj) ? 03526 ATD_NO_ENTRY_LIST(AL_ATTR_IDX(list_idx)) : 03527 ATP_NO_ENTRY_LIST(AL_ATTR_IDX(list_idx))); 03528 list_idx = AL_NEXT_IDX(list_idx); 03529 } 03530 03531 free_attr_list(SCP_TMP_LIST(curr_scp_idx)); 03532 SCP_TMP_LIST(curr_scp_idx) = NULL_IDX; 03533 } 03534 03535 if (!insert_in_SH_stream) { 03536 03537 /* Statement headers are not wanted. Leave this as IR. These tmps */ 03538 /* become place holders. If this is a parameter bound, this is an */ 03539 /* error situation. If this is an interface block, all these tmps */ 03540 /* are just place holders. NOTE: Cannot free IR, because IR can */ 03541 /* be shared and you could free IR that is used in other places. */ 03542 03543 AT_REFERENCED(attr_idx) = Not_Referenced; 03544 AT_DEFINED(attr_idx) = FALSE; 03545 03546 while (curr_stmt_sh_idx != NULL_IDX) { 03547 bound_sh_idx = curr_stmt_sh_idx; 03548 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 03549 FREE_SH_NODE(bound_sh_idx); 03550 } 03551 bound_sh_idx = NULL_IDX; 03552 curr_stmt_sh_idx = save_sh_idx; 03553 } 03554 else { 03555 03556 /* can't assume that the SH_NEXT_IDX(save_sh_idx) is null */ 03557 03558 if (SH_NEXT_IDX(save_sh_idx) != NULL_IDX) { 03559 while (SH_NEXT_IDX(bound_sh_idx) != NULL_IDX) { 03560 bound_sh_idx = SH_NEXT_IDX(bound_sh_idx); 03561 } 03562 SH_NEXT_IDX(bound_sh_idx) = SH_NEXT_IDX(save_sh_idx); 03563 if (SH_NEXT_IDX(bound_sh_idx)) { 03564 SH_PREV_IDX(SH_NEXT_IDX(bound_sh_idx)) = bound_sh_idx; 03565 } 03566 } 03567 03568 while (SH_PREV_IDX(bound_sh_idx) != NULL_IDX) { 03569 bound_sh_idx = SH_PREV_IDX(bound_sh_idx); 03570 } 03571 03572 SH_PREV_IDX(bound_sh_idx) = save_sh_idx; 03573 SH_NEXT_IDX(save_sh_idx) = bound_sh_idx; 03574 AT_DEFINED(attr_idx) = TRUE; 03575 AT_REFERENCED(attr_idx) = Referenced; 03576 } 03577 03578 /* Save the unexpanded IR, so it can be expanded later if this */ 03579 /* is part of a function that may be called. */ 03580 03581 /* Adjust type if necessary in the save unexpanded IR. */ 03582 03583 OPND_FLD(opnd) = new_fld; 03584 OPND_IDX(opnd) = new_ir_idx; 03585 OPND_LINE_NUM(opnd) = AT_DEF_LINE(attr_idx); 03586 OPND_COL_NUM(opnd) = AT_DEF_COLUMN(attr_idx); 03587 03588 type_idx = check_type_for_size_address(&opnd); 03589 03590 ATD_FLD(attr_idx) = OPND_FLD(opnd); 03591 ATD_TMP_IDX(attr_idx) = OPND_IDX(opnd); 03592 } 03593 03594 expr_mode = Regular_Expr; 03595 03596 TRACE (Func_Exit, "bound_semantics", NULL); 03597 03598 return(bound_sh_idx); 03599 03600 } /* bound_semantics */ 03601 03602 /******************************************************************************\ 03603 |* *| 03604 |* Description: *| 03605 |* This routine resolves the character length to a temp. *| 03606 |* NOTE: This does not handle component character lengths. They are *| 03607 |* done in parse_cpnt_dcl_stmt. *| 03608 |* *| 03609 |* Input parameters: *| 03610 |* attr_idx -> Index to attribute for array. *| 03611 |* *| 03612 |* Output parameters: *| 03613 |* NONE *| 03614 |* *| 03615 |* Returns: *| 03616 |* NONE *| 03617 |* *| 03618 \******************************************************************************/ 03619 void char_len_resolution(int attr_idx, 03620 boolean must_be_const_array) 03621 03622 { 03623 int column; 03624 int entry_count; 03625 int ir_idx; 03626 boolean is_interface; 03627 int len_entry_count; 03628 int len_idx; 03629 int line; 03630 int list_idx; 03631 int max_idx; 03632 int new_len_idx; 03633 opnd_type opnd; 03634 int sh_idx; 03635 int tmp_attr_idx; 03636 int t_idx; 03637 int type_idx; 03638 int zero_idx; 03639 03640 03641 TRACE (Func_Entry, "char_len_resolution", NULL); 03642 03643 is_interface = SCP_IS_INTERFACE(curr_scp_idx); 03644 type_idx = ATD_TYPE_IDX(attr_idx); 03645 03646 if (TYP_CHAR_CLASS(type_idx) == Unknown_Char) { 03647 03648 if (AT_OBJ_CLASS(TYP_IDX(type_idx)) == Data_Obj && 03649 ATD_CLASS(TYP_IDX(type_idx)) == Constant) { 03650 TYP_IDX(type_idx) = ATD_CONST_IDX(TYP_IDX(type_idx)); 03651 TYP_FLD(type_idx) = CN_Tbl_Idx; 03652 TYP_CHAR_CLASS(type_idx) = Const_Len_Char; 03653 } 03654 else if (AT_OBJ_CLASS(TYP_IDX(type_idx)) == Data_Obj && 03655 ATD_SYMBOLIC_CONSTANT(TYP_IDX(type_idx))) { 03656 03657 PRINTMSG(AT_DEF_LINE(attr_idx), 1211, Error, 03658 AT_DEF_COLUMN(attr_idx), 03659 AT_OBJ_NAME_PTR(attr_idx)); 03660 AT_DCL_ERR(attr_idx) = TRUE; 03661 ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE; 03662 } 03663 else { 03664 TYP_CHAR_CLASS(type_idx) = Var_Len_Char; 03665 TYP_ORIG_LEN_IDX(type_idx) = TYP_IDX(type_idx); 03666 } 03667 } 03668 03669 if (TYP_CHAR_CLASS(type_idx) == Var_Len_Char) { 03670 03671 /* This is called from PARAMETER processing. This must be a const */ 03672 /* length array. If it is not, do not process now. It will happen */ 03673 /* at decl_sematics time. PARAMETER processing will issue error. */ 03674 03675 if (must_be_const_array) { 03676 goto EXIT; 03677 } 03678 03679 if (fnd_semantic_err(Obj_Var_Len_Ch, 03680 AT_DEF_LINE(attr_idx), 03681 AT_DEF_COLUMN(attr_idx), 03682 attr_idx, 03683 TRUE)) { 03684 ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE; 03685 } 03686 else if (ATD_CLASS(attr_idx) == Function_Result && 03687 !ATP_EXPL_ITRFC(ATD_FUNC_IDX(attr_idx))) { 03688 PRINTMSG(AT_DEF_LINE(attr_idx), 916, Error, 03689 AT_DEF_COLUMN(attr_idx), 03690 AT_OBJ_NAME_PTR(ATD_FUNC_IDX(attr_idx))); 03691 AT_DCL_ERR(attr_idx) = TRUE; 03692 ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE; 03693 } 03694 else { 03695 03696 if (!TYP_RESOLVED(type_idx)) { 03697 03698 /* generate max(0,length) - then switch length to new tmp */ 03699 03700 NTR_IR_TBL(max_idx); 03701 IR_OPR(max_idx) = Max_Opr; 03702 IR_LINE_NUM(max_idx) = AT_DEF_LINE(attr_idx); 03703 IR_COL_NUM(max_idx) = AT_DEF_COLUMN(attr_idx); 03704 IR_LIST_CNT_L(max_idx) = 2; 03705 03706 NTR_IR_LIST_TBL(list_idx); 03707 IR_FLD_L(max_idx) = IL_Tbl_Idx; 03708 IR_IDX_L(max_idx) = list_idx; 03709 03710 OPND_FLD(opnd) = TYP_FLD(type_idx); 03711 OPND_IDX(opnd) = TYP_IDX(type_idx); 03712 OPND_LINE_NUM(opnd) = AT_DEF_LINE(attr_idx); 03713 OPND_COL_NUM(opnd) = AT_DEF_COLUMN(attr_idx); 03714 t_idx = check_type_for_size_address(&opnd); 03715 03716 COPY_OPND(IL_OPND(list_idx), opnd); 03717 03718 IR_TYPE_IDX(max_idx) = t_idx; 03719 03720 NTR_IR_LIST_TBL(zero_idx); 03721 IL_NEXT_LIST_IDX(list_idx) = zero_idx; 03722 IL_PREV_LIST_IDX(zero_idx) = list_idx; 03723 IL_FLD(zero_idx) = CN_Tbl_Idx; 03724 IL_IDX(zero_idx) = CN_INTEGER_ZERO_IDX; 03725 IL_LINE_NUM(zero_idx) = AT_DEF_LINE(attr_idx); 03726 IL_COL_NUM(zero_idx) = AT_DEF_COLUMN(attr_idx); 03727 03728 if (!is_interface) { 03729 sh_idx = ntr_sh_tbl(); 03730 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 03731 SH_P2_SKIP_ME(sh_idx) = TRUE; 03732 SH_COMPILER_GEN(sh_idx) = TRUE; 03733 SH_GLB_LINE(sh_idx) = stmt_start_line; 03734 SH_COL_NUM(sh_idx) = stmt_start_col; 03735 } 03736 03737 OPND_FLD(opnd) = IR_Tbl_Idx; 03738 OPND_IDX(opnd) = max_idx; 03739 OPND_LINE_NUM(opnd) = stmt_start_line; 03740 OPND_COL_NUM(opnd) = stmt_start_col; 03741 new_len_idx = ntr_bnds_sh_tmp_list( 03742 &opnd, 03743 ATD_NO_ENTRY_LIST(TYP_IDX(type_idx)), 03744 (is_interface) ? NULL_IDX : sh_idx, 03745 TRUE, 03746 t_idx); 03747 03748 TYP_FLD(type_idx) = AT_Tbl_Idx; 03749 TYP_IDX(type_idx) = new_len_idx; 03750 03751 if (ATD_NO_ENTRY_LIST(new_len_idx) != NULL_IDX) { 03752 entry_count = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1; 03753 03754 if (entry_count==AL_ENTRY_COUNT(ATD_NO_ENTRY_LIST(new_len_idx))){ 03755 03756 /* The length for this character cannot be calculated at */ 03757 /* any entry point, because dargs used in the expression do */ 03758 /* not enter at all the same points. */ 03759 03760 PRINTMSG(AT_DEF_LINE(attr_idx), 659, Error, 03761 AT_DEF_COLUMN(attr_idx), 03762 AT_OBJ_NAME_PTR(attr_idx)); 03763 AT_DCL_ERR(attr_idx) = TRUE; 03764 } 03765 else if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) { 03766 len_entry_count = 03767 merge_entry_list_count(ATD_NO_ENTRY_LIST(new_len_idx), 03768 ((ATD_CLASS(attr_idx) == Function_Result) ? 03769 ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) : 03770 ATD_NO_ENTRY_LIST(attr_idx))); 03771 03772 if (entry_count == len_entry_count) { 03773 PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error, 03774 AT_DEF_COLUMN(attr_idx), 03775 AT_OBJ_NAME_PTR(attr_idx)); 03776 AT_DCL_ERR(attr_idx) = TRUE; 03777 } 03778 else if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 03779 ATD_CLASS(attr_idx) == Variable) { 03780 PRINTMSG(AT_DEF_LINE(attr_idx), 1046, Caution, 03781 AT_DEF_COLUMN(attr_idx), 03782 AT_OBJ_NAME_PTR(attr_idx)); 03783 } 03784 } 03785 } 03786 } 03787 03788 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 03789 03790 if (ATD_CLASS(attr_idx) != Function_Result && 03791 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Function && 03792 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Subroutine) { 03793 PRINTMSG(AT_DEF_LINE(attr_idx), 1014, Error, 03794 AT_DEF_COLUMN(attr_idx), 03795 AT_OBJ_NAME_PTR(attr_idx)); 03796 AT_DCL_ERR(attr_idx) = TRUE; 03797 } 03798 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) { 03799 PRINTMSG(AT_DEF_LINE(attr_idx), 1577, Error, 03800 AT_DEF_COLUMN(attr_idx), 03801 AT_OBJ_NAME_PTR(attr_idx)); 03802 AT_DCL_ERR(attr_idx) = TRUE; 03803 } 03804 else if (ATD_CLASS(attr_idx) == Variable) { 03805 ATD_AUTOMATIC(attr_idx) = TRUE; 03806 } 03807 } 03808 } 03809 } 03810 else if (TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) { 03811 03812 /* This is called from PARAMETER processing. This must be a const */ 03813 /* length array. If it is not, do not process now. It will happen */ 03814 /* at decl_sematics time. PARAMETER processing will issue error. */ 03815 03816 if (must_be_const_array) { 03817 goto EXIT; 03818 } 03819 03820 if (AT_OBJ_CLASS(attr_idx) == Stmt_Func) { 03821 ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE; 03822 } 03823 else { 03824 03825 switch (ATD_CLASS(attr_idx)) { 03826 case Function_Result: 03827 03828 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX || ATD_POINTER(attr_idx)) { 03829 PRINTMSG(AT_DEF_LINE(attr_idx), 507, Error, 03830 AT_DEF_COLUMN(attr_idx), 03831 AT_OBJ_NAME_PTR(attr_idx)); 03832 AT_DCL_ERR(attr_idx) = TRUE; 03833 AT_DCL_ERR(ATD_FUNC_IDX(attr_idx)) = TRUE; 03834 break; 03835 } 03836 03837 if (ATD_FUNC_IDX(attr_idx) != SCP_ATTR_IDX(curr_scp_idx) && 03838 !ATP_ALT_ENTRY(ATD_FUNC_IDX(attr_idx)) && 03839 ATP_PROC(ATD_FUNC_IDX(attr_idx)) != Dummy_Proc) { 03840 PRINTMSG(AT_DEF_LINE(attr_idx), 1107, Error, 03841 AT_DEF_COLUMN(attr_idx), 03842 AT_OBJ_NAME_PTR(ATD_FUNC_IDX(attr_idx))); 03843 AT_DCL_ERR(attr_idx) = TRUE; 03844 AT_DCL_ERR(ATD_FUNC_IDX(attr_idx)) = TRUE; 03845 break; 03846 } 03847 03848 /* This is an intentional fall through. All character*(*) */ 03849 /* function results will be passed thru the interface as */ 03850 /* dummy arguments. */ 03851 03852 case Dummy_Argument: 03853 03854 /* Generate tmp = clen(attr). This must go on the bound list */ 03855 /* because this is a dummy argument. */ 03856 NTR_IR_TBL(len_idx); 03857 IR_OPR(len_idx) = Clen_Opr; 03858 IR_TYPE_IDX(len_idx) = SA_INTEGER_DEFAULT_TYPE; 03859 IR_LINE_NUM(len_idx) = AT_DEF_LINE(attr_idx); 03860 IR_COL_NUM(len_idx) = AT_DEF_COLUMN(attr_idx); 03861 03862 if (ATD_CLASS(attr_idx) == Function_Result && 03863 ATP_PROC(ATD_FUNC_IDX(attr_idx)) == Dummy_Proc) { 03864 IR_IDX_L(len_idx) = ATD_FUNC_IDX(attr_idx); 03865 } 03866 else { 03867 IR_IDX_L(len_idx) = attr_idx; 03868 } 03869 03870 IR_FLD_L(len_idx) = AT_Tbl_Idx; 03871 IR_LINE_NUM_L(len_idx) = AT_DEF_LINE(attr_idx); 03872 IR_COL_NUM_L(len_idx) = AT_DEF_COLUMN(attr_idx); 03873 03874 OPND_FLD(opnd) = IR_Tbl_Idx; 03875 OPND_IDX(opnd) = len_idx; 03876 OPND_LINE_NUM(opnd) = AT_DEF_LINE(attr_idx); 03877 OPND_COL_NUM(opnd) = AT_DEF_COLUMN(attr_idx); 03878 03879 { 03880 expr_arg_type exp_desc; 03881 fold_clen_opr(&opnd, &exp_desc); 03882 } 03883 gen_sh(After, 03884 Automatic_Base_Size_Stmt, 03885 stmt_start_line, 03886 stmt_start_col, 03887 FALSE, 03888 FALSE, 03889 TRUE); 03890 03891 find_opnd_line_and_column(&opnd, &line, &column); 03892 GEN_COMPILER_TMP_ASG(ir_idx, 03893 tmp_attr_idx, 03894 TRUE, /* Semantics is done */ 03895 line, 03896 column, 03897 SA_INTEGER_DEFAULT_TYPE, 03898 Priv); 03899 03900 COPY_OPND(IR_OPND_R(ir_idx), opnd); /* IR_OPND_R = opnd */ 03901 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 03902 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 03903 ATD_TMP_IDX(tmp_attr_idx) = ir_idx; 03904 ATD_FLD(tmp_attr_idx) = IR_Tbl_Idx; 03905 /* Create new entry, because each assumed sized darg has a */ 03906 /* different tmp to go with it. */ 03907 03908 type_tbl[TYP_WORK_IDX] = type_tbl[ATD_TYPE_IDX(attr_idx)]; 03909 TYP_FLD(TYP_WORK_IDX) = AT_Tbl_Idx; 03910 TYP_IDX(TYP_WORK_IDX) = tmp_attr_idx; 03911 03912 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 03913 03914 /* insert_sh_after_entries will handle this code at alternate */ 03915 /* entry points. It will also take care of any OPTIONAL stuff */ 03916 /* that needs to be generated. */ 03917 03918 insert_sh_after_entries(attr_idx, 03919 SH_PREV_IDX(curr_stmt_sh_idx), 03920 curr_stmt_sh_idx, 03921 FALSE, /* Don't generate tmp = 0 */ 03922 TRUE); /* Advance ATP_FIRST_SH_IDX */ 03923 03924 break; 03925 03926 case CRI__Pointee: 03927 03928 /* TYP_IDX becomes the attr index of the pointer. A new entry */ 03929 /* is made, because this entry cannot share with another. */ 03930 03931 type_tbl[TYP_WORK_IDX] = type_tbl[ATD_TYPE_IDX(attr_idx)]; 03932 TYP_FLD(TYP_WORK_IDX) = AT_Tbl_Idx; 03933 TYP_IDX(TYP_WORK_IDX) = ATD_PTR_IDX(attr_idx); 03934 03935 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 03936 break; 03937 03938 case Constant: 03939 break; 03940 03941 default: /* This must be a darg, constant, or CRI pointee */ 03942 PRINTMSG(AT_DEF_LINE(attr_idx), 350, Error, 03943 AT_DEF_COLUMN(attr_idx), 03944 AT_OBJ_NAME_PTR(attr_idx)); 03945 AT_DCL_ERR(attr_idx) = TRUE; 03946 break; 03947 } /* End switch */ 03948 } 03949 } 03950 else if (TYP_CHAR_CLASS(type_idx) == Const_Len_Char) { 03951 03952 if (compare_cn_and_value(TYP_IDX(type_idx), 0, Lt_Opr)) { 03953 type_tbl[TYP_WORK_IDX] = type_tbl[type_idx]; 03954 TYP_IDX(TYP_WORK_IDX) = CN_INTEGER_ZERO_IDX; 03955 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 03956 } 03957 else if (compare_cn_and_value(TYP_IDX(type_idx), 03958 max_character_length, 03959 Gt_Opr) && 03960 TYP_TYPE(CN_TYPE_IDX(TYP_IDX(type_idx))) == Integer) { 03961 03962 PRINTMSG(AT_DEF_LINE(attr_idx), 35, Error, 03963 AT_DEF_COLUMN(attr_idx), 03964 AT_OBJ_NAME_PTR(attr_idx), 03965 max_character_length); 03966 03967 type_tbl[TYP_WORK_IDX] = type_tbl[type_idx]; 03968 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CN_TYPE_IDX(TYP_IDX(type_idx)), 03969 max_character_length); 03970 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 03971 AT_DCL_ERR(attr_idx) = TRUE; 03972 } 03973 } 03974 03975 EXIT: 03976 03977 TYP_RESOLVED(ATD_TYPE_IDX(attr_idx)) = TRUE; 03978 03979 TRACE (Func_Exit, "char_len_resolution", NULL); 03980 03981 return; 03982 03983 } /* char_len_resolution */ 03984 03985 /******************************************************************************\ 03986 |* *| 03987 |* Description: *| 03988 |* compares two dummy arguments for type, kind type, and rank. *| 03989 |* This is used for verifyng interfaces and for interface resolution. *| 03990 |* *| 03991 |* Input parameters: *| 03992 |* idx1, idx2 - the two dummies. *| 03993 |* *| 03994 |* Output parameters: *| 03995 |* NONE *| 03996 |* *| 03997 |* Returns: *| 03998 |* TRUE is same in all three categories. *| 03999 |* FALSE otherwise. *| 04000 |* *| 04001 \******************************************************************************/ 04002 boolean compare_dummy_arguments(int idx1, 04003 int idx2) 04004 04005 { 04006 int i; 04007 boolean same = TRUE; 04008 04009 04010 TRACE (Func_Entry, "compare_dummy_arguments", NULL); 04011 04012 if (AT_OBJ_CLASS(idx1) == AT_OBJ_CLASS(idx2)) { 04013 04014 if (AT_OBJ_CLASS(idx1) == Pgm_Unit) { 04015 04016 if (!ATP_EXPL_ITRFC(idx1) || !ATP_EXPL_ITRFC(idx2)) { 04017 04018 /* We can only disambiguate, if an explicit interface */ 04019 /* is specified for the dummy procedure. */ 04020 04021 same = FALSE; 04022 } 04023 else if (ATP_PGM_UNIT(idx1) != ATP_PGM_UNIT(idx2) && 04024 ATP_PGM_UNIT(idx1) != Pgm_Unknown && 04025 ATP_PGM_UNIT(idx2) != Pgm_Unknown) { 04026 same = FALSE; /* Have func vs Subr */ 04027 } 04028 else { 04029 04030 if (ATP_PGM_UNIT(idx1) == ATP_PGM_UNIT(idx2) && 04031 ATP_PGM_UNIT(idx2) == Function) { 04032 04033 /* Both functions - compare results */ 04034 04035 same = compare_darg_or_rslt_types(ATP_RSLT_IDX(idx1), 04036 ATP_RSLT_IDX(idx2)); 04037 } 04038 04039 if (same) { /* Compare the dargs */ 04040 04041 if (ATP_NUM_DARGS(idx1) != ATP_NUM_DARGS(idx2)) { 04042 same = FALSE; 04043 } 04044 else { 04045 04046 /* We know the result type is the same, so either both */ 04047 /* have ATP_EXTRA_DARG set or both have it FALSE. */ 04048 04049 for (i = (ATP_EXTRA_DARG(idx1) ? 1 : 0); 04050 i < ATP_NUM_DARGS(idx1); i++) { 04051 same = compare_dummy_arguments( 04052 SN_ATTR_IDX((ATP_FIRST_IDX(idx1)+i)), 04053 SN_ATTR_IDX((ATP_FIRST_IDX(idx2)+i))); 04054 04055 if (!same) break; 04056 } 04057 } 04058 } 04059 } 04060 } 04061 else if (AT_OBJ_CLASS(idx1) == Data_Obj) { 04062 04063 if (ATD_CLASS(idx1) == ATD_CLASS(idx2)) { 04064 04065 /* If either one is IGNORE_TKR they are the same type and rank. */ 04066 04067 if (ATD_CLASS(idx1) == Dummy_Argument && 04068 !ATD_IGNORE_TKR(idx1) && !ATD_IGNORE_TKR(idx2)) { 04069 same = compare_darg_or_rslt_types(idx1, idx2); 04070 } 04071 } 04072 else { 04073 same = FALSE; 04074 } 04075 } 04076 } 04077 else { 04078 same = FALSE; 04079 } 04080 04081 TRACE (Func_Exit, "compare_dummy_arguments", NULL); 04082 04083 return(same); 04084 04085 } /* compare_dummy_arguments */ 04086 04087 /******************************************************************************\ 04088 |* *| 04089 |* Description: *| 04090 |* This routine does the semantic error checking between the function *| 04091 |* result name and entry names. *| 04092 |* *| 04093 |* Input parameters: *| 04094 |* rslt_idx -> attr idx for the result name. *| 04095 |* pgm_rslt_idx -> Result index for the external program. *| 04096 |* *| 04097 |* Output parameters: *| 04098 |* NONE *| 04099 |* *| 04100 |* Returns: *| 04101 |* NONE *| 04102 |* *| 04103 \******************************************************************************/ 04104 static void compare_entry_to_func_rslt(int attr_idx, 04105 int pgm_rslt_idx) 04106 { 04107 int column; 04108 int idx; 04109 int line; 04110 int loop; 04111 boolean not_a_match; 04112 int pgm_type_idx; 04113 int rslt_idx; 04114 int rslt_type_idx; 04115 04116 04117 TRACE (Func_Entry, "compare_entry_to_func_rslt", NULL); 04118 04119 line = AT_DEF_LINE(attr_idx); 04120 column = AT_DEF_COLUMN(attr_idx); 04121 rslt_idx = ATP_RSLT_IDX(attr_idx); 04122 rslt_type_idx= ATD_TYPE_IDX(rslt_idx); 04123 pgm_type_idx = ATD_TYPE_IDX(pgm_rslt_idx); 04124 04125 04126 if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX && 04127 BD_ARRAY_SIZE(ATD_ARRAY_IDX(rslt_idx)) == Symbolic_Constant_Size) { 04128 PRINTMSG(line, 1230, Error, column, AT_OBJ_NAME_PTR(attr_idx)); 04129 } 04130 else if (ATD_ARRAY_IDX(rslt_idx) != ATD_ARRAY_IDX(pgm_rslt_idx) && 04131 !compare_array_entries(ATD_ARRAY_IDX(rslt_idx), 04132 ATD_ARRAY_IDX(pgm_rslt_idx))) { 04133 PRINTMSG(line, 673, Error, column, AT_OBJ_NAME_PTR(pgm_rslt_idx), 04134 AT_OBJ_NAME_PTR(rslt_idx)); 04135 } 04136 else if (ATD_POINTER(pgm_rslt_idx) != ATD_POINTER(rslt_idx)) { 04137 PRINTMSG(line, 674, Error, column, AT_OBJ_NAME_PTR(pgm_rslt_idx), 04138 AT_OBJ_NAME_PTR(rslt_idx)); 04139 } 04140 else if (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) != 04141 TYP_TYPE(ATD_TYPE_IDX(pgm_rslt_idx))) { 04142 04143 if (TYP_TYPE(rslt_type_idx) > Complex || 04144 TYP_TYPE(pgm_type_idx) > Complex) { 04145 PRINTMSG(line, 21, Error, column, AT_OBJ_NAME_PTR(pgm_rslt_idx), 04146 AT_OBJ_NAME_PTR(rslt_idx)); 04147 } 04148 # if defined(_TARGET_OS_MAX) 04149 04150 else if (cmd_line_flags.integer_32 && 04151 !cmd_line_flags.s_default32 && 04152 ((TYP_TYPE(rslt_type_idx) == Integer && 04153 TYP_DESC(rslt_type_idx) == Default_Typed) || 04154 (TYP_TYPE(pgm_type_idx) == Integer && 04155 TYP_DESC(pgm_type_idx) == Default_Typed))) { 04156 04157 if (TYP_TYPE(rslt_type_idx) == Integer) { 04158 PRINTMSG(line, 1195, Warning, column, 04159 AT_OBJ_NAME_PTR(rslt_idx), 04160 AT_OBJ_NAME_PTR(pgm_rslt_idx)); 04161 } 04162 else { 04163 PRINTMSG(line, 1195, Warning, column, 04164 AT_OBJ_NAME_PTR(pgm_rslt_idx), 04165 AT_OBJ_NAME_PTR(rslt_idx)); 04166 } 04167 } 04168 # endif 04169 else if (on_off_flags.issue_ansi_messages || 04170 GET_MESSAGE_TBL(message_warning_tbl, 22) || 04171 GET_MESSAGE_TBL(message_error_tbl, 22)) { 04172 04173 /* The standard requires mixed types (COMPLEX, LOGICAL, INTEGER, */ 04174 /* REAL) to all be of default type. If ANSI checking is on, this */ 04175 /* for/switch checks the rslt_idx and then the pgm_rslt_idx to see*/ 04176 /* if any are non_default types. An ANSI msg is issued if found. */ 04177 04178 idx = rslt_idx; 04179 04180 for (loop = 1; loop <=2; loop++) { 04181 04182 switch (TYP_TYPE(ATD_TYPE_IDX(idx))) { 04183 case Logical: 04184 not_a_match = TYP_LINEAR(ATD_TYPE_IDX(idx)) != 04185 LOGICAL_DEFAULT_TYPE; 04186 break; 04187 04188 case Complex: 04189 not_a_match = TYP_LINEAR(ATD_TYPE_IDX(idx)) != 04190 COMPLEX_DEFAULT_TYPE; 04191 break; 04192 04193 case Integer: 04194 not_a_match = TYP_LINEAR(ATD_TYPE_IDX(idx)) != 04195 INTEGER_DEFAULT_TYPE; 04196 break; 04197 04198 case Real: 04199 not_a_match = (TYP_LINEAR(ATD_TYPE_IDX(idx)) != 04200 REAL_DEFAULT_TYPE && 04201 TYP_LINEAR(ATD_TYPE_IDX(idx)) != 04202 DOUBLE_DEFAULT_TYPE); 04203 break; 04204 } /* switch */ 04205 04206 if (not_a_match) { 04207 PRINTMSG(line, 22, Ansi, column, AT_OBJ_NAME_PTR(idx)); 04208 } 04209 04210 idx = pgm_rslt_idx; 04211 } /* end FOR */ 04212 } 04213 } 04214 else if (TYP_LINEAR(rslt_type_idx) == TYP_LINEAR(pgm_type_idx) && 04215 TYP_IDX(rslt_type_idx) == TYP_IDX(pgm_type_idx)) { 04216 04217 /* This is the same linear type or the same character length or the */ 04218 /* same structure. Intentionally left blank. */ 04219 } 04220 else if (TYP_TYPE(rslt_type_idx) == Character) { 04221 04222 /* Do not issue the error, if they are both variable length, because */ 04223 /* this cannot be detected at compile time. */ 04224 04225 if (TYP_CHAR_CLASS(rslt_type_idx) == Const_Len_Char && 04226 TYP_CHAR_CLASS(pgm_type_idx) == Const_Len_Char && 04227 fold_relationals(TYP_IDX(rslt_type_idx), 04228 TYP_IDX(pgm_type_idx), Ne_Opr)) { 04229 PRINTMSG(line, 21, Error, column, AT_OBJ_NAME_PTR(pgm_rslt_idx), 04230 AT_OBJ_NAME_PTR(rslt_idx)); 04231 } 04232 } 04233 else if (TYP_TYPE(rslt_type_idx) == Structure) { 04234 04235 /* Both are structures with different structure indexes. Check if */ 04236 /* the structures are the same. */ 04237 04238 if (!compare_derived_types(rslt_type_idx, pgm_type_idx)) { 04239 PRINTMSG(line, 21, Error, column, AT_OBJ_NAME_PTR(pgm_rslt_idx), 04240 AT_OBJ_NAME_PTR(rslt_idx)); 04241 } 04242 } 04243 else if (on_off_flags.issue_ansi_messages || 04244 GET_MESSAGE_TBL(message_warning_tbl, 13) || 04245 GET_MESSAGE_TBL(message_error_tbl, 13)) { 04246 04247 04248 /* Types match, but TYPE_IDX differs. This means that both cannot */ 04249 /* be default types (unless one is default real and the other is */ 04250 /* default double precision.), so if ANSI checking, issue msg. */ 04251 04252 if ((TYP_TYPE(rslt_type_idx) == Real) && 04253 (TYP_LINEAR(rslt_type_idx) == REAL_DEFAULT_TYPE || 04254 TYP_LINEAR(rslt_type_idx) == DOUBLE_DEFAULT_TYPE) && 04255 (TYP_LINEAR(pgm_type_idx) == REAL_DEFAULT_TYPE || 04256 TYP_LINEAR(pgm_type_idx) == DOUBLE_DEFAULT_TYPE)) { 04257 /* This is double precision default and a real default -ok no msg */ 04258 } 04259 else { 04260 PRINTMSG(line, 13, Ansi, column, AT_OBJ_NAME_PTR(pgm_rslt_idx), 04261 AT_OBJ_NAME_PTR(rslt_idx)); 04262 } 04263 } 04264 04265 TRACE (Func_Exit, "compare_entry_to_func_rslt", NULL); 04266 04267 return; 04268 04269 } /* compare_entry_to_func_rslt */ 04270 04271 /******************************************************************************\ 04272 |* *| 04273 |* Description: *| 04274 |* This does semantic checking for the declaration statements. *| 04275 |* *| 04276 |* Input parameters: *| 04277 |* NONE *| 04278 |* *| 04279 |* Output parameters: *| 04280 |* NONE *| 04281 |* *| 04282 |* Returns: *| 04283 |* NONE *| 04284 |* *| 04285 \******************************************************************************/ 04286 void decl_semantics(void) 04287 04288 { 04289 int al_idx; 04290 int attr_idx; 04291 int count; 04292 int darg_idx; 04293 int darg_list_idx; 04294 int eq_idx; 04295 int entry_attr_idx; 04296 int entry_idx; 04297 int entry_list_idx; 04298 int group; 04299 int idx; 04300 int label_sh_idx; 04301 int line; 04302 int list_idx; 04303 int list_idx2; 04304 int name_idx; 04305 opnd_type opnd; 04306 int pgm_attr_idx; 04307 int prev_idx; 04308 boolean recursive; 04309 int rslt_idx; 04310 int save_curr_stmt_sh_idx; 04311 int sh_after_entry_idx; 04312 04313 04314 TRACE (Func_Entry, "decl_semantics", NULL); 04315 04316 pgm_attr_idx = SCP_ATTR_IDX(curr_scp_idx); 04317 04318 /* Implement the save all commandline option -ev */ 04319 04320 if (on_off_flags.save_all_vars) { 04321 04322 if (ATP_RECURSIVE(pgm_attr_idx)) { 04323 PRINTMSG(AT_DEF_LINE(pgm_attr_idx), 1103, Caution, 04324 AT_DEF_COLUMN(pgm_attr_idx), 04325 AT_OBJ_NAME_PTR(pgm_attr_idx)); 04326 } 04327 else if (SCP_PARENT_IDX(curr_scp_idx) != NULL_IDX) { 04328 04329 /* Check if the parent is recursive. */ 04330 04331 idx = SCP_PARENT_IDX(curr_scp_idx); 04332 recursive = FALSE; 04333 04334 do { 04335 04336 if (ATP_RECURSIVE(SCP_ATTR_IDX(idx))) { 04337 recursive = TRUE; 04338 break; 04339 } 04340 idx = SCP_PARENT_IDX(idx); 04341 } 04342 while (idx != NULL_IDX); 04343 04344 if (!recursive) { 04345 ATP_SAVE_ALL(pgm_attr_idx) = TRUE; 04346 } 04347 } 04348 else { 04349 ATP_SAVE_ALL(pgm_attr_idx) = TRUE; 04350 } 04351 } 04352 04353 /* Set the default storage for this procedure. */ 04354 04355 if (ATP_PGM_UNIT(pgm_attr_idx) == Module) { 04356 SCP_DEFAULT_STORAGE(curr_scp_idx) = Static; 04357 } 04358 else if (!ATP_SAVE_ALL(pgm_attr_idx) || 04359 ATP_STACK_DIR(pgm_attr_idx) || 04360 ATP_RECURSIVE(pgm_attr_idx) || 04361 (on_off_flags.recursive && 04362 (ATP_PGM_UNIT(pgm_attr_idx) == Function || 04363 ATP_PGM_UNIT(pgm_attr_idx) == Subroutine))) { 04364 SCP_DEFAULT_STORAGE(curr_scp_idx) = Stack; 04365 } 04366 else { 04367 SCP_DEFAULT_STORAGE(curr_scp_idx) = Static; 04368 } 04369 04370 /* Set up global variables needed for decl_semantics and attr_semantics. */ 04371 04372 allocatable_list_idx = NULL_IDX; 04373 namelist_list_idx = NULL_IDX; 04374 number_of_allocatables = 0; 04375 pointee_based_blk = NULL_IDX; 04376 alt_entry_equiv_blk = NULL_IDX; 04377 alt_entry_equiv_grp = NULL_IDX; 04378 reshape_array_list = NULL_IDX; 04379 init_sh_start_idx = NULL_IDX; 04380 init_sh_end_idx = NULL_IDX; 04381 04382 /* At entry curr_stmt_sh_idx is set to the first stmt of the pgm unit. */ 04383 /* All entry code will insert after curr_stmt_sh_idx. After the symbol */ 04384 /* table is gone through the rest of the IR must be connected back up to */ 04385 /* curr_stmt_sh_idx. */ 04386 04387 sh_after_entry_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 04388 SH_NEXT_IDX(curr_stmt_sh_idx) = NULL_IDX; 04389 SH_PREV_IDX(sh_after_entry_idx) = NULL_IDX; 04390 04391 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1 && 04392 ATP_PGM_UNIT(pgm_attr_idx) <= Program) { 04393 04394 /* If -G0 or -G1 specified and this is not a module or blockdata, */ 04395 /* we need to correct the line number for the Ldbg_End_Prologue */ 04396 /* label. The label needs to point to the first executable */ 04397 /* statement. Pass up all data and initialization statements. */ 04398 /* These do not count as executable statements for debug. */ 04399 04400 idx = SH_NEXT_IDX(sh_after_entry_idx); 04401 label_sh_idx = sh_after_entry_idx; 04402 04403 while (SH_STMT_TYPE(idx) == Type_Init_Stmt || 04404 SH_STMT_TYPE(idx) == Data_Stmt) { 04405 idx = SH_NEXT_IDX(idx); 04406 } 04407 04408 if (idx != SH_NEXT_IDX(sh_after_entry_idx)) { 04409 04410 /* Move End_Prologue_Label after initialization statements. */ 04411 /* Do not reconnect SH_NEXT_IDX of curr_stmt_sh_idx. It */ 04412 /* will be connected after decl_semantics. */ 04413 04414 sh_after_entry_idx = SH_NEXT_IDX(label_sh_idx); 04415 SH_PREV_IDX(sh_after_entry_idx) = NULL_IDX; 04416 04417 SH_NEXT_IDX(label_sh_idx) = idx; 04418 04419 if (SH_PREV_IDX(idx)) { 04420 SH_NEXT_IDX(SH_PREV_IDX(idx)) = label_sh_idx; 04421 } 04422 SH_PREV_IDX(label_sh_idx) = SH_PREV_IDX(idx); 04423 SH_PREV_IDX(idx) = label_sh_idx; 04424 } 04425 04426 line = SH_GLB_LINE(idx); 04427 SH_GLB_LINE(label_sh_idx) = line; 04428 IR_LINE_NUM(SH_IR_IDX(label_sh_idx)) = line; 04429 IR_LINE_NUM_L(SH_IR_IDX(label_sh_idx)) = line; 04430 AT_DEF_LINE(IR_IDX_L(SH_IR_IDX(label_sh_idx))) = line; 04431 } 04432 04433 if (SCP_ALT_ENTRY_CNT(curr_scp_idx) > 0) { 04434 04435 if (ATP_PGM_UNIT(pgm_attr_idx) == Function && 04436 (TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(pgm_attr_idx))) == Character || 04437 ATD_ARRAY_IDX(ATP_RSLT_IDX(pgm_attr_idx)) != NULL_IDX)) { 04438 entry_idx = SCP_ENTRY_IDX(curr_scp_idx); 04439 04440 /* Add the main entry point to all the alternate entry points, */ 04441 /* so that tmps generated for bounds for the main entry point */ 04442 /* will not show up at other entry points. */ 04443 04444 while (entry_idx != NULL_IDX) { 04445 04446 /* Add the main attr to the entry attr list. */ 04447 04448 NTR_ATTR_LIST_TBL(list_idx); 04449 AL_ATTR_IDX(list_idx) = pgm_attr_idx; 04450 entry_attr_idx = AL_ATTR_IDX(entry_idx); 04451 04452 if (ATP_NO_ENTRY_LIST(entry_attr_idx) != NULL_IDX) { 04453 AL_NEXT_IDX(list_idx) = ATP_NO_ENTRY_LIST(entry_attr_idx); 04454 AL_ENTRY_COUNT(list_idx) = 04455 AL_ENTRY_COUNT(AL_NEXT_IDX(list_idx))+ 1; 04456 } 04457 else { 04458 AL_ENTRY_COUNT(list_idx) = 1; 04459 } 04460 04461 ATP_NO_ENTRY_LIST(entry_attr_idx) = list_idx; 04462 04463 /* Add the entry attr to the main attr's list */ 04464 04465 NTR_ATTR_LIST_TBL(list_idx); 04466 AL_ATTR_IDX(list_idx) = entry_attr_idx; 04467 04468 if (ATP_NO_ENTRY_LIST(pgm_attr_idx) != NULL_IDX) { 04469 AL_NEXT_IDX(list_idx) = ATP_NO_ENTRY_LIST(pgm_attr_idx); 04470 AL_ENTRY_COUNT(list_idx) = 04471 AL_ENTRY_COUNT(AL_NEXT_IDX(list_idx)) + 1; 04472 } 04473 else { 04474 AL_ENTRY_COUNT(list_idx) = 1; 04475 } 04476 04477 ATP_NO_ENTRY_LIST(pgm_attr_idx) = list_idx; 04478 04479 entry_list_idx = SCP_ENTRY_IDX(curr_scp_idx); 04480 04481 while (entry_list_idx != NULL_IDX) { 04482 04483 if (entry_attr_idx != AL_ATTR_IDX(entry_list_idx)) { 04484 NTR_ATTR_LIST_TBL(list_idx); 04485 AL_ATTR_IDX(list_idx) = entry_attr_idx; 04486 04487 if (ATP_NO_ENTRY_LIST(AL_ATTR_IDX(entry_list_idx)) != 04488 NULL_IDX) { 04489 AL_NEXT_IDX(list_idx) = 04490 ATP_NO_ENTRY_LIST(AL_ATTR_IDX(entry_list_idx)); 04491 AL_ENTRY_COUNT(list_idx) = 04492 AL_ENTRY_COUNT(AL_NEXT_IDX(list_idx)) + 1; 04493 } 04494 else { 04495 AL_ENTRY_COUNT(list_idx) = 1; 04496 } 04497 ATP_NO_ENTRY_LIST(AL_ATTR_IDX(entry_list_idx)) = list_idx; 04498 } 04499 entry_list_idx = AL_NEXT_IDX(entry_list_idx); 04500 } 04501 entry_idx = AL_NEXT_IDX(entry_idx); 04502 } 04503 } 04504 04505 /* Create a list for each darg, of entry points the darg is NOT at. */ 04506 /* Also, create a list of the SH index for each alternate entry point. */ 04507 04508 /* Process !DIR$ IGNORE TYPE AND KIND directive */ 04509 04510 darg_list_idx = SCP_DARG_LIST(curr_scp_idx); 04511 04512 while (darg_list_idx != NULL_IDX) { 04513 darg_idx = AL_ATTR_IDX(darg_list_idx); 04514 darg_list_idx = AL_NEXT_IDX(darg_list_idx); 04515 list_idx = NULL_IDX; 04516 04517 04518 if (SCP_IGNORE_TKR(curr_scp_idx) && 04519 AT_OBJ_CLASS(darg_idx) == Data_Obj) { 04520 04521 if (!fnd_semantic_err(Obj_Ignore_TKR, 04522 AT_DEF_LINE(darg_idx), 04523 AT_DEF_COLUMN(darg_idx), 04524 darg_idx, 04525 TRUE)) { 04526 ATD_IGNORE_TKR(darg_idx) = TRUE; 04527 } 04528 } 04529 04530 if (!darg_in_entry_list(darg_idx, pgm_attr_idx)) { 04531 NTR_ATTR_LIST_TBL(list_idx); 04532 AL_ATTR_IDX(list_idx) = pgm_attr_idx; 04533 AT_ALT_DARG(darg_idx) = TRUE; 04534 AL_ENTRY_COUNT(list_idx) = 1; 04535 04536 if (AT_OBJ_CLASS(darg_idx) == Data_Obj) { 04537 ATD_NO_ENTRY_LIST(darg_idx) = list_idx; 04538 } 04539 else { 04540 ATP_NO_ENTRY_LIST(darg_idx) = list_idx; 04541 } 04542 } 04543 04544 entry_list_idx = SCP_ENTRY_IDX(curr_scp_idx); 04545 04546 while(entry_list_idx != NULL_IDX) { 04547 entry_attr_idx = AL_ATTR_IDX(entry_list_idx); 04548 entry_list_idx = AL_NEXT_IDX(entry_list_idx); 04549 04550 if (!darg_in_entry_list(darg_idx, entry_attr_idx)) { 04551 prev_idx = list_idx; 04552 NTR_ATTR_LIST_TBL(list_idx); 04553 04554 if (prev_idx == NULL_IDX) { 04555 AL_ENTRY_COUNT(list_idx) = 1; 04556 04557 if (AT_OBJ_CLASS(darg_idx) == Data_Obj) { 04558 ATD_NO_ENTRY_LIST(darg_idx) = list_idx; 04559 } 04560 else { 04561 ATP_NO_ENTRY_LIST(darg_idx) = list_idx; 04562 } 04563 } 04564 else { 04565 AL_NEXT_IDX(prev_idx) = list_idx; 04566 04567 if (AT_OBJ_CLASS(darg_idx) == Data_Obj) { 04568 AL_ENTRY_COUNT(ATD_NO_ENTRY_LIST(darg_idx))+=1; 04569 } 04570 else { 04571 AL_ENTRY_COUNT(ATP_NO_ENTRY_LIST(darg_idx))+=1; 04572 } 04573 } 04574 AL_ATTR_IDX(list_idx) = entry_attr_idx; 04575 AT_ALT_DARG(darg_idx) = TRUE; 04576 } 04577 } 04578 } 04579 } 04580 else { 04581 darg_list_idx = SCP_DARG_LIST(curr_scp_idx); 04582 04583 while (darg_list_idx != NULL_IDX) { 04584 darg_idx = AL_ATTR_IDX(darg_list_idx); 04585 darg_list_idx = AL_NEXT_IDX(darg_list_idx); 04586 04587 if (SCP_IGNORE_TKR(curr_scp_idx) && 04588 AT_OBJ_CLASS(darg_idx) == Data_Obj) { 04589 04590 if (!fnd_semantic_err(Obj_Ignore_TKR, 04591 AT_DEF_LINE(darg_idx), 04592 AT_DEF_COLUMN(darg_idx), 04593 darg_idx, 04594 TRUE)) { 04595 ATD_IGNORE_TKR(darg_idx) = TRUE; 04596 } 04597 } 04598 } 04599 } 04600 04601 if (opt_flags.reshape) { 04602 04603 /* Set ATD_RESHAPE_ARRAY_OPT for specific attrs */ 04604 /* that are specified on the commandline. */ 04605 04606 reshape_array_semantics(); 04607 04608 } 04609 04610 /* There may be bounds temps hidden in the implicit table that need to be */ 04611 /* folded. These come up when something like IMPLICIT CHARACTER*(n) (a-z) */ 04612 /* is specified. This code checks the implicit table for this scope. */ 04613 04614 for (idx = 0; idx < MAX_IMPL_CHS; idx++) { 04615 04616 if (IM_SET(curr_scp_idx, idx) && 04617 TYP_TYPE(IM_TYPE_IDX(curr_scp_idx, idx)) == Character && 04618 TYP_FLD(IM_TYPE_IDX(curr_scp_idx, idx)) == AT_Tbl_Idx) { 04619 attr_semantics(TYP_IDX(IM_TYPE_IDX(curr_scp_idx, idx)), TRUE); 04620 } 04621 } 04622 04623 /* Process the program name first, so that any other object that needs */ 04624 /* to refer to it or check against it, gets the correct information. */ 04625 04626 attr_semantics(pgm_attr_idx, FALSE); 04627 04628 /* There are seperate lists for stride multipliers, extents, array lengths,*/ 04629 /* and max(0,char length) tmps. These can never share with character len, */ 04630 /* lower bound and upper bounds tmps, because the stride ect.. tmps all */ 04631 /* reference other tmps in their expressions. IR is generated and */ 04632 /* attached to curr_stmt_sh_idx for extents, strides, and lengths. If the */ 04633 /* object is an automatic object, the allocate IR will then generate. */ 04634 /* This allocate will always follow its length IR(s) and will be of the */ 04635 /* tmp = form. */ 04636 04637 for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 04638 name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) { 04639 04640 attr_idx = LN_ATTR_IDX(name_idx); 04641 attr_semantics(attr_idx, FALSE); 04642 } 04643 04644 al_idx = SCP_ATTR_LIST(curr_scp_idx); 04645 04646 while (al_idx != NULL_IDX) { 04647 attr_idx = AL_ATTR_IDX(al_idx); 04648 al_idx = AL_NEXT_IDX(al_idx); 04649 04650 attr_semantics(attr_idx, FALSE); 04651 } 04652 04653 # if !defined(_SINGLE_ALLOCS_FOR_AUTOMATIC) 04654 04655 /* Force saved automatic ir into statements */ 04656 04657 gen_multiple_automatic_allocate(NULL_IDX); 04658 04659 # endif 04660 04661 /* There may be statements before sh_after_entry_idx. */ 04662 /* Find the beginning before hooking up sh_after_entry_idx. */ 04663 04664 while (SH_PREV_IDX(sh_after_entry_idx) != NULL_IDX) { 04665 sh_after_entry_idx = SH_PREV_IDX(sh_after_entry_idx); 04666 } 04667 04668 /* There may be statements following curr_stmt_sh_idx. */ 04669 /* Find the end before hooking up sh_after_entry_idx. */ 04670 04671 while (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) { 04672 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 04673 } 04674 04675 if (init_sh_start_idx != NULL_IDX) { 04676 04677 /* Insert any default initialization Init_Oprs */ 04678 04679 SH_NEXT_IDX(init_sh_end_idx) = SH_NEXT_IDX(curr_stmt_sh_idx); 04680 SH_NEXT_IDX(curr_stmt_sh_idx) = init_sh_start_idx; 04681 SH_PREV_IDX(init_sh_start_idx) = curr_stmt_sh_idx; 04682 SH_PREV_IDX(SH_NEXT_IDX(init_sh_end_idx)) = init_sh_end_idx; 04683 curr_stmt_sh_idx = init_sh_end_idx; 04684 } 04685 04686 SH_NEXT_IDX(curr_stmt_sh_idx) = sh_after_entry_idx; 04687 SH_PREV_IDX(sh_after_entry_idx) = curr_stmt_sh_idx; 04688 04689 if (ATP_PGM_UNIT(pgm_attr_idx) == Function && 04690 SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX && 04691 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(pgm_attr_idx))) == Character) { 04692 04693 /* If this is a character function with character alternate entries */ 04694 /* equivalence all the character size temps together. */ 04695 04696 /* BHJ - JBL - You may want to make temps for constant */ 04697 /* size entries as well and equiv them too, but I'm not */ 04698 /* going to take the implementation quite that far. */ 04699 04700 count = 0; 04701 al_idx = SCP_ENTRY_IDX(curr_scp_idx); 04702 04703 while (al_idx != NULL_IDX) { 04704 rslt_idx = ATP_RSLT_IDX(AL_ATTR_IDX(al_idx)); 04705 04706 if (TYP_FLD(ATD_TYPE_IDX(rslt_idx)) == AT_Tbl_Idx) { 04707 NTR_EQ_TBL(eq_idx); 04708 EQ_LINE_NUM(eq_idx) = AT_DEF_LINE(rslt_idx); 04709 EQ_COLUMN_NUM(eq_idx) = AT_DEF_COLUMN(rslt_idx); 04710 EQ_ATTR_IDX(eq_idx) = TYP_IDX(ATD_TYPE_IDX(rslt_idx)); 04711 ATD_EQUIV(EQ_ATTR_IDX(eq_idx)) = TRUE; 04712 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 04713 04714 if (count == 0) { 04715 EQ_NEXT_EQUIV_GRP(eq_idx) = group; 04716 SCP_FIRST_EQUIV_GRP(curr_scp_idx) = eq_idx; 04717 group = eq_idx; 04718 } 04719 else { 04720 EQ_NEXT_EQUIV_OBJ(EQ_GRP_END_IDX(group)) = eq_idx; 04721 } 04722 EQ_GRP_END_IDX(group) = eq_idx; 04723 EQ_GRP_IDX(eq_idx) = group; 04724 count++; 04725 } 04726 al_idx = AL_NEXT_IDX(al_idx); 04727 } 04728 04729 if (count > 0 && 04730 TYP_FLD(ATD_TYPE_IDX(ATP_RSLT_IDX(pgm_attr_idx))) == AT_Tbl_Idx) { 04731 NTR_EQ_TBL(eq_idx); 04732 rslt_idx = ATP_RSLT_IDX(pgm_attr_idx); 04733 EQ_LINE_NUM(eq_idx) = AT_DEF_LINE(rslt_idx); 04734 EQ_COLUMN_NUM(eq_idx) = AT_DEF_COLUMN(rslt_idx); 04735 EQ_ATTR_IDX(eq_idx) = TYP_IDX(ATD_TYPE_IDX(rslt_idx)); 04736 ATD_EQUIV(EQ_ATTR_IDX(eq_idx)) = TRUE; 04737 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 04738 EQ_NEXT_EQUIV_OBJ(EQ_GRP_END_IDX(group)) = eq_idx; 04739 EQ_GRP_END_IDX(group) = eq_idx; 04740 EQ_GRP_IDX(eq_idx) = group; 04741 } 04742 else if (count == 1) { /* Only one item on the list - loose it */ 04743 SCP_FIRST_EQUIV_GRP(curr_scp_idx) = 04744 EQ_NEXT_EQUIV_GRP(SCP_FIRST_EQUIV_GRP(curr_scp_idx)); 04745 } 04746 } 04747 04748 if (ATP_ARGCHCK_ENTRY(pgm_attr_idx)) { 04749 insert_argchck_calls(sh_after_entry_idx, pgm_attr_idx); 04750 04751 if (SCP_ALT_ENTRY_CNT(curr_scp_idx) != 0) { 04752 entry_list_idx = SCP_ENTRY_IDX(curr_scp_idx); 04753 04754 while (entry_list_idx != NULL_IDX) { 04755 insert_argchck_calls(ATP_ENTRY_LABEL_SH_IDX(AL_ATTR_IDX( 04756 entry_list_idx)), 04757 AL_ATTR_IDX(entry_list_idx)); 04758 entry_list_idx = AL_NEXT_IDX(entry_list_idx); 04759 } 04760 } 04761 } 04762 04763 if (SCP_FIRST_EQUIV_GRP(curr_scp_idx) != NULL_IDX && 04764 num_prog_unit_errors == 0) { 04765 equivalence_semantics(); 04766 } 04767 04768 /* Put the list of alternate returns on the equiv list, if it exists. */ 04769 /* Do now, so it doesn't go throuh equivalence_semantics. */ 04770 04771 if (alt_entry_equiv_grp != NULL_IDX) { 04772 EQ_NEXT_EQUIV_GRP(alt_entry_equiv_grp)= SCP_FIRST_EQUIV_GRP(curr_scp_idx); 04773 EQ_SEMANTICS_DONE(alt_entry_equiv_grp)= TRUE; 04774 SCP_FIRST_EQUIV_GRP(curr_scp_idx) = alt_entry_equiv_grp; 04775 } 04776 04777 if (namelist_list_idx != NULL_IDX) { 04778 namelist_resolution(namelist_list_idx); 04779 } 04780 04781 #ifndef _ALLOCATE_IS_CALL 04782 if (allocatable_list_idx != NULL_IDX) { 04783 deallocate_local_allocatables(); 04784 } 04785 #endif 04786 04787 if (ATP_PGM_UNIT(pgm_attr_idx) == Function || 04788 ATP_PGM_UNIT(pgm_attr_idx) == Subroutine) { 04789 04790 if (SCP_COPY_ASSUMED_SHAPE(curr_scp_idx) && 04791 SCP_COPY_ASSUMED_LIST(curr_scp_idx) != NULL_IDX && 04792 IL_FLD(SCP_COPY_ASSUMED_LIST(curr_scp_idx)) != NO_Tbl_Idx) { 04793 04794 /* this is an error situation */ 04795 PRINTMSG(IL_LINE_NUM(IL_IDX(SCP_COPY_ASSUMED_LIST(curr_scp_idx))), 04796 1281, Error, 04797 IL_COL_NUM(IL_IDX(SCP_COPY_ASSUMED_LIST(curr_scp_idx)))); 04798 } 04799 else if (SCP_COPY_ASSUMED_SHAPE(curr_scp_idx)) { 04800 04801 idx = SCP_DARG_LIST(curr_scp_idx); 04802 04803 list_idx = NULL_IDX; 04804 OPND_IDX(opnd) = NULL_IDX; 04805 04806 while (idx != NULL_IDX) { 04807 04808 attr_idx = AL_ATTR_IDX(idx); 04809 04810 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 04811 ATD_ARRAY_IDX(attr_idx) != NULL_IDX && 04812 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape) { 04813 04814 if (list_idx == NULL_IDX) { 04815 NTR_IR_LIST_TBL(list_idx); 04816 OPND_FLD(opnd) = IL_Tbl_Idx; 04817 OPND_IDX(opnd) = list_idx; 04818 OPND_LIST_CNT(opnd) = 1; 04819 } 04820 else { 04821 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04822 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 04823 list_idx = IL_NEXT_LIST_IDX(list_idx); 04824 OPND_LIST_CNT(opnd) += 1; 04825 } 04826 04827 IL_FLD(list_idx) = AT_Tbl_Idx; 04828 IL_IDX(list_idx) = attr_idx; 04829 IL_LINE_NUM(list_idx) = 04830 IL_LINE_NUM(SCP_COPY_ASSUMED_LIST(curr_scp_idx)); 04831 IL_COL_NUM(list_idx) = 04832 IL_COL_NUM(SCP_COPY_ASSUMED_LIST(curr_scp_idx)); 04833 } 04834 04835 idx = AL_NEXT_IDX(idx); 04836 } 04837 04838 if (OPND_IDX(opnd) != NULL_IDX) { 04839 reassign_XT_temps = must_reassign_XT_temp(&opnd); 04840 shared_bd_idx = -1; 04841 list_idx = OPND_IDX(opnd); 04842 04843 while (list_idx != NULL_IDX) { 04844 curr_stmt_sh_idx = sh_after_entry_idx; 04845 gen_assumed_shape_copy(&IL_OPND(list_idx)); 04846 list_idx = IL_NEXT_LIST_IDX(list_idx); 04847 } 04848 } 04849 else { 04850 PRINTMSG(IL_LINE_NUM(SCP_COPY_ASSUMED_LIST(curr_scp_idx)), 04851 1304, Caution, 04852 IL_COL_NUM(SCP_COPY_ASSUMED_LIST(curr_scp_idx))); 04853 } 04854 } 04855 else if (SCP_COPY_ASSUMED_LIST(curr_scp_idx) != NULL_IDX) { 04856 list_idx = SCP_COPY_ASSUMED_LIST(curr_scp_idx); 04857 04858 while (list_idx) { 04859 shared_bd_idx = -1; 04860 COPY_OPND(opnd, IL_OPND(list_idx)); 04861 reassign_XT_temps = must_reassign_XT_temp(&opnd); 04862 list_idx2 = OPND_IDX(opnd); 04863 04864 while (list_idx2) { 04865 if (AT_DCL_ERR(IL_IDX(list_idx2))) { 04866 /* intentionally blank */ 04867 } 04868 else if (AT_OBJ_CLASS(IL_IDX(list_idx2)) != Data_Obj || 04869 ATD_ARRAY_IDX(IL_IDX(list_idx2)) == NULL_IDX || 04870 BD_ARRAY_CLASS(ATD_ARRAY_IDX(IL_IDX(list_idx2))) != 04871 Assumed_Shape) { 04872 04873 PRINTMSG(IL_LINE_NUM(list_idx2), 1303, Error, 04874 IL_COL_NUM(list_idx2)); 04875 } 04876 else { 04877 curr_stmt_sh_idx = sh_after_entry_idx; 04878 gen_assumed_shape_copy(&IL_OPND(list_idx2)); 04879 } 04880 04881 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 04882 } 04883 04884 list_idx = IL_NEXT_LIST_IDX(list_idx); 04885 } 04886 } 04887 04888 shared_bd_idx = NULL_IDX; 04889 } 04890 else { /* Module, blockdata or program */ 04891 04892 if (SCP_COPY_ASSUMED_LIST(curr_scp_idx) != NULL_IDX) { 04893 list_idx = SCP_COPY_ASSUMED_LIST(curr_scp_idx); 04894 04895 while (list_idx) { 04896 COPY_OPND(opnd, IL_OPND(list_idx)); 04897 list_idx2 = OPND_IDX(opnd); 04898 04899 while (list_idx2) { 04900 04901 if (AT_DCL_ERR(IL_IDX(list_idx2))) { 04902 /* intentionally blank */ 04903 } 04904 else { 04905 PRINTMSG(IL_LINE_NUM(list_idx2), 1303, Error, 04906 IL_COL_NUM(list_idx2)); 04907 } 04908 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 04909 } 04910 04911 list_idx = IL_NEXT_LIST_IDX(list_idx); 04912 } 04913 } 04914 } 04915 04916 # if 0 /* fzhao get rid of "start_pes" call */ 04917 # ifdef COARRAY_FORTRAN 04918 04919 # if ! defined(_TARGET_OS_MAX) 04920 04921 if (cmd_line_flags.co_array_fortran && 04922 ATP_PGM_UNIT(pgm_attr_idx) == Program) { 04923 /* insert call to start_pes(0) */ 04924 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04925 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 04926 04927 OPND_FLD(opnd) = CN_Tbl_Idx; 04928 OPND_IDX(opnd) = CN_INTEGER_ZERO_IDX; 04929 OPND_LINE_NUM(opnd) = AT_DEF_LINE(pgm_attr_idx); 04930 OPND_COL_NUM(opnd) = AT_DEF_COLUMN(pgm_attr_idx); 04931 04932 gen_internal_call_stmt(START_PES_LIB_ENTRY, 04933 &opnd, 04934 After); 04935 04936 PRINTMSG(AT_DEF_LINE(pgm_attr_idx), 1460, Warning, 04937 AT_DEF_COLUMN(pgm_attr_idx)); 04938 04939 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 04940 } 04941 # endif 04942 # endif 04943 04944 # endif /* fzhao */ 04945 04946 if (SCP_DARG_LIST(curr_scp_idx) != NULL_IDX) { 04947 free_attr_list(SCP_DARG_LIST(curr_scp_idx)); 04948 SCP_DARG_LIST(curr_scp_idx) = NULL_IDX; 04949 } 04950 04951 SCP_RESHAPE_ARRAY_LIST(curr_scp_idx) = reshape_array_list; 04952 reshape_array_list = NULL_IDX; 04953 04954 TRACE (Func_Exit, "decl_semantics", NULL); 04955 04956 return; 04957 04958 } /* decl_semantics */ 04959 04960 /******************************************************************************\ 04961 |* *| 04962 |* Description: *| 04963 |* attr_semantics calls itself recursively to find all attr *| 04964 |* dependencies. Then it does all the semantic checking it can think of.*| 04965 |* *| 04966 |* Input parameters: *| 04967 |* NONE *| 04968 |* *| 04969 |* Output parameters: *| 04970 |* NONE *| 04971 |* *| 04972 |* Returns: *| 04973 |* NONE *| 04974 |* *| 04975 \******************************************************************************/ 04976 static void attr_semantics(int attr_idx, 04977 boolean bound_attr) 04978 04979 { 04980 int al_idx; 04981 int bd_idx; 04982 int column; 04983 int count; 04984 int curr_fwd_ref_idx; 04985 int darg_idx; 04986 int dim; 04987 int dt_idx; 04988 int end_entry_sh_idx; 04989 int entry_sh_idx; 04990 int eq_idx; 04991 expr_arg_type expr_desc; 04992 int first_idx; 04993 int i; 04994 int ir_idx; 04995 boolean is_interface; 04996 int line; 04997 int link_idx; 04998 int name_idx; 04999 int new_bd_idx; 05000 int old_fwd_ref_idx; 05001 opnd_type opnd; 05002 int pgm_attr_idx; 05003 int pgm_idx; 05004 int pointer_idx; 05005 int proc_idx; 05006 char *pure_str; 05007 int rslt_idx; 05008 int scp_idx; 05009 int sf_attr_idx; 05010 int sn_attr_idx; 05011 int sn_idx; 05012 id_str_type storage_name; 05013 int tmp_ir_idx; 05014 int type_idx; 05015 boolean type_resolved; 05016 size_offset_type storage_size; 05017 05018 # if defined(_TARGET_OS_MAX) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 05019 int tmp_idx; 05020 # endif 05021 05022 05023 TRACE (Func_Entry, "attr_semantics", NULL); 05024 05025 is_interface = SCP_IS_INTERFACE(curr_scp_idx); 05026 05027 if (AT_SEMANTICS_DONE(attr_idx) || 05028 AT_DCL_ERR(attr_idx) || 05029 AT_ATTR_LINK(attr_idx) != NULL_IDX) { 05030 AT_SEMANTICS_DONE(attr_idx) = TRUE; 05031 05032 if (AT_OBJ_CLASS(attr_idx) != Interface || 05033 AT_DCL_ERR(attr_idx) || 05034 AT_ATTR_LINK(attr_idx) == NULL_IDX) { 05035 05036 if (is_interface) { 05037 05038 switch(AT_OBJ_CLASS(attr_idx)) { 05039 case Pgm_Unit: 05040 ATP_SCP_IDX(attr_idx) = SCP_PARENT_IDX(curr_scp_idx); 05041 break; 05042 05043 case Derived_Type: 05044 ATT_SCP_IDX(attr_idx) = SCP_PARENT_IDX(curr_scp_idx); 05045 break; 05046 } 05047 } 05048 05049 return; 05050 } 05051 } 05052 05053 pgm_attr_idx = SCP_ATTR_IDX(curr_scp_idx); 05054 05055 /* Mark this flag TRUE, for all objects declared in the module, if */ 05056 /* this is a module. The purpose of this flag is to separate */ 05057 /* objects from any module procedures from the objects in the */ 05058 /* module itself. The classic case is the same named derived type */ 05059 /* declared in the module and the module procedure. The module */ 05060 /* procedure is of this type. Because we match on AT_MODULE_IDX */ 05061 /* and AT_USE_ASSOCIATED in resolve_attr during use processing, we */ 05062 /* have no way of knowing that these two types are not the same. */ 05063 /* This flag will differentiate between them, because only the */ 05064 /* module procedure name itself will come through this routine */ 05065 /* when pgm_attr_idx is set to the module. AT_MODULE_IDX and */ 05066 /* AT_USE_ASSOCIATED cannot be used to determine this, because */ 05067 /* they are set for everything coming out of a module at USE time. */ 05068 05069 if (ATP_PGM_UNIT(pgm_attr_idx) == Module && !AT_USE_ASSOCIATED(attr_idx)) { 05070 AT_MODULE_OBJECT(attr_idx) = TRUE; 05071 } 05072 05073 switch(AT_OBJ_CLASS(attr_idx)) { 05074 case Data_Obj: 05075 05076 switch (ATD_CLASS(attr_idx)) { 05077 case Atd_Unknown: 05078 05079 /* All data objs that do not resolve to something else are variables.*/ 05080 05081 ATD_CLASS(attr_idx) = Variable; 05082 break; 05083 05084 case Function_Result: 05085 05086 /* These are done when the pgm_unit is processed, */ 05087 /* so process the program unit now. */ 05088 05089 attr_semantics(ATD_FUNC_IDX(attr_idx), FALSE); 05090 05091 return; 05092 05093 case Compiler_Tmp: 05094 05095 if (AT_REFERENCED(attr_idx) == Not_Referenced) { 05096 05097 /* LRR - You're going to get more than bound attrs here. */ 05098 05099 /* Bound tmp saved just for CIF - These are bound_attrs, but */ 05100 /* only process them if CIF XREFS is on. */ 05101 05102 if ((cif_flags & XREF_RECS) != 0) { 05103 bound_attr = TRUE; 05104 } 05105 else { 05106 goto EXIT; 05107 } 05108 } 05109 break; 05110 05111 case Constant: 05112 05113 if (ATP_PGM_UNIT(pgm_attr_idx) == Module && 05114 ATD_FLD(attr_idx) == AT_Tbl_Idx && 05115 AT_OBJ_CLASS(ATD_CONST_IDX(attr_idx)) == Data_Obj && 05116 ATD_CLASS(ATD_CONST_IDX(attr_idx)) == Compiler_Tmp && 05117 ATD_TMP_INIT_NOT_DONE(ATD_CONST_IDX(attr_idx))) { 05118 05119 /* Do all the init stmts for module parameters */ 05120 05121 insert_init_stmt_for_tmp(ATD_CONST_IDX(attr_idx)); 05122 } 05123 break; 05124 05125 } /* End switch */ 05126 05127 type_idx = ATD_TYPE_IDX(attr_idx); 05128 05129 if (TYP_TYPE(type_idx) == Structure) { 05130 05131 if (AT_ATTR_LINK(TYP_IDX(type_idx)) != NULL_IDX) { 05132 05133 /* If this derived type is host associated (AT_ATTR_LINK is set) */ 05134 /* change the type table to point to the original type. It is */ 05135 /* okay to change the type table, because every attr of this type */ 05136 /* needs to do this. */ 05137 05138 link_idx = TYP_IDX(type_idx); 05139 05140 while (AT_ATTR_LINK(link_idx) != NULL_IDX) { 05141 link_idx = AT_ATTR_LINK(link_idx); 05142 } 05143 05144 TYP_IDX(type_idx) = link_idx; 05145 } 05146 05147 attr_semantics(TYP_IDX(type_idx), FALSE); 05148 } 05149 05150 if (ATP_PGM_UNIT(pgm_attr_idx) == Module && 05151 ATD_CLASS(attr_idx) != Struct_Component) { 05152 05153 if (TYP_TYPE(type_idx) == Structure && 05154 !AT_PRIVATE(attr_idx) && 05155 AT_PRIVATE(TYP_IDX(type_idx)) && 05156 !AT_USE_ASSOCIATED(TYP_IDX(type_idx))) { /* Interp 161 */ 05157 PRINTMSG(AT_DEF_LINE(attr_idx), 598, Error, 05158 AT_DEF_COLUMN(attr_idx), 05159 AT_OBJ_NAME_PTR(attr_idx), 05160 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 05161 } 05162 05163 if (ATD_CLASS(attr_idx) == CRI__Pointee) { 05164 attr_semantics(ATD_PTR_IDX(attr_idx), FALSE); 05165 05166 if (AT_PRIVATE(attr_idx) != AT_PRIVATE(ATD_PTR_IDX(attr_idx))) { 05167 PRINTMSG(AT_DEF_LINE(attr_idx), 697, Error, 05168 AT_DEF_COLUMN(attr_idx), 05169 AT_OBJ_NAME_PTR(ATD_PTR_IDX(attr_idx)), 05170 AT_OBJ_NAME_PTR(attr_idx)); 05171 } 05172 } 05173 } 05174 05175 if (ATP_PURE(pgm_attr_idx) || ATP_ELEMENTAL(pgm_attr_idx)) { 05176 05177 if (ATD_IN_COMMON(attr_idx) || 05178 AT_USE_ASSOCIATED(attr_idx) || 05179 AT_HOST_ASSOCIATED(attr_idx) || 05180 (ATD_CLASS(attr_idx) == Dummy_Argument && 05181 (ATP_PGM_UNIT(pgm_attr_idx) == Function || 05182 (ATP_PGM_UNIT(pgm_attr_idx) == Subroutine && 05183 ATD_INTENT(attr_idx) == Intent_In)))) { 05184 05185 /* Mark this, so that this object does not get defined. */ 05186 05187 ATD_PURE(attr_idx) = TRUE; 05188 } 05189 05190 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) { 05191 PRINTMSG(BD_LINE_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 1580, Error, 05192 BD_COLUMN_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 05193 AT_OBJ_NAME_PTR(pgm_attr_idx), 05194 AT_OBJ_NAME_PTR(attr_idx)); 05195 } 05196 } 05197 05198 if (AT_USE_ASSOCIATED(attr_idx)) { 05199 goto EXIT; 05200 } 05201 05202 if (bound_attr && ATD_CLASS(attr_idx) == Compiler_Tmp) { 05203 05204 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) { 05205 attr_semantics(ATD_TMP_IDX(attr_idx), FALSE); 05206 } 05207 else if (ATD_FLD(attr_idx) == IR_Tbl_Idx) { 05208 ir_idx = ATD_TMP_IDX(attr_idx); 05209 05210 switch (IR_FLD_R(ir_idx)) { 05211 case AT_Tbl_Idx: 05212 attr_semantics(IR_IDX_R(ir_idx), FALSE); 05213 break; 05214 05215 case IR_Tbl_Idx: 05216 tmp_ir_resolution(IR_IDX_R(ir_idx)); 05217 break; 05218 05219 case IL_Tbl_Idx: 05220 tmp_il_resolution(IR_IDX_R(ir_idx)); 05221 break; 05222 } 05223 } 05224 05225 bound_resolution(attr_idx); 05226 } 05227 05228 05229 if (TYP_TYPE(type_idx) == Character) { 05230 05231 if (TYP_FLD(type_idx) == AT_Tbl_Idx) { 05232 attr_semantics(TYP_IDX(type_idx), TRUE); 05233 } 05234 } 05235 05236 bd_idx = ATD_ARRAY_IDX(attr_idx); 05237 05238 if (bd_idx != NULL_IDX && BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) { 05239 05240 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 05241 05242 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 05243 attr_semantics(BD_LB_IDX(bd_idx, dim), TRUE); 05244 } 05245 05246 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 05247 attr_semantics(BD_UB_IDX(bd_idx, dim), TRUE); 05248 } 05249 } 05250 } 05251 05252 bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 05253 05254 if (bd_idx != NULL_IDX && BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) { 05255 05256 # if 0 05257 /* this error is disabled for now. It was a little too strong */ 05258 /* Perhaps it must be common or dummy arg. */ 05259 if (! ATD_IN_COMMON(attr_idx)) { 05260 PRINTMSG(BD_LINE_NUM(bd_idx), 1365, Error, 05261 BD_COLUMN_NUM(bd_idx), 05262 AT_OBJ_NAME_PTR(attr_idx)); 05263 AT_DCL_ERR(attr_idx) = TRUE; 05264 } 05265 # endif 05266 05267 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 05268 05269 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 05270 attr_semantics(BD_LB_IDX(bd_idx, dim), TRUE); 05271 } 05272 05273 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 05274 attr_semantics(BD_UB_IDX(bd_idx, dim), TRUE); 05275 } 05276 } 05277 } 05278 05279 05280 if (!AT_TYPED(attr_idx)) { 05281 05282 if (SCP_IMPL_NONE(curr_scp_idx)) { 05283 AT_DCL_ERR(attr_idx) = TRUE; 05284 PRINTMSG(AT_DEF_LINE(attr_idx), 113, Error, 05285 AT_DEF_COLUMN(attr_idx), 05286 AT_OBJ_NAME_PTR(attr_idx)); 05287 } 05288 else if (!IM_SET(curr_scp_idx, IMPL_IDX(AT_OBJ_NAME(attr_idx)))) { 05289 05290 if (SCP_PARENT_NONE(curr_scp_idx)) { 05291 AT_DCL_ERR(attr_idx) = TRUE; 05292 PRINTMSG(AT_DEF_LINE(attr_idx), 297, Error, 05293 AT_DEF_COLUMN(attr_idx), 05294 AT_OBJ_NAME_PTR(attr_idx)); 05295 } 05296 else if (on_off_flags.implicit_none) { 05297 AT_DCL_ERR(attr_idx) = TRUE; 05298 PRINTMSG(AT_DEF_LINE(attr_idx), 1171, Error, 05299 AT_DEF_COLUMN(attr_idx), 05300 AT_OBJ_NAME_PTR(attr_idx)); 05301 } 05302 } 05303 } 05304 05305 /* char_len_resolution MUST happen before array_dim_resolution */ 05306 /* because the character length is used to calculate the stride */ 05307 /* multiplier stored in the bounds table array entry. */ 05308 05309 if (TYP_TYPE(type_idx) == Character) { 05310 char_len_resolution(attr_idx, FALSE); 05311 05312 /* reset the type_idx in case it changes */ 05313 05314 type_idx = ATD_TYPE_IDX(attr_idx); 05315 } 05316 05317 if (AT_DCL_ERR(attr_idx)) { 05318 goto EXIT; 05319 } 05320 05321 if (ATD_ALLOCATABLE(attr_idx)) { 05322 /* ATD_IM_A_DOPE(attr_idx) = TRUE; */ 05323 05324 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX || 05325 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Deferred_Shape && 05326 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Deferred_Shape1 ) { 05327 AT_DCL_ERR(attr_idx) = TRUE; 05328 PRINTMSG(AT_DEF_LINE(attr_idx), 570, Error, 05329 AT_DEF_COLUMN(attr_idx), 05330 AT_OBJ_NAME_PTR(attr_idx)); 05331 } 05332 05333 # ifdef COARRAY_FORTRAN 05334 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX && 05335 BD_ARRAY_CLASS(ATD_PE_ARRAY_IDX(attr_idx)) != Deferred_Shape) { 05336 AT_DCL_ERR(attr_idx) = TRUE; 05337 PRINTMSG(AT_DEF_LINE(attr_idx), 1552, Error, 05338 AT_DEF_COLUMN(attr_idx), 05339 AT_OBJ_NAME_PTR(attr_idx)); 05340 } 05341 # endif 05342 } 05343 05344 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 05345 05346 /* If -O fld is set and this is an explicit shape (rank > 1) */ 05347 /* array that has not been specified in a -O fld=array_name */ 05348 /* option, then set ATD_RESHAPE_ARRAY_OPT to TRUE. */ 05349 05350 if (opt_flags.reshape_all_arrays && 05351 BD_RANK(ATD_ARRAY_IDX(attr_idx)) > 1 && 05352 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Explicit_Shape && 05353 (ATD_CLASS(attr_idx) != CRI__Pointee && 05354 ATD_CLASS(attr_idx) != Constant) && 05355 BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), 05356 BD_RANK(ATD_ARRAY_IDX(attr_idx))) == CN_Tbl_Idx && 05357 compare_cn_and_value(BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), 05358 BD_RANK(ATD_ARRAY_IDX(attr_idx))), 05359 1, 05360 Eq_Opr) && 05361 BD_UB_FLD(ATD_ARRAY_IDX(attr_idx), 05362 BD_RANK(ATD_ARRAY_IDX(attr_idx))) == CN_Tbl_Idx && 05363 compare_cn_and_value(BD_UB_IDX(ATD_ARRAY_IDX(attr_idx), 05364 BD_RANK(ATD_ARRAY_IDX(attr_idx))), 05365 16, 05366 Lt_Opr) && 05367 !ATD_RESHAPE_ARRAY_OPT(attr_idx)) { 05368 05369 if (ATD_DATA_INIT(attr_idx)) { 05370 PRINTMSG(AT_DEF_LINE(attr_idx), 1644, Error, 05371 AT_DEF_COLUMN(attr_idx), 05372 AT_OBJ_NAME_PTR(attr_idx)); 05373 } 05374 ATD_RESHAPE_ARRAY_OPT(attr_idx) = TRUE; 05375 NTR_ATTR_LIST_TBL(al_idx); 05376 AL_ATTR_IDX(al_idx) = attr_idx; 05377 AL_NEXT_IDX(al_idx) = reshape_array_list; 05378 reshape_array_list = al_idx; 05379 } 05380 05381 if (ATD_RESHAPE_ARRAY_OPT(attr_idx)) { 05382 05383 PRINTMSG(AT_DEF_LINE(attr_idx), 1637, Optimization, 0, 05384 "-O reshape", 05385 AT_OBJ_NAME_PTR(attr_idx)); 05386 05387 /* create the new bounds entry with the swapped dimensions */ 05388 05389 bd_idx = ATD_ARRAY_IDX(attr_idx); 05390 05391 new_bd_idx = reserve_array_ntry(BD_RANK(bd_idx)); 05392 BD_RANK(new_bd_idx) = BD_RANK(bd_idx); 05393 BD_LINE_NUM(new_bd_idx) = BD_LINE_NUM(bd_idx); 05394 BD_COLUMN_NUM(new_bd_idx) = BD_COLUMN_NUM(bd_idx); 05395 BD_ARRAY_CLASS(new_bd_idx) = BD_ARRAY_CLASS(bd_idx); 05396 BD_RESOLVED(new_bd_idx) = FALSE; 05397 05398 dim = 1; 05399 05400 BD_LB_FLD(new_bd_idx,dim) = BD_LB_FLD(bd_idx,BD_RANK(bd_idx)); 05401 BD_LB_IDX(new_bd_idx,dim) = BD_LB_IDX(bd_idx,BD_RANK(bd_idx)); 05402 05403 BD_UB_FLD(new_bd_idx,dim) = BD_UB_FLD(bd_idx,BD_RANK(bd_idx)); 05404 BD_UB_IDX(new_bd_idx,dim) = BD_UB_IDX(bd_idx,BD_RANK(bd_idx)); 05405 05406 for (i = 1; i < BD_RANK(bd_idx); i++) { 05407 dim++; 05408 BD_LB_FLD(new_bd_idx,dim) = BD_LB_FLD(bd_idx,i); 05409 BD_LB_IDX(new_bd_idx,dim) = BD_LB_IDX(bd_idx,i); 05410 05411 BD_UB_FLD(new_bd_idx,dim) = BD_UB_FLD(bd_idx,i); 05412 BD_UB_IDX(new_bd_idx,dim) = BD_UB_IDX(bd_idx,i); 05413 } 05414 05415 new_bd_idx = ntr_array_in_bd_tbl(new_bd_idx); 05416 05417 array_dim_resolution(attr_idx, FALSE); 05418 bd_idx = ATD_ARRAY_IDX(attr_idx); 05419 05420 if (! AT_DCL_ERR(attr_idx) && 05421 ! BD_DCL_ERR(bd_idx)) { 05422 05423 ATD_ARRAY_IDX(attr_idx) = new_bd_idx; 05424 array_dim_resolution(attr_idx, FALSE); 05425 ATD_RESHAPE_ARRAY_IDX(attr_idx) = ATD_ARRAY_IDX(attr_idx); 05426 ATD_ARRAY_IDX(attr_idx) = bd_idx; 05427 } 05428 } 05429 else { 05430 array_dim_resolution(attr_idx, FALSE); 05431 } 05432 } 05433 05434 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) { 05435 pe_array_dim_resolution(attr_idx); 05436 } 05437 05438 if (ATD_DISTRIBUTION_IDX(attr_idx) != NULL_IDX) { 05439 distribution_resolution(attr_idx); 05440 } 05441 05442 if (ATD_POINTER(attr_idx) && ATD_CLASS(attr_idx) != Dummy_Argument) { 05443 /* ATD_IM_A_DOPE(attr_idx) = TRUE; */ 05444 } 05445 05446 # if 0 05447 /* BHJ DOPE VECTOR TARGET */ 05448 /* save this in case the interp changes. */ 05449 05450 if (ATD_TARGET(attr_idx) && ATD_CLASS(attr_idx) == Dummy_Argument) { 05451 /* ATD_IM_A_DOPE(attr_idx) = TRUE; */ 05452 } 05453 # endif 05454 05455 if (ATD_AUTOMATIC(attr_idx)) { 05456 05457 if (ATD_IM_A_DOPE(attr_idx)) { /* If defrd array, its not auto */ 05458 ATD_NO_ENTRY_LIST(attr_idx) = NULL_IDX; /* Only good for autos */ 05459 ATD_AUTOMATIC(attr_idx) = FALSE; 05460 } 05461 else if (!is_interface) { 05462 05463 if (ATP_SYMMETRIC(pgm_attr_idx)) { 05464 05465 /* Check to see if this can be switched to symmetric. */ 05466 /* The only thing AUTOMATIC can be, that SYMMETRIC */ 05467 /* cannot be is TARGET, so check that. */ 05468 05469 if (ATD_TARGET(attr_idx)) { 05470 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05471 AT_DEF_COLUMN(attr_idx), 05472 AT_OBJ_NAME_PTR(attr_idx), 05473 "TARGET"); 05474 } 05475 else { 05476 ATD_SYMMETRIC(attr_idx) = TRUE; 05477 } 05478 } 05479 ATD_AUTOMATIC(attr_idx) = FALSE; 05480 ATD_NO_ENTRY_LIST(attr_idx) = NULL_IDX; 05481 ATD_IM_A_DOPE(attr_idx) = FALSE; 05482 05483 #if 0 05484 # if defined(_SINGLE_ALLOCS_FOR_AUTOMATIC) 05485 gen_single_automatic_allocate(attr_idx); 05486 # else 05487 05488 if (TYP_TYPE(type_idx) == Character || 05489 (TYP_TYPE(type_idx) == Structure && 05490 ATT_CHAR_SEQ(TYP_IDX(type_idx)))) { 05491 gen_single_automatic_allocate(attr_idx); 05492 } 05493 else { 05494 gen_multiple_automatic_allocate(attr_idx); 05495 } 05496 # endif 05497 # endif 05498 } 05499 } 05500 05501 if (TYP_TYPE(type_idx) == Character && 05502 ATD_CLASS(attr_idx) != CRI__Pointee && 05503 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char && 05504 TYP_FLD(type_idx) == AT_Tbl_Idx && 05505 AT_OBJ_CLASS(TYP_IDX(type_idx)) == Data_Obj) { 05506 05507 tmp_ir_idx = ATD_TMP_IDX(TYP_IDX(type_idx)); 05508 05509 COPY_OPND(opnd, IR_OPND_R(tmp_ir_idx)); 05510 fold_clen_opr(&opnd, &expr_desc); 05511 COPY_OPND(IR_OPND_R(tmp_ir_idx), opnd); 05512 } 05513 05514 if (TYP_TYPE(type_idx) == Structure && 05515 ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx))) { 05516 05517 if (ATD_IN_COMMON(attr_idx)) { 05518 AT_DCL_ERR(attr_idx) = TRUE; 05519 PRINTMSG(AT_DEF_LINE(attr_idx), 1600, Error, 05520 AT_DEF_COLUMN(attr_idx), 05521 AT_OBJ_NAME_PTR(attr_idx), 05522 AT_OBJ_NAME_PTR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))); 05523 } 05524 else if (ATD_CLASS(attr_idx) == CRI__Pointee) { 05525 PRINTMSG(AT_DEF_LINE(attr_idx), 1647, Warning, 05526 AT_DEF_COLUMN(attr_idx), 05527 AT_OBJ_NAME_PTR(attr_idx)); 05528 } 05529 } 05530 05531 05532 # if 0 05533 /* BHJ DOPE VECTOR TARGET */ 05534 /* save the old version of this condition in case */ 05535 /* the target dummy arg interp changes. */ 05536 05537 if (!is_interface && 05538 (ATD_IM_A_DOPE(attr_idx) && 05539 (ATD_CLASS(attr_idx) != Dummy_Argument || 05540 (ATD_ARRAY_IDX(attr_idx) && 05541 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape) || 05542 (ATD_TARGET(attr_idx)))) || 05543 05544 (TYP_TYPE(type_idx) == Structure && 05545 ATD_CLASS(attr_idx) != Constant && 05546 (ATD_CLASS(attr_idx) != Dummy_Argument || 05547 ATD_INTENT(attr_idx) == Intent_Out) && 05548 ATD_CLASS(attr_idx) != CRI__Pointee && 05549 ((ATT_POINTER_CPNT(TYP_IDX(type_idx)) || 05550 ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx))) && 05551 !ATD_DATA_INIT(attr_idx)))) { 05552 # else 05553 if (!is_interface && 05554 05555 (ATD_IM_A_DOPE(attr_idx) && 05556 (ATD_CLASS(attr_idx) != Dummy_Argument || 05557 (ATD_ARRAY_IDX(attr_idx) && 05558 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape))) || 05559 05560 /* Follows is the default init check */ 05561 05562 (TYP_TYPE(type_idx) == Structure && 05563 ATD_CLASS(attr_idx) != Constant && 05564 (ATD_CLASS(attr_idx) != Dummy_Argument || 05565 ATD_INTENT(attr_idx) == Intent_Out) && 05566 ATD_CLASS(attr_idx) != CRI__Pointee && 05567 (ATT_POINTER_CPNT(TYP_IDX(type_idx)) || 05568 (ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx)) && 05569 !ATD_DATA_INIT(attr_idx))))) { 05570 # endif 05571 05572 entry_sh_idx = curr_stmt_sh_idx; 05573 end_entry_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 05574 05575 if (ATD_IM_A_DOPE(attr_idx) && 05576 ATD_CLASS(attr_idx) == Dummy_Argument && 05577 ATD_ARRAY_IDX(attr_idx) && 05578 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape) { 05579 05580 /* Fill in the lower bound of Assumed Shape dummy arg here */ 05581 /* TARGET will go here also */ 05582 05583 for (i = 1; i <= BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) { 05584 05585 NTR_IR_TBL(ir_idx); 05586 IR_OPR(ir_idx) = Dv_Set_Low_Bound; 05587 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 05588 IR_LINE_NUM(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05589 IR_COL_NUM(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx); 05590 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 05591 IR_IDX_L(ir_idx) = attr_idx; 05592 IR_LINE_NUM_L(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05593 IR_COL_NUM_L(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx); 05594 05595 IR_FLD_R(ir_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i); 05596 IR_IDX_R(ir_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i); 05597 IR_LINE_NUM_R(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05598 IR_COL_NUM_R(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx); 05599 05600 IR_DV_DIM(ir_idx) = i; 05601 05602 gen_sh(After, Assignment_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 05603 SH_COL_NUM(curr_stmt_sh_idx), FALSE, FALSE, TRUE); 05604 05605 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05606 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05607 } 05608 05609 # if defined(GENERATE_WHIRL) 05610 # if 0 05611 if (! ATD_COPY_ASSUMED_SHAPE(attr_idx)) { 05612 /* copy the assumed shape dummy arg to a stack dope vector */ 05613 05614 tmp_idx = gen_compiler_tmp(SH_GLB_LINE(curr_stmt_sh_idx), 05615 SH_COL_NUM(curr_stmt_sh_idx), 05616 Shared, TRUE); 05617 05618 COPY_ATTR_NTRY(tmp_idx, attr_idx); 05619 05620 ATD_CLASS(tmp_idx) = Compiler_Tmp; 05621 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 05622 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 05623 05624 NTR_IR_TBL(ir_idx); 05625 IR_OPR(ir_idx) = Dv_Whole_Copy_Opr; 05626 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 05627 IR_LINE_NUM(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05628 IR_COL_NUM(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx); 05629 05630 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 05631 IR_IDX_L(ir_idx) = tmp_idx; 05632 IR_LINE_NUM_L(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05633 IR_COL_NUM_L(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx); 05634 05635 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 05636 IR_IDX_R(ir_idx) = attr_idx; 05637 IR_LINE_NUM_R(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05638 IR_COL_NUM_R(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx); 05639 05640 gen_sh(After, Assignment_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 05641 SH_COL_NUM(curr_stmt_sh_idx), FALSE, FALSE, TRUE); 05642 05643 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05644 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05645 05646 ATD_SF_ARG_IDX(attr_idx) = tmp_idx; 05647 } 05648 # endif 05649 05650 # if 0 05651 } /* This is here, just so that { }'s match. */ 05652 # endif 05653 # endif 05654 } 05655 else if (ATP_PGM_UNIT(pgm_attr_idx) != Blockdata && 05656 (ATD_CLASS(attr_idx) != Dummy_Argument || 05657 (ATD_INTENT(attr_idx) == Intent_Out && 05658 ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx))))) { 05659 05660 /* Do not generate entry code for block data program units. */ 05661 /* It is meaningless and PVP codegen blows up. */ 05662 05663 /* fzhao gen_entry_dope_code(attr_idx); */ 05664 } 05665 05666 if (end_entry_sh_idx == NULL_IDX) { 05667 05668 /* find the end of the gen'd stmts */ 05669 05670 end_entry_sh_idx = entry_sh_idx; 05671 05672 while (SH_NEXT_IDX(end_entry_sh_idx) != NULL_IDX) { 05673 end_entry_sh_idx = SH_NEXT_IDX(end_entry_sh_idx); 05674 } 05675 } 05676 else { 05677 end_entry_sh_idx = SH_PREV_IDX(end_entry_sh_idx); 05678 } 05679 05680 if (ATD_AUTOMATIC(attr_idx)) { 05681 05682 /* reset the curr_stmt_sh_idx if automatic, to get order right */ 05683 05684 curr_stmt_sh_idx = entry_sh_idx; 05685 } 05686 05687 if (ATD_ALLOCATABLE(attr_idx) && 05688 ATP_PGM_UNIT(pgm_attr_idx) != Module && 05689 ! ATP_SAVE_ALL(pgm_attr_idx) && 05690 ! ATD_DATA_INIT(attr_idx) && 05691 ! ATD_SAVED(attr_idx)) { 05692 05693 NTR_SN_TBL(sn_idx); 05694 05695 SN_SIBLING_LINK(sn_idx) = allocatable_list_idx; 05696 allocatable_list_idx = sn_idx; 05697 SN_ATTR_IDX(sn_idx) = attr_idx; 05698 number_of_allocatables++; 05699 } 05700 05701 insert_sh_after_entries(attr_idx, 05702 entry_sh_idx, 05703 end_entry_sh_idx, 05704 FALSE, /* Don't generate tmp = 0 */ 05705 (ATD_AUTOMATIC(attr_idx) ? FALSE : TRUE)); 05706 05707 } 05708 05709 if (ATD_AUXILIARY(attr_idx)) { 05710 05711 if (ATP_PGM_UNIT(pgm_attr_idx) == Module && !ATD_IN_COMMON(attr_idx)) { 05712 05713 /* Cray is not allowing non-COMMON AUXILIARY data in a MODULE blk */ 05714 05715 PRINTMSG(AT_DEF_LINE(attr_idx), 876, Error, 05716 AT_DEF_COLUMN(attr_idx), 05717 AT_OBJ_NAME_PTR(attr_idx)); 05718 AT_DCL_ERR(attr_idx) = TRUE; 05719 } 05720 else if (TYP_TYPE(type_idx) == Character) { 05721 PRINTMSG(AT_DEF_LINE(attr_idx), 535, Error, 05722 AT_DEF_COLUMN(attr_idx), 05723 AT_OBJ_NAME_PTR(attr_idx)); 05724 AT_DCL_ERR(attr_idx) = TRUE; 05725 } 05726 else if (TYP_TYPE(type_idx) == Structure && 05727 (ATT_POINTER_CPNT(TYP_IDX(type_idx)) || 05728 ATT_CHAR_CPNT(TYP_IDX(type_idx))) ) { 05729 PRINTMSG(AT_DEF_LINE(attr_idx), 536, Error, 05730 AT_DEF_COLUMN(attr_idx), 05731 AT_OBJ_NAME_PTR(attr_idx), 05732 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 05733 AT_DCL_ERR(attr_idx) = TRUE; 05734 } 05735 } 05736 05737 if (ATD_PERMUTATION(attr_idx)) { /* Must be integer array. */ 05738 05739 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX || 05740 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Integer) { 05741 PRINTMSG(AT_DEF_LINE(attr_idx), 1126, Error, 05742 AT_DEF_COLUMN(attr_idx), 05743 AT_OBJ_NAME_PTR(attr_idx)); 05744 AT_DCL_ERR(attr_idx) = TRUE; 05745 } 05746 } 05747 05748 switch (ATD_CLASS(attr_idx)) { 05749 case Variable: 05750 05751 if (ATD_EQUIV(attr_idx) && 05752 AL_NEXT_IDX(ATD_EQUIV_LIST(attr_idx)) == NULL_IDX) { 05753 05754 /* Only one item on list so, clear it for faster equiv processing */ 05755 05756 ATD_EQUIV_LIST(attr_idx) = NULL_IDX; 05757 } 05758 05759 /* Intentional fall through */ 05760 05761 case Compiler_Tmp: 05762 05763 if (ATD_IN_COMMON(attr_idx)) { 05764 05765 if (TYP_TYPE(type_idx) == Structure && 05766 !ATT_SEQUENCE_SET(TYP_IDX(type_idx))) { 05767 AT_DCL_ERR(attr_idx) = TRUE; 05768 PRINTMSG(AT_DEF_LINE(attr_idx), 373, Error, 05769 AT_DEF_COLUMN(attr_idx), 05770 AT_OBJ_NAME_PTR(attr_idx), 05771 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 05772 } 05773 05774 if (SB_BLK_HAS_NPES(ATD_STOR_BLK_IDX(attr_idx)) && 05775 ATD_DATA_INIT(attr_idx)) { 05776 PRINTMSG(AT_DEF_LINE(attr_idx), 1227, Error, 05777 AT_DEF_COLUMN(attr_idx), 05778 AT_OBJ_NAME_PTR(attr_idx), 05779 SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx)) ? 05780 "" : SB_NAME_PTR(ATD_STOR_BLK_IDX(attr_idx))); 05781 AT_DCL_ERR(attr_idx) = TRUE; 05782 } 05783 } 05784 else { 05785 05786 if (ATD_SYMMETRIC(attr_idx)) { 05787 05788 if (AT_HOST_ASSOCIATED(attr_idx)) { 05789 PRINTMSG(AT_DEF_LINE(attr_idx), 1235, Error, 05790 AT_DEF_COLUMN(attr_idx), 05791 AT_OBJ_NAME_PTR(attr_idx)); 05792 05793 ATD_SYMMETRIC(attr_idx) = FALSE; 05794 } 05795 } 05796 else if (ATP_SYMMETRIC(pgm_attr_idx)) { 05797 05798 /* Check to see if this item should be switched to symmetric */ 05799 05800 if (fnd_semantic_err(Obj_Symmetric, 05801 AT_DEF_LINE(attr_idx), 05802 AT_DEF_COLUMN(attr_idx), 05803 attr_idx, 05804 FALSE)) { 05805 05806 /* Blank until caution messages can be issued. */ 05807 05808 if (AT_HOST_ASSOCIATED(attr_idx)) { 05809 PRINTMSG(AT_DEF_LINE(attr_idx), 1236, Caution, 05810 AT_DEF_COLUMN(attr_idx), 05811 AT_OBJ_NAME_PTR(attr_idx)); 05812 } 05813 else { 05814 05815 if (ATD_TARGET(attr_idx)) { 05816 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05817 AT_DEF_COLUMN(attr_idx), 05818 AT_OBJ_NAME_PTR(attr_idx), 05819 "TARGET"); 05820 } 05821 else if (ATD_DATA_INIT(attr_idx)) { 05822 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05823 AT_DEF_COLUMN(attr_idx), 05824 AT_OBJ_NAME_PTR(attr_idx), 05825 "DATA initialized"); 05826 } 05827 else if (ATD_SAVED(attr_idx)) { 05828 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05829 AT_DEF_COLUMN(attr_idx), 05830 AT_OBJ_NAME_PTR(attr_idx), 05831 "SAVE"); 05832 } 05833 else if (ATD_POINTER(attr_idx)) { 05834 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05835 AT_DEF_COLUMN(attr_idx), 05836 AT_OBJ_NAME_PTR(attr_idx), 05837 "POINTER"); 05838 } 05839 else if (ATD_EQUIV(attr_idx)) { 05840 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05841 AT_DEF_COLUMN(attr_idx), 05842 AT_OBJ_NAME_PTR(attr_idx), 05843 "EQUIVALENCE"); 05844 } 05845 else if (ATD_ALLOCATABLE(attr_idx)) { 05846 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05847 AT_DEF_COLUMN(attr_idx), 05848 AT_OBJ_NAME_PTR(attr_idx), 05849 "ALLOCATABLE"); 05850 } 05851 else if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX && 05852 BD_ARRAY_CLASS(attr_idx) == Deferred_Shape) { 05853 PRINTMSG(AT_DEF_LINE(attr_idx), 1234, Caution, 05854 AT_DEF_COLUMN(attr_idx), 05855 AT_OBJ_NAME_PTR(attr_idx), 05856 "deferred-shape DIMENSION"); 05857 } 05858 } 05859 } 05860 else { 05861 ATD_SYMMETRIC(attr_idx) = TRUE; 05862 } 05863 } 05864 05865 if (ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX) { 05866 assign_storage_blk(attr_idx); 05867 } 05868 } 05869 05870 break; 05871 05872 case Dummy_Argument: 05873 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_DARG_IDX(curr_scp_idx); 05874 05875 if (ATD_AUXILIARY(attr_idx)) { 05876 SB_AUXILIARY(ATD_STOR_BLK_IDX(attr_idx)) = TRUE; 05877 } 05878 05879 if (!AT_IS_DARG(attr_idx)) { 05880 05881 if (AT_OPTIONAL(attr_idx)) { 05882 AT_DCL_ERR(attr_idx) = TRUE; 05883 PRINTMSG(AT_DEF_LINE(attr_idx), 352, Error, 05884 AT_DEF_COLUMN(attr_idx), 05885 AT_OBJ_NAME_PTR(attr_idx), "OPTIONAL"); 05886 } 05887 else if (ATD_INTENT(attr_idx) > Intent_Unseen) { 05888 AT_DCL_ERR(attr_idx) = TRUE; 05889 PRINTMSG(AT_DEF_LINE(attr_idx), 352, Error, 05890 AT_DEF_COLUMN(attr_idx), 05891 AT_OBJ_NAME_PTR(attr_idx), "INTENT"); 05892 } 05893 else if (ATD_IGNORE_TKR(attr_idx)) { 05894 AT_DCL_ERR(attr_idx) = TRUE; 05895 PRINTMSG(AT_DEF_LINE(attr_idx), 1505, Error, 05896 AT_DEF_COLUMN(attr_idx), 05897 AT_OBJ_NAME_PTR(attr_idx), "IGNORE_TKR"); 05898 } 05899 } 05900 else if (TYP_TYPE(type_idx) == Structure && 05901 ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx)) && 05902 ATD_INTENT(attr_idx) == Intent_Out && 05903 ATD_ARRAY_IDX(attr_idx) != NULL_IDX && 05904 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Size) { 05905 AT_DCL_ERR(attr_idx) = TRUE; 05906 PRINTMSG(AT_DEF_LINE(attr_idx), 1590, Error, 05907 AT_DEF_COLUMN(attr_idx), 05908 AT_OBJ_NAME_PTR(attr_idx), 05909 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 05910 } 05911 break; 05912 05913 case CRI__Pointee: 05914 05915 if (pointee_based_blk == NULL_IDX) { 05916 05917 /* Create a based entry for PDGCS to use for cri_pointees */ 05918 05919 CREATE_ID(storage_name, sb_name[Pointee_Blk], sb_len[Pointee_Blk]); 05920 pointee_based_blk = ntr_stor_blk_tbl(storage_name.string, 05921 sb_len[Pointee_Blk], 05922 AT_DEF_LINE(attr_idx), 05923 AT_DEF_COLUMN(attr_idx), 05924 Based); 05925 } 05926 05927 ATD_STOR_BLK_IDX(attr_idx) = pointee_based_blk; 05928 pointer_idx = ATD_PTR_IDX(attr_idx); 05929 05930 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 05931 05932 if (ATD_PTR_TYPE_SET(pointer_idx)) { /* Pointer locked in */ 05933 05934 if (TYP_LINEAR(ATD_TYPE_IDX(pointer_idx)) != CRI_Ch_Ptr_8) { 05935 05936 /* Error - Mixing char and non-char pointers */ 05937 05938 AT_DCL_ERR(attr_idx) = TRUE; 05939 AT_DCL_ERR(pointer_idx) = TRUE; 05940 PRINTMSG(AT_DEF_LINE(attr_idx), 1428, Error, 05941 AT_DEF_COLUMN(attr_idx), 05942 AT_OBJ_NAME_PTR(pointer_idx), 05943 AT_OBJ_NAME_PTR(attr_idx)); 05944 } 05945 } 05946 else { 05947 ATD_PTR_TYPE_SET(pointer_idx) = TRUE; 05948 ATD_TYPE_IDX(pointer_idx) = CRI_Ch_Ptr_8; 05949 } 05950 break; 05951 } 05952 else if (ATD_PTR_TYPE_SET(pointer_idx)) { /* Pointer locked in */ 05953 05954 if (TYP_LINEAR(ATD_TYPE_IDX(pointer_idx)) == CRI_Ch_Ptr_8) { 05955 05956 /* Error - Mixing char and non-char pointers */ 05957 05958 AT_DCL_ERR(attr_idx) = TRUE; 05959 AT_DCL_ERR(pointer_idx) = TRUE; 05960 PRINTMSG(AT_DEF_LINE(attr_idx), 1427, Error, 05961 AT_DEF_COLUMN(attr_idx), 05962 AT_OBJ_NAME_PTR(pointer_idx), 05963 AT_OBJ_NAME_PTR(attr_idx)); 05964 } 05965 } 05966 05967 05968 # if defined(_TARGET_OS_MAX) 05969 05970 if (PACK_HALF_WORD_TEST_CONDITION(ATD_TYPE_IDX(attr_idx))) { 05971 05972 if (ATD_PTR_TYPE_SET(pointer_idx)) { 05973 05974 if (TYP_PTR_INCREMENT(ATD_TYPE_IDX(pointer_idx)) != 32) { 05975 PRINTMSG(AT_DEF_LINE(pointer_idx), 1092, Error, 05976 AT_DEF_COLUMN(pointer_idx), 05977 AT_OBJ_NAME_PTR(pointer_idx)); 05978 } 05979 } 05980 else { 05981 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 05982 TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr; 05983 TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8; 05984 TYP_PTR_INCREMENT(TYP_WORK_IDX) = 32; 05985 ATD_TYPE_IDX(pointer_idx) = ntr_type_tbl(); 05986 } 05987 } 05988 else if (ATD_PTR_TYPE_SET(pointer_idx)) { 05989 05990 if (TYP_PTR_INCREMENT(ATD_TYPE_IDX(pointer_idx)) != 64) { 05991 PRINTMSG(AT_DEF_LINE(pointer_idx), 1092, Error, 05992 AT_DEF_COLUMN(pointer_idx), 05993 AT_OBJ_NAME_PTR(pointer_idx)); 05994 } 05995 } /* Else type uses default pointer type */ 05996 05997 # elif defined(_TARGET_OS_UNICOS) 05998 05999 /* Issue caution if we are mixing potential 32 bit types with */ 06000 /* 64 bit types. This works on the PVP okay, but is not portable. */ 06001 06002 if (TARGET_MAX_HALF_WORD_STORAGE_TYPE(ATD_TYPE_IDX(attr_idx))) { 06003 06004 if (ATD_PTR_TYPE_SET(pointer_idx)) { 06005 06006 if (!ATD_PTR_HALF_WORD(pointer_idx)) { 06007 PRINTMSG(AT_DEF_LINE(pointer_idx), 1102, Caution, 06008 AT_DEF_COLUMN(pointer_idx), 06009 AT_OBJ_NAME_PTR(pointer_idx)); 06010 } 06011 } 06012 else { 06013 ATD_PTR_HALF_WORD(pointer_idx) = TRUE; 06014 } 06015 } 06016 else if (ATD_PTR_TYPE_SET(pointer_idx)) { 06017 06018 if (ATD_PTR_HALF_WORD(pointer_idx)) { 06019 PRINTMSG(AT_DEF_LINE(pointer_idx), 1102, Caution, 06020 AT_DEF_COLUMN(pointer_idx), 06021 AT_OBJ_NAME_PTR(pointer_idx)); 06022 } 06023 } 06024 06025 # elif defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 06026 06027 if (TARGET_32BIT_DOUBLE_WORD_STORAGE_TYPE(ATD_TYPE_IDX(attr_idx))) { 06028 06029 if (ATD_PTR_TYPE_SET(pointer_idx)) { 06030 06031 if (TYP_PTR_INCREMENT(ATD_TYPE_IDX(pointer_idx)) != 64) { 06032 PRINTMSG(AT_DEF_LINE(pointer_idx), 1092, Error, 06033 AT_DEF_COLUMN(pointer_idx), 06034 AT_OBJ_NAME_PTR(pointer_idx)); 06035 } 06036 } 06037 else { 06038 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 06039 TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr; 06040 TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8; 06041 TYP_PTR_INCREMENT(TYP_WORK_IDX) = 64; 06042 ATD_TYPE_IDX(pointer_idx) = ntr_type_tbl(); 06043 } 06044 } 06045 else if (ATD_PTR_TYPE_SET(pointer_idx)) { 06046 06047 if (TYP_PTR_INCREMENT(ATD_TYPE_IDX(pointer_idx)) != 32) { 06048 PRINTMSG(AT_DEF_LINE(pointer_idx), 1092, Error, 06049 AT_DEF_COLUMN(pointer_idx), 06050 AT_OBJ_NAME_PTR(pointer_idx)); 06051 } 06052 } /* Else type uses default pointer type */ 06053 06054 # endif 06055 ATD_PTR_TYPE_SET(pointer_idx) = TRUE; 06056 break; 06057 06058 } /* End switch */ 06059 06060 if (ATP_PURE(pgm_attr_idx) || ATP_ELEMENTAL(pgm_attr_idx)) { 06061 pure_str = ATP_PURE(pgm_attr_idx) ? "PURE" : "ELEMENTAL"; 06062 06063 if (ATD_SAVED(attr_idx)) { 06064 PRINTMSG(AT_DEF_LINE(attr_idx), 1264, Error, 06065 AT_DEF_COLUMN(attr_idx), 06066 AT_OBJ_NAME_PTR(attr_idx), 06067 pure_str, 06068 AT_OBJ_NAME_PTR(pgm_attr_idx), 06069 "SAVE"); 06070 } 06071 06072 if (ATD_DATA_INIT(attr_idx)) { 06073 PRINTMSG(AT_DEF_LINE(attr_idx), 1264, Error, 06074 AT_DEF_COLUMN(attr_idx), 06075 AT_OBJ_NAME_PTR(attr_idx), 06076 pure_str, 06077 AT_OBJ_NAME_PTR(pgm_attr_idx), 06078 "DATA initialized"); 06079 } 06080 06081 if (ATD_CLASS(attr_idx) == Dummy_Argument) { 06082 06083 if (!ATD_POINTER(attr_idx) && ATD_INTENT(attr_idx) != Intent_In) { 06084 06085 if (ATP_PGM_UNIT(pgm_attr_idx) == Function) { 06086 PRINTMSG(AT_DEF_LINE(attr_idx), 1265, Error, 06087 AT_DEF_COLUMN(attr_idx), 06088 AT_OBJ_NAME_PTR(attr_idx), 06089 pure_str, 06090 AT_OBJ_NAME_PTR(pgm_attr_idx)); 06091 } 06092 else if (ATP_PGM_UNIT(pgm_attr_idx) == Subroutine && 06093 ATD_INTENT(attr_idx) == Intent_Unseen) { 06094 PRINTMSG(AT_DEF_LINE(attr_idx), 1266, Error, 06095 AT_DEF_COLUMN(attr_idx), 06096 AT_OBJ_NAME_PTR(attr_idx), 06097 pure_str, 06098 AT_OBJ_NAME_PTR(pgm_attr_idx)); 06099 } 06100 } 06101 06102 if (ATP_ELEMENTAL(pgm_attr_idx) && 06103 (ATD_POINTER(attr_idx) || ATD_ARRAY_IDX(attr_idx) != NULL_IDX)){ 06104 PRINTMSG(AT_DEF_LINE(attr_idx), 1267, Error, 06105 AT_DEF_COLUMN(attr_idx), 06106 AT_OBJ_NAME_PTR(attr_idx), 06107 AT_OBJ_NAME_PTR(pgm_attr_idx)); 06108 } 06109 } 06110 } 06111 06112 if (ATP_PGM_UNIT(pgm_attr_idx) == Module && 06113 TYP_TYPE(type_idx) == Structure && 06114 ATT_DEFAULT_INITIALIZED(TYP_IDX(type_idx)) && 06115 !ATD_IN_COMMON(attr_idx) && 06116 (ATD_CLASS(attr_idx) == Atd_Unknown || 06117 ATD_CLASS(attr_idx) == Variable) && 06118 !ATD_POINTER(attr_idx) && 06119 !ATD_ALLOCATABLE(attr_idx) && 06120 !ATD_SAVED(attr_idx)) { 06121 PRINTMSG(AT_DEF_LINE(attr_idx), 1641, Ansi, 06122 AT_DEF_COLUMN(attr_idx), 06123 AT_OBJ_NAME_PTR(attr_idx), 06124 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 06125 } 06126 break; 06127 06128 06129 case Pgm_Unit: 06130 06131 /* Set in case we have an overloaded intrinsic that references the */ 06132 /* standard intrinsic. */ 06133 06134 AT_SEMANTICS_DONE(attr_idx) = TRUE; 06135 06136 if (ATP_PROC(attr_idx) == Intern_Proc || 06137 ATP_PROC(attr_idx) == Module_Proc) { 06138 06139 if (ATP_SCP_IDX(attr_idx) != curr_scp_idx) { 06140 06141 /* This is an internal or module procedure that is in its */ 06142 /* parent's scope. Process this when its own scope is done.*/ 06143 06144 AT_SEMANTICS_DONE(attr_idx) = FALSE; 06145 return; 06146 } 06147 06148 /* If this pgm unit is pure and elemental, the parent */ 06149 /* procedures can be anything and do not need to be checked. */ 06150 06151 if (ATP_PROC(attr_idx) == Intern_Proc && 06152 (!ATP_PURE(attr_idx) || !ATP_ELEMENTAL(attr_idx))) { 06153 scp_idx = SCP_PARENT_IDX(curr_scp_idx); 06154 06155 while (scp_idx != NULL_IDX) { 06156 06157 /* Parent is pure, so child must be too. This only goes back */ 06158 06159 if (ATP_PURE(SCP_ATTR_IDX(scp_idx)) && 06160 !ATP_PURE(attr_idx) && !ATP_ELEMENTAL(attr_idx)) { 06161 PRINTMSG(AT_DEF_LINE(attr_idx), 1272, Error, 06162 AT_DEF_COLUMN(attr_idx), 06163 AT_OBJ_NAME_PTR(attr_idx), 06164 ATP_PURE(SCP_ATTR_IDX(scp_idx))?"pure":"elemental", 06165 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(scp_idx)), 06166 ATP_PURE(SCP_ATTR_IDX(scp_idx))?"PURE":"ELEMENTAL"); 06167 } 06168 06169 if (ATP_ELEMENTAL(SCP_ATTR_IDX(scp_idx)) && 06170 !ATP_ELEMENTAL(attr_idx)) { 06171 PRINTMSG(AT_DEF_LINE(attr_idx), 1272, Error, 06172 AT_DEF_COLUMN(attr_idx), 06173 AT_OBJ_NAME_PTR(attr_idx), 06174 "elemental", 06175 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(scp_idx)), 06176 "ELEMENTAL"); 06177 } 06178 scp_idx = SCP_PARENT_IDX(scp_idx); 06179 } 06180 } 06181 } 06182 06183 if (ATP_PGM_UNIT(attr_idx) == Function) { 06184 rslt_idx = ATP_RSLT_IDX(attr_idx); 06185 type_idx = ATD_TYPE_IDX(rslt_idx); 06186 06187 if (TYP_TYPE(type_idx) == Structure) { 06188 06189 if (AT_ATTR_LINK(TYP_IDX(type_idx)) != NULL_IDX) { 06190 06191 /* If this derived type is host associated (AT_ATTR_LINK is */ 06192 /* set) change the type table to point to the original type. */ 06193 /* It is okay to change the type table, because every attr of */ 06194 /* this type needs to do this. */ 06195 06196 link_idx = TYP_IDX(type_idx); 06197 06198 while (AT_ATTR_LINK(link_idx) != NULL_IDX) { 06199 link_idx = AT_ATTR_LINK(link_idx); 06200 } 06201 06202 TYP_IDX(type_idx) = link_idx; 06203 } 06204 attr_semantics(TYP_IDX(type_idx), FALSE); 06205 } 06206 06207 bd_idx = ATD_ARRAY_IDX(rslt_idx); 06208 06209 if (TYP_TYPE(type_idx) == Character) { 06210 06211 if (TYP_FLD(type_idx) == AT_Tbl_Idx) { 06212 attr_semantics(TYP_IDX(type_idx), TRUE); 06213 } 06214 06215 if (TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) { 06216 06217 if (ATP_ELEMENTAL(attr_idx)) { 06218 PRINTMSG(AT_DEF_LINE(rslt_idx), 1564, Error, 06219 AT_DEF_COLUMN(rslt_idx), 06220 AT_OBJ_NAME_PTR(rslt_idx), "ELEMENTAL"); 06221 } 06222 else if (ATP_PURE(attr_idx)) { 06223 PRINTMSG(AT_DEF_LINE(rslt_idx), 1564, Error, 06224 AT_DEF_COLUMN(rslt_idx), 06225 AT_OBJ_NAME_PTR(rslt_idx), "PURE"); 06226 } 06227 } 06228 } 06229 06230 if (bd_idx != NULL_IDX && BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) { 06231 06232 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 06233 06234 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 06235 attr_semantics(BD_LB_IDX(bd_idx, dim), TRUE); 06236 } 06237 06238 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 06239 attr_semantics(BD_UB_IDX(bd_idx, dim), TRUE); 06240 } 06241 } 06242 } 06243 AT_SEMANTICS_DONE(rslt_idx) = TRUE; 06244 } 06245 06246 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 06247 06248 /* These return charcter results on the SPARC but not Cray. */ 06249 06250 if (ATP_PROC(attr_idx) != Intrin_Proc || 06251 AT_OBJ_NAME(attr_idx) != '_' || 06252 (!(strcmp(AT_OBJ_NAME_PTR(attr_idx), "_DATE") == 0)) && 06253 (!(strcmp(AT_OBJ_NAME_PTR(attr_idx), "_JDATE") == 0)) && 06254 (!(strcmp(AT_OBJ_NAME_PTR(attr_idx), "_CLOCK") == 0))) { 06255 # endif 06256 06257 if (AT_USE_ASSOCIATED(attr_idx) || AT_IS_INTRIN(attr_idx)) { 06258 goto EXIT; 06259 } 06260 06261 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 06262 } 06263 else { 06264 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 06265 TYP_TYPE(TYP_WORK_IDX) = Character; 06266 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 06267 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 06268 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 06269 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(SA_INTEGER_DEFAULT_TYPE, 06270 8); 06271 ATD_TYPE_IDX(rslt_idx) = ntr_type_tbl(); 06272 } 06273 # endif 06274 06275 if (ATP_PGM_UNIT(attr_idx) == Function) { 06276 06277 if (!AT_TYPED(rslt_idx) && ATP_PROC(attr_idx) != Intrin_Proc) { 06278 06279 if (SCP_IMPL_NONE(curr_scp_idx)) { 06280 AT_DCL_ERR(rslt_idx) = TRUE; 06281 PRINTMSG(AT_DEF_LINE(rslt_idx), 232, Error, 06282 AT_DEF_COLUMN(rslt_idx), 06283 AT_OBJ_NAME_PTR(rslt_idx)); 06284 } 06285 else if (!IM_SET(curr_scp_idx, IMPL_IDX(AT_OBJ_NAME(rslt_idx)))) { 06286 06287 if (SCP_PARENT_NONE(curr_scp_idx)) { 06288 AT_DCL_ERR(rslt_idx) = TRUE; 06289 PRINTMSG(AT_DEF_LINE(rslt_idx), 233, Error, 06290 AT_DEF_COLUMN(rslt_idx), 06291 AT_OBJ_NAME_PTR(rslt_idx)); 06292 } 06293 else if (is_interface && attr_idx == pgm_attr_idx && 06294 SCP_IMPL_NONE(SCP_PARENT_IDX(curr_scp_idx))) { 06295 AT_DCL_ERR(rslt_idx) = TRUE; 06296 PRINTMSG(AT_DEF_LINE(rslt_idx), 233, Error, 06297 AT_DEF_COLUMN(rslt_idx), 06298 AT_OBJ_NAME_PTR(rslt_idx)); 06299 } 06300 else if (on_off_flags.implicit_none) { 06301 AT_DCL_ERR(attr_idx) = TRUE; 06302 PRINTMSG(AT_DEF_LINE(rslt_idx), 1171, Error, 06303 AT_DEF_COLUMN(rslt_idx), 06304 AT_OBJ_NAME_PTR(rslt_idx)); 06305 } 06306 } 06307 } 06308 06309 if (TYP_TYPE(type_idx) == Character) { 06310 char_len_resolution(rslt_idx, FALSE); 06311 06312 /* reset the type_idx in case it changes */ 06313 06314 type_idx = ATD_TYPE_IDX(rslt_idx); 06315 } 06316 06317 if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX) { 06318 array_dim_resolution(rslt_idx, FALSE); 06319 06320 if (!ATP_EXPL_ITRFC(attr_idx) && !AT_DCL_ERR(rslt_idx)) { 06321 PRINTMSG(AT_DEF_LINE(rslt_idx), 914, Error, 06322 AT_DEF_COLUMN(rslt_idx), 06323 AT_OBJ_NAME_PTR(attr_idx)); 06324 AT_DCL_ERR(rslt_idx) = TRUE; 06325 } 06326 } 06327 06328 if (ATD_POINTER(rslt_idx) && !ATP_EXPL_ITRFC(attr_idx)) { 06329 PRINTMSG(AT_DEF_LINE(rslt_idx), 915, Error, 06330 AT_DEF_COLUMN(rslt_idx), 06331 AT_OBJ_NAME_PTR(attr_idx)); 06332 AT_DCL_ERR(rslt_idx) = TRUE; 06333 } 06334 06335 if (ATD_AUTOMATIC(rslt_idx) && 06336 (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX || 06337 ATD_POINTER(rslt_idx) || 06338 TYP_TYPE(type_idx) == Structure || 06339 TYP_TYPE(type_idx) == Character)) { 06340 PRINTMSG(AT_DEF_LINE(rslt_idx), 1255, Error, 06341 AT_DEF_COLUMN(rslt_idx), 06342 AT_OBJ_NAME_PTR(rslt_idx)); 06343 AT_DCL_ERR(rslt_idx) = TRUE; 06344 } 06345 06346 if (AT_DCL_ERR(rslt_idx)) { 06347 AT_DCL_ERR(attr_idx) = TRUE; 06348 } 06349 06350 if (TYP_TYPE(type_idx) == Character && 06351 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char && 06352 TYP_FLD(type_idx) == AT_Tbl_Idx && 06353 AT_OBJ_CLASS(TYP_IDX(type_idx)) == Data_Obj) { 06354 06355 tmp_ir_idx = ATD_TMP_IDX(TYP_IDX(type_idx)); 06356 06357 COPY_OPND(opnd, IR_OPND_R(tmp_ir_idx)); 06358 fold_clen_opr(&opnd, &expr_desc); 06359 COPY_OPND(IR_OPND_R(tmp_ir_idx), opnd); 06360 } 06361 06362 /* All character, structure and array-valued function results */ 06363 /* become the zeroth darg. All scalar function results with */ 06364 /* alternate entries are stored in the equivalence block. */ 06365 06366 06367 if (FUNCTION_MUST_BE_SUBROUTINE(rslt_idx)) { 06368 06369 ATP_EXTRA_DARG(attr_idx) = TRUE; 06370 06371 if (ATP_EXPL_ITRFC(attr_idx)) { 06372 ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_DARG_IDX(curr_scp_idx); 06373 06374 /* Insert the function result as the zero'th darg */ 06375 06376 if (ATP_FIRST_IDX(attr_idx) == NULL_IDX) { 06377 NTR_SN_TBL(sn_idx); 06378 } 06379 else { 06380 sn_idx = ATP_FIRST_IDX(attr_idx) - 1; 06381 } 06382 ATP_FIRST_IDX(attr_idx) = sn_idx; 06383 ATP_NUM_DARGS(attr_idx) += 1; 06384 SN_NAME_LEN(sn_idx) = AT_NAME_LEN(rslt_idx); 06385 SN_NAME_IDX(sn_idx) = AT_NAME_IDX(rslt_idx); 06386 SN_ATTR_IDX(sn_idx) = rslt_idx; 06387 SN_LINE_NUM(sn_idx) = AT_DEF_LINE(rslt_idx); 06388 SN_COLUMN_NUM(sn_idx) = AT_DEF_COLUMN(rslt_idx); 06389 } 06390 } 06391 else if (SCP_ALT_ENTRY_CNT(curr_scp_idx) > 0 && 06392 (attr_idx == pgm_attr_idx || ATP_ALT_ENTRY(attr_idx))) { 06393 06394 if (alt_entry_equiv_blk == NULL_IDX) { 06395 06396 /* Create an equivalence entry for PDGCS to use for alternate */ 06397 /* function results. The offset is always zero. */ 06398 06399 alt_entry_equiv_blk = create_equiv_stor_blk(attr_idx, Stack); 06400 } 06401 06402 if (ATP_RSLT_IDX(attr_idx) != NULL_IDX) { 06403 storage_size = stor_bit_size_of(ATP_RSLT_IDX(attr_idx), 06404 TRUE, 06405 FALSE); 06406 06407 /* KAY - Set SB_LEN correctly here when storage_size is fixed.*/ 06408 06409 if (storage_size.fld == NO_Tbl_Idx) { 06410 storage_size.fld = CN_Tbl_Idx; 06411 storage_size.idx = ntr_const_tbl(storage_size.type_idx, 06412 FALSE, 06413 storage_size.constant); 06414 } 06415 06416 # if defined(_TARGET_OS_MAX) 06417 06418 else if (storage_size.fld == IR_Tbl_Idx || 06419 storage_size.fld == IL_Tbl_Idx) { 06420 tmp_idx = gen_compiler_tmp(SB_DEF_LINE(alt_entry_equiv_blk), 06421 SB_DEF_COLUMN(alt_entry_equiv_blk), 06422 Priv, TRUE); 06423 ATD_TYPE_IDX(tmp_idx) = INTEGER_DEFAULT_TYPE; 06424 ATD_TMP_IDX(tmp_idx) = storage_size.idx; 06425 ATD_FLD(tmp_idx) = storage_size.fld; 06426 ATD_SYMBOLIC_CONSTANT(tmp_idx) = TRUE; 06427 storage_size.fld = AT_Tbl_Idx; 06428 storage_size.idx = tmp_idx; 06429 } 06430 06431 if (attr_idx == pgm_attr_idx && 06432 ATD_ARRAY_IDX(rslt_idx) != NULL_IDX && 06433 BD_ARRAY_SIZE(ATD_ARRAY_IDX(rslt_idx)) == 06434 Symbolic_Constant_Size){ 06435 PRINTMSG(AT_DEF_LINE(rslt_idx), 1230, Error, 06436 AT_DEF_COLUMN(rslt_idx), 06437 AT_OBJ_NAME_PTR(attr_idx)); 06438 AT_DCL_ERR(rslt_idx) = TRUE; 06439 } 06440 # endif 06441 06442 SB_LEN_FLD(alt_entry_equiv_blk) = storage_size.fld; 06443 SB_LEN_IDX(alt_entry_equiv_blk) = storage_size.idx; 06444 } 06445 06446 ATD_STOR_BLK_IDX(rslt_idx) = alt_entry_equiv_blk; 06447 ATD_EQUIV(rslt_idx) = TRUE; 06448 ATD_OFFSET_ASSIGNED(rslt_idx) = TRUE; 06449 ATD_OFFSET_FLD(rslt_idx) = CN_Tbl_Idx; 06450 ATD_OFFSET_IDX(rslt_idx) = CN_INTEGER_ZERO_IDX; 06451 06452 if (alt_entry_equiv_grp == NULL_IDX) { 06453 NTR_EQ_TBL(alt_entry_equiv_grp); 06454 EQ_GRP_END_IDX(alt_entry_equiv_grp) = alt_entry_equiv_grp; 06455 eq_idx = alt_entry_equiv_grp; 06456 EQ_GRP_IDX(eq_idx) = alt_entry_equiv_grp; 06457 } 06458 else { 06459 NTR_EQ_TBL(eq_idx); 06460 EQ_NEXT_EQUIV_OBJ(EQ_GRP_END_IDX(alt_entry_equiv_grp)) = eq_idx; 06461 EQ_GRP_END_IDX(alt_entry_equiv_grp) = eq_idx; 06462 EQ_GRP_IDX(eq_idx) = alt_entry_equiv_grp; 06463 } 06464 06465 EQ_LINE_NUM(eq_idx) = AT_DEF_LINE(rslt_idx); 06466 EQ_COLUMN_NUM(eq_idx) = AT_DEF_COLUMN(rslt_idx); 06467 EQ_ATTR_IDX(eq_idx) = rslt_idx; 06468 } 06469 else { 06470 ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 06471 } 06472 06473 if (ATP_ALT_ENTRY(attr_idx)) { 06474 compare_entry_to_func_rslt(attr_idx, ATP_RSLT_IDX(pgm_attr_idx)); 06475 } 06476 06477 if (ATP_ELEMENTAL(attr_idx) && 06478 (ATD_POINTER(rslt_idx) || ATD_ARRAY_IDX(rslt_idx) != NULL_IDX)) { 06479 PRINTMSG(AT_DEF_LINE(rslt_idx), 1268, Error, 06480 AT_DEF_COLUMN(rslt_idx), 06481 AT_OBJ_NAME_PTR(attr_idx), 06482 AT_OBJ_NAME_PTR(rslt_idx)); 06483 AT_DCL_ERR(rslt_idx) = TRUE; 06484 } 06485 } 06486 else if (ATP_PGM_UNIT(attr_idx) == Subroutine) { 06487 06488 if (ATP_HAS_ALT_RETURN(attr_idx)) { 06489 06490 if (ATP_ELEMENTAL(pgm_attr_idx)) { 06491 06492 /* Illegal to have alternate return in an elemental. */ 06493 /* Find location and issue an error. */ 06494 06495 for (sn_idx = ATP_FIRST_IDX(pgm_attr_idx); 06496 sn_idx <= ATP_FIRST_IDX(pgm_attr_idx) + 06497 ATP_NUM_DARGS(pgm_attr_idx); 06498 sn_idx++) { 06499 06500 if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) == Data_Obj && 06501 ATD_CLASS(SN_ATTR_IDX(sn_idx)) == Dummy_Argument && 06502 AT_COMPILER_GEND(SN_ATTR_IDX(sn_idx))) { 06503 PRINTMSG(AT_DEF_LINE(SN_ATTR_IDX(sn_idx)), 1269, Error, 06504 AT_DEF_COLUMN(SN_ATTR_IDX(sn_idx)), 06505 AT_OBJ_NAME_PTR(pgm_attr_idx)); 06506 AT_DCL_ERR(pgm_attr_idx) = TRUE; 06507 } 06508 } 06509 } 06510 06511 /* The interface needs to have a function result for this */ 06512 /* subroutine because of the alternate return. */ 06513 06514 CREATE_FUNC_RSLT(attr_idx, rslt_idx); 06515 AT_DEFINED(rslt_idx) = TRUE; 06516 ATD_TYPE_IDX(rslt_idx) = CG_INTEGER_DEFAULT_TYPE; 06517 ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 06518 06519 if (ATP_ALT_ENTRY(attr_idx)) { 06520 06521 if (alt_entry_equiv_blk == NULL_IDX) { 06522 06523 /* Create an equivalence entry for PDGCS */ 06524 /* to use for alternate function results. */ 06525 06526 alt_entry_equiv_blk = create_equiv_stor_blk(attr_idx, Stack); 06527 } 06528 06529 if (alt_entry_equiv_grp == NULL_IDX) { 06530 NTR_EQ_TBL(alt_entry_equiv_grp); 06531 EQ_GRP_END_IDX(alt_entry_equiv_grp) = alt_entry_equiv_grp; 06532 eq_idx = alt_entry_equiv_grp; 06533 EQ_GRP_IDX(eq_idx) = alt_entry_equiv_grp; 06534 } 06535 else { 06536 NTR_EQ_TBL(eq_idx); 06537 EQ_NEXT_EQUIV_OBJ(EQ_GRP_END_IDX(alt_entry_equiv_grp))=eq_idx; 06538 EQ_GRP_END_IDX(alt_entry_equiv_grp) = eq_idx; 06539 EQ_GRP_IDX(eq_idx) = alt_entry_equiv_grp; 06540 } 06541 06542 EQ_LINE_NUM(eq_idx) = AT_DEF_LINE(rslt_idx); 06543 EQ_COLUMN_NUM(eq_idx) = AT_DEF_COLUMN(rslt_idx); 06544 EQ_ATTR_IDX(eq_idx) = rslt_idx; 06545 ATD_STOR_BLK_IDX(rslt_idx) = alt_entry_equiv_blk; 06546 } 06547 } 06548 } 06549 else if (ATP_PGM_UNIT(attr_idx) == Pgm_Unknown) { 06550 06551 if (ATP_PROC(attr_idx) == Module_Proc) { 06552 06553 /* MODULE PROCEDURE specified in INTERFACE, but the MODULE */ 06554 /* PROCEDURE was never accessed in the MODULE or from USE. */ 06555 06556 AT_DCL_ERR(attr_idx) = TRUE; 06557 PRINTMSG(AT_DEF_LINE(attr_idx), 368, Error, 06558 AT_DEF_COLUMN(attr_idx), 06559 AT_OBJ_NAME_PTR(attr_idx)); 06560 } 06561 else if (ATP_PROC(attr_idx) == Dummy_Proc) { 06562 06563 /* dummy arg has been declared in external stmt */ 06564 /* but it is still unknown prog. Valid Fortran. */ 06565 /* Leave it as a Pgm_Unknown, but implicitly type */ 06566 /* this, just in case a function is passed in */ 06567 /* as an actual argument for this dummy proc. */ 06568 06569 CREATE_FUNC_RSLT(attr_idx, rslt_idx); 06570 SET_IMPL_TYPE(rslt_idx); 06571 } 06572 } 06573 06574 if (ATP_PGM_UNIT(attr_idx) != Module && 06575 ATP_FIRST_IDX(attr_idx) != NULL_IDX) { /* Process the dargs */ 06576 06577 for (i = (ATP_EXTRA_DARG(attr_idx) ? 1 : 0); 06578 i < ATP_NUM_DARGS(attr_idx); i++) { 06579 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(attr_idx) + i); 06580 attr_semantics(darg_idx, FALSE); 06581 } 06582 } 06583 06584 /* Vfunction infers no side effects - so set it now */ 06585 06586 ATP_NOSIDE_EFFECTS(attr_idx) = ATP_NOSIDE_EFFECTS(attr_idx) | 06587 ATP_VFUNCTION(attr_idx); 06588 06589 /* If this is the program unit being defined in the interface, set */ 06590 /* ATP_SCP_IDX to the parent's scope, otherwise clear it, because */ 06591 /* this is an invalid scope id, when the interface scope is removed. */ 06592 06593 if (is_interface) { 06594 ATP_SCP_IDX(attr_idx) = SCP_PARENT_IDX(curr_scp_idx); 06595 } 06596 06597 if (ATP_PROC(attr_idx) == Dummy_Proc) { 06598 06599 /* If this is an interface specific, pgm_attr_idx is set to the */ 06600 /* specific. The correct attr to check is the program unit */ 06601 /* containing the procedure. */ 06602 06603 proc_idx = is_interface ? SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)) : 06604 pgm_attr_idx; 06605 06606 if (ATP_ELEMENTAL(proc_idx)) { 06607 PRINTMSG(AT_DEF_LINE(attr_idx), 1267, Error, 06608 AT_DEF_COLUMN(attr_idx), 06609 AT_OBJ_NAME_PTR(attr_idx), 06610 AT_OBJ_NAME_PTR(proc_idx)); 06611 } 06612 else if (ATP_PURE(proc_idx) && !ATP_PURE(attr_idx)) { 06613 06614 /* Dummy procedures must be given the PURE attribute */ 06615 06616 PRINTMSG(AT_DEF_LINE(attr_idx), 1271, Error, 06617 AT_DEF_COLUMN(attr_idx), 06618 AT_OBJ_NAME_PTR(attr_idx), 06619 AT_OBJ_NAME_PTR(proc_idx)); 06620 } 06621 } 06622 06623 if (ATP_DUPLICATE_INTERFACE_IDX(attr_idx) != NULL_IDX) { 06624 06625 /* An interface body has been specified for the program unit */ 06626 /* being compiled. Verify that they are identical. If they */ 06627 /* are, issue an ansi message, otherwise, issue an error. */ 06628 06629 compare_duplicate_interface_bodies(attr_idx); 06630 } 06631 06632 06633 break; 06634 06635 case Label: 06636 06637 if (!AT_DEFINED(attr_idx)) { 06638 # ifdef _DEBUG 06639 if (ATL_FWD_REF_IDX(attr_idx) == NULL_IDX && 06640 (ATL_CLASS(attr_idx) == Lbl_User || 06641 ATL_CLASS(attr_idx) == Lbl_Format)) { 06642 PRINTMSG(stmt_start_line, 9, Internal, 06643 stmt_start_col, AT_OBJ_NAME_PTR(attr_idx)); 06644 } 06645 # endif 06646 curr_fwd_ref_idx = ATL_FWD_REF_IDX(attr_idx); 06647 06648 while (curr_fwd_ref_idx != NULL_IDX) { 06649 if (IL_FLD(curr_fwd_ref_idx) == IL_Tbl_Idx) { 06650 line = IL_LINE_NUM(IL_IDX(curr_fwd_ref_idx)); 06651 column = IL_COL_NUM(IL_IDX(curr_fwd_ref_idx)); 06652 } 06653 else { 06654 line = IL_LINE_NUM(curr_fwd_ref_idx); 06655 column = IL_COL_NUM(curr_fwd_ref_idx); 06656 } 06657 PRINTMSG(line, 23, Error, column, 06658 AT_OBJ_NAME_PTR(attr_idx)); 06659 old_fwd_ref_idx = curr_fwd_ref_idx; 06660 curr_fwd_ref_idx = IL_NEXT_LIST_IDX(curr_fwd_ref_idx); 06661 FREE_IR_LIST_NODE(old_fwd_ref_idx); 06662 } 06663 06664 ATL_FWD_REF_IDX(attr_idx) = NULL_IDX; 06665 } 06666 break; 06667 06668 case Derived_Type: 06669 06670 /* Set in case, any components are ptrs to the derived type. */ 06671 06672 AT_SEMANTICS_DONE(attr_idx) = TRUE; 06673 sn_idx = ATT_FIRST_CPNT_IDX(attr_idx); 06674 06675 while (sn_idx != NULL_IDX) { 06676 type_idx = ATD_TYPE_IDX(SN_ATTR_IDX(sn_idx)); 06677 06678 if (TYP_TYPE(type_idx) == Structure) { 06679 dt_idx = TYP_IDX(type_idx); 06680 attr_semantics(dt_idx, FALSE); 06681 06682 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 06683 !AT_PRIVATE(attr_idx) && 06684 !ATT_PRIVATE_CPNT(attr_idx) && 06685 AT_PRIVATE(dt_idx) && 06686 !AT_USE_ASSOCIATED(dt_idx)) { /* interp 161 */ 06687 PRINTMSG(AT_DEF_LINE(SN_ATTR_IDX(sn_idx)), 45, Error, 06688 AT_DEF_COLUMN(SN_ATTR_IDX(sn_idx)), 06689 AT_OBJ_NAME_PTR(SN_ATTR_IDX(sn_idx)), 06690 AT_OBJ_NAME_PTR(dt_idx), 06691 AT_OBJ_NAME_PTR(attr_idx)); 06692 } 06693 06694 if (!AT_USE_ASSOCIATED(attr_idx) && 06695 ATT_SEQUENCE_SET(attr_idx) && !ATT_SEQUENCE_SET(dt_idx)) { 06696 PRINTMSG(AT_DEF_LINE(attr_idx), 140, Error, 06697 AT_DEF_COLUMN(attr_idx)); 06698 } 06699 06700 } 06701 06702 if (!AT_USE_ASSOCIATED(attr_idx) && 06703 ATD_CPNT_INIT_IDX(SN_ATTR_IDX(sn_idx)) != NULL_IDX) { 06704 default_init_semantics(SN_ATTR_IDX(sn_idx)); 06705 } 06706 sn_idx = SN_SIBLING_LINK(sn_idx); 06707 } 06708 06709 if (!AT_DEFINED(attr_idx)) { 06710 issue_undefined_type_msg(attr_idx, 06711 AT_DEF_LINE(attr_idx), 06712 AT_DEF_COLUMN(attr_idx)); 06713 } 06714 06715 if (is_interface) { 06716 ATT_SCP_IDX(attr_idx) = SCP_PARENT_IDX(curr_scp_idx); 06717 } 06718 06719 if (ATT_LABEL_LIST_IDX(attr_idx) != NULL_IDX) { 06720 06721 /* This list is used for parsing only. Free and clear the field */ 06722 06723 free_attr_list(ATT_LABEL_LIST_IDX(attr_idx)); 06724 ATT_LABEL_LIST_IDX(attr_idx) = NULL_IDX; 06725 } 06726 06727 break; 06728 06729 case Interface: 06730 06731 if (!ATI_UNNAMED_INTERFACE(attr_idx)) { 06732 06733 if (!AT_IS_INTRIN(attr_idx)) { 06734 06735 /* If there is a program unit with the same name, make sure it */ 06736 /* is in this interface block. */ 06737 06738 pgm_idx = ATI_PROC_IDX(attr_idx); 06739 06740 if (pgm_idx != NULL_IDX && ATP_PROC(pgm_idx) == Module_Proc) { 06741 06742 if (ATP_PGM_UNIT(pgm_idx) == Pgm_Unknown) { 06743 06744 /* Need to search host for this module procedure */ 06745 06746 sn_attr_idx = srch_host_sym_tbl(AT_OBJ_NAME_PTR(pgm_idx), 06747 AT_NAME_LEN(pgm_idx), 06748 &name_idx, 06749 FALSE); 06750 06751 if (sn_attr_idx != NULL_IDX && 06752 AT_OBJ_CLASS(sn_attr_idx) == Interface && 06753 ATI_PROC_IDX(sn_attr_idx) != NULL_IDX) { 06754 AT_ATTR_LINK(pgm_idx) = ATI_PROC_IDX(sn_attr_idx); 06755 ATI_PROC_IDX(attr_idx) = ATI_PROC_IDX(sn_attr_idx); 06756 } 06757 else if (sn_attr_idx != NULL_IDX && 06758 AT_OBJ_CLASS(sn_attr_idx) == Pgm_Unit && 06759 ATP_PROC(sn_attr_idx) == Module_Proc) { 06760 ATI_PROC_IDX(attr_idx) = sn_attr_idx; 06761 AT_ATTR_LINK(pgm_idx) = sn_attr_idx; 06762 } 06763 else if (!AT_DCL_ERR(pgm_idx)) { 06764 PRINTMSG(AT_DEF_LINE(pgm_idx), 368, Error, 06765 AT_DEF_COLUMN(pgm_idx), 06766 AT_OBJ_NAME_PTR(pgm_idx)); 06767 AT_DCL_ERR(pgm_idx) = TRUE; 06768 AT_DCL_ERR(attr_idx) = TRUE; 06769 } 06770 } 06771 06772 sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx); 06773 sn_attr_idx = srch_linked_sn(AT_OBJ_NAME_PTR(attr_idx), 06774 AT_NAME_LEN(attr_idx), 06775 &sn_idx); 06776 06777 if (sn_attr_idx == NULL_IDX) { 06778 AT_DCL_ERR(attr_idx) = TRUE; 06779 PRINTMSG(AT_DEF_LINE(ATI_PROC_IDX(attr_idx)), 712, Error, 06780 AT_DEF_COLUMN(ATI_PROC_IDX(attr_idx)), 06781 AT_OBJ_NAME_PTR(attr_idx), 06782 (ATP_PGM_UNIT(ATI_PROC_IDX(attr_idx)) == Function) ? 06783 "FUNCTION" : "SUBROUTINE", 06784 AT_OBJ_NAME_PTR(attr_idx)); 06785 } 06786 else { 06787 06788 /* Need to generate a usage record for the module procedure */ 06789 /* definition here. Could not do it earlier, as we did */ 06790 /* might not have the proper attr. */ 06791 06792 if ((cif_flags & XREF_RECS) != 0) { 06793 cif_usage_rec(attr_idx, 06794 AT_Tbl_Idx, 06795 SN_LINE_NUM(sn_attr_idx), 06796 SN_COLUMN_NUM(sn_attr_idx), 06797 CIF_Symbol_Declaration); 06798 } 06799 } 06800 } 06801 06802 if (AT_TYPED(attr_idx)) { 06803 AT_DCL_ERR(attr_idx) = TRUE; 06804 PRINTMSG(AT_DEF_LINE(attr_idx), 949, Error, 06805 AT_DEF_COLUMN(attr_idx), 06806 AT_OBJ_NAME_PTR(attr_idx)); 06807 } 06808 } 06809 else if (AT_TYPED(attr_idx)) { /* The intrinsic has been typed. */ 06810 06811 PRINTMSG(AT_DEF_LINE(attr_idx), 711, Caution, 06812 AT_DEF_COLUMN(attr_idx), 06813 AT_OBJ_NAME_PTR(attr_idx)); 06814 06815 type_idx = ATD_TYPE_IDX(attr_idx); 06816 06817 if (TYP_TYPE(type_idx) == Structure) { 06818 06819 if (AT_ATTR_LINK(TYP_IDX(type_idx)) != NULL_IDX) { 06820 06821 /* If this derived type is host associated (AT_ATTR_LINK */ 06822 /* is set) change the type table to point to the original */ 06823 /* type. It is okay to change the type table, because */ 06824 /* every attr of this type needs to do this. */ 06825 06826 link_idx = TYP_IDX(type_idx); 06827 06828 while (AT_ATTR_LINK(link_idx) != NULL_IDX) { 06829 link_idx = AT_ATTR_LINK(link_idx); 06830 } 06831 06832 TYP_IDX(type_idx) = link_idx; 06833 } 06834 06835 attr_semantics(TYP_IDX(type_idx), FALSE); 06836 } 06837 06838 if (AT_USE_ASSOCIATED(attr_idx)) { 06839 goto EXIT; 06840 } 06841 06842 if (TYP_TYPE(type_idx) == Character) { 06843 06844 if (TYP_FLD(type_idx) == AT_Tbl_Idx) { 06845 attr_semantics(TYP_IDX(type_idx), TRUE); 06846 } 06847 } 06848 06849 if (AT_DCL_ERR(attr_idx)) { 06850 goto EXIT; 06851 } 06852 } 06853 06854 /* We allow inline and ipa directives on interfaces. */ 06855 /* Do some semantics here. First they can only be */ 06856 /* specified on intrinsics that have user specified */ 06857 /* intrinsics. Second, set the flags on the specifics. */ 06858 06859 if (ATI_INLINE_ALWAYS(attr_idx) || 06860 ATI_INLINE_NEVER(attr_idx) || 06861 ATI_SGI_ROUTINE_INLINE(attr_idx) || 06862 ATI_SGI_ROUTINE_NOINLINE(attr_idx)) { 06863 06864 if (AT_IS_INTRIN(attr_idx) && !ATI_USER_SPECIFIED(attr_idx)) { 06865 06866 if (ATI_IPA_DIR_SPECIFIED(attr_idx)) { 06867 PRINTMSG(AT_DEF_LINE(attr_idx), 1655, Error, 06868 AT_DEF_COLUMN(attr_idx), 06869 AT_OBJ_NAME_PTR(attr_idx), 06870 "IPA"); 06871 } 06872 else { /* INLINE directive */ 06873 PRINTMSG(AT_DEF_LINE(attr_idx), 1655, Error, 06874 AT_DEF_COLUMN(attr_idx), 06875 AT_OBJ_NAME_PTR(attr_idx), 06876 "INLINE"); 06877 } 06878 } 06879 else { /* Set flags on specifics */ 06880 sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx); 06881 06882 while (sn_idx != NULL_IDX) { 06883 06884 if (!AT_IS_INTRIN(SN_ATTR_IDX(sn_idx))) { 06885 ATP_INLINE_ALWAYS(SN_ATTR_IDX(sn_idx)) = 06886 ATI_INLINE_ALWAYS(attr_idx); 06887 ATP_INLINE_NEVER(SN_ATTR_IDX(sn_idx)) = 06888 ATI_INLINE_NEVER(attr_idx); 06889 ATP_SGI_ROUTINE_INLINE(SN_ATTR_IDX(sn_idx)) = 06890 ATI_SGI_ROUTINE_INLINE(attr_idx); 06891 ATP_SGI_ROUTINE_NOINLINE(SN_ATTR_IDX(sn_idx)) = 06892 ATI_SGI_ROUTINE_NOINLINE(attr_idx); 06893 } 06894 sn_idx = SN_SIBLING_LINK(sn_idx); 06895 } 06896 } 06897 } 06898 06899 verify_interface(attr_idx); 06900 } 06901 break; 06902 06903 case Namelist_Grp: 06904 06905 NTR_SN_TBL(sn_idx); 06906 06907 SN_SIBLING_LINK(sn_idx) = namelist_list_idx; 06908 namelist_list_idx = sn_idx; 06909 SN_ATTR_IDX(sn_idx) = attr_idx; 06910 06911 break; 06912 06913 case Stmt_Func: 06914 06915 if (AT_COMPILER_GEND(attr_idx)) { 06916 break; 06917 } 06918 06919 type_idx = ATD_TYPE_IDX(attr_idx); 06920 06921 if (TYP_TYPE(type_idx) == Structure) { 06922 06923 if (AT_ATTR_LINK(TYP_IDX(type_idx)) != NULL_IDX) { 06924 06925 /* If this derived type is host associated (AT_ATTR_LINK is set) */ 06926 /* change the type table to point to the original type. It is */ 06927 /* okay to change the type table, because every attr of this type */ 06928 /* needs to do this. */ 06929 06930 link_idx = TYP_IDX(type_idx); 06931 06932 while (AT_ATTR_LINK(link_idx) != NULL_IDX) { 06933 link_idx = AT_ATTR_LINK(link_idx); 06934 } 06935 06936 TYP_IDX(type_idx) = link_idx; 06937 } 06938 06939 attr_semantics(TYP_IDX(type_idx), FALSE); 06940 } 06941 06942 if (ATP_PGM_UNIT(pgm_attr_idx) == Module) { 06943 06944 if (TYP_TYPE(type_idx) == Structure && 06945 !AT_PRIVATE(attr_idx) && 06946 AT_PRIVATE(TYP_IDX(type_idx)) && 06947 !AT_USE_ASSOCIATED(TYP_IDX(type_idx))) { /* Interp 161 */ 06948 PRINTMSG(AT_DEF_LINE(attr_idx), 598, Error, 06949 AT_DEF_COLUMN(attr_idx), 06950 AT_OBJ_NAME_PTR(attr_idx), 06951 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 06952 } 06953 } 06954 06955 if (AT_USE_ASSOCIATED(attr_idx)) { 06956 goto EXIT; 06957 } 06958 06959 if (TYP_TYPE(type_idx) == Character) { 06960 06961 if (TYP_FLD(type_idx) == AT_Tbl_Idx) { 06962 attr_semantics(TYP_IDX(type_idx), TRUE); 06963 } 06964 } 06965 06966 if (AT_DCL_ERR(attr_idx)) { 06967 goto EXIT; 06968 } 06969 06970 if (!AT_TYPED(attr_idx)) { 06971 06972 if (SCP_IMPL_NONE(curr_scp_idx)) { 06973 AT_DCL_ERR(attr_idx) = TRUE; 06974 PRINTMSG(AT_DEF_LINE(attr_idx), 740, Error, 06975 AT_DEF_COLUMN(attr_idx), 06976 AT_OBJ_NAME_PTR(attr_idx)); 06977 } 06978 else if (!IM_SET(curr_scp_idx, IMPL_IDX(AT_OBJ_NAME(attr_idx)))) { 06979 06980 if (SCP_PARENT_NONE(curr_scp_idx)) { 06981 AT_DCL_ERR(attr_idx) = TRUE; 06982 PRINTMSG(AT_DEF_LINE(attr_idx), 742, Error, 06983 AT_DEF_COLUMN(attr_idx), 06984 AT_OBJ_NAME_PTR(attr_idx)); 06985 } 06986 else if (on_off_flags.implicit_none) { 06987 AT_DCL_ERR(attr_idx) = TRUE; 06988 PRINTMSG(AT_DEF_LINE(attr_idx), 1171, Error, 06989 AT_DEF_COLUMN(attr_idx), 06990 AT_OBJ_NAME_PTR(attr_idx)); 06991 } 06992 } 06993 } 06994 06995 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 06996 char_len_resolution(attr_idx, FALSE); 06997 type_idx = ATD_TYPE_IDX(attr_idx); /* Reset type_idx */ 06998 } 06999 07000 /* Check the dummy arguments. */ 07001 07002 first_idx = ATP_FIRST_IDX(attr_idx); 07003 count = ATP_NUM_DARGS(attr_idx); 07004 07005 for (i = first_idx; i < (first_idx + count); i++) { 07006 sf_attr_idx = SN_ATTR_IDX(i); 07007 07008 if (TYP_TYPE(ATD_TYPE_IDX(sf_attr_idx)) == Character) { 07009 07010 if (TYP_TYPE(ATD_TYPE_IDX(sf_attr_idx)) == Character) { 07011 07012 if (TYP_FLD(ATD_TYPE_IDX(sf_attr_idx)) == AT_Tbl_Idx) { 07013 attr_semantics(TYP_IDX(ATD_TYPE_IDX(sf_attr_idx)), TRUE); 07014 } 07015 } 07016 07017 type_resolved = TYP_RESOLVED(ATD_TYPE_IDX(sf_attr_idx)); 07018 char_len_resolution(sf_attr_idx, TRUE); 07019 07020 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(sf_attr_idx)) != Const_Len_Char) { 07021 07022 if (!AT_DCL_ERR(sf_attr_idx)) { 07023 PRINTMSG(AT_DEF_LINE(sf_attr_idx), 215, Error, 07024 AT_DEF_COLUMN(sf_attr_idx), 07025 AT_OBJ_NAME_PTR(sf_attr_idx), 07026 AT_OBJ_NAME_PTR(attr_idx)); 07027 AT_DCL_ERR(sf_attr_idx) = TRUE; 07028 } 07029 07030 /* Reset so that if type needs to be resolved for use as a */ 07031 /* variable that it happens and error recovery is good. */ 07032 07033 TYP_RESOLVED(ATD_TYPE_IDX(sf_attr_idx)) = type_resolved; 07034 ATD_TYPE_IDX(sf_attr_idx) = CHARACTER_DEFAULT_TYPE; 07035 } 07036 } 07037 07038 if (!AT_TYPED(sf_attr_idx)) { 07039 07040 if (SCP_IMPL_NONE(curr_scp_idx)) { 07041 AT_DCL_ERR(sf_attr_idx) = TRUE; 07042 PRINTMSG(AT_DEF_LINE(sf_attr_idx), 741, Error, 07043 AT_DEF_COLUMN(sf_attr_idx), 07044 AT_OBJ_NAME_PTR(sf_attr_idx)); 07045 } 07046 else if (!IM_SET(curr_scp_idx, IMPL_IDX(AT_OBJ_NAME(sf_attr_idx)))){ 07047 07048 if (SCP_PARENT_NONE(curr_scp_idx)) { 07049 AT_DCL_ERR(sf_attr_idx) = TRUE; 07050 PRINTMSG(AT_DEF_LINE(sf_attr_idx), 743, Error, 07051 AT_DEF_COLUMN(sf_attr_idx), 07052 AT_OBJ_NAME_PTR(sf_attr_idx)); 07053 } 07054 else if (on_off_flags.implicit_none) { 07055 AT_DCL_ERR(attr_idx) = TRUE; 07056 PRINTMSG(AT_DEF_LINE(sf_attr_idx), 1171, Error, 07057 AT_DEF_COLUMN(sf_attr_idx), 07058 AT_OBJ_NAME_PTR(sf_attr_idx)); 07059 } 07060 } 07061 } 07062 07063 darg_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(sf_attr_idx), 07064 AT_NAME_LEN(sf_attr_idx), 07065 &name_idx); 07066 07067 if (darg_idx != NULL_IDX && AT_OBJ_CLASS(darg_idx) == Data_Obj && 07068 TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != 07069 TYP_TYPE(ATD_TYPE_IDX(sf_attr_idx))) { 07070 07071 PRINTMSG(AT_DEF_LINE(sf_attr_idx), 940, Ansi, 07072 AT_DEF_COLUMN(sf_attr_idx), 07073 AT_OBJ_NAME_PTR(sf_attr_idx)); 07074 } 07075 } 07076 break; 07077 07078 } /* End switch */ 07079 07080 # ifdef COARRAY_FORTRAN 07081 # if 0 07082 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 07083 ATD_CLASS(attr_idx) == Variable && 07084 ATD_ALLOCATABLE(attr_idx) && 07085 ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX && 07086 ATD_VARIABLE_TMP_IDX(attr_idx) == NULL_IDX && 07087 ! AT_DCL_ERR(attr_idx)) { 07088 07089 /* set up ptr/pointee pair with explicit bd entries */ 07090 07091 gen_allocatable_ptr_ptee(attr_idx); 07092 } 07093 # endif 07094 # endif 07095 07096 EXIT: 07097 07098 AT_SEMANTICS_DONE(attr_idx) = TRUE; 07099 07100 TRACE (Func_Exit, "attr_semantics", NULL); 07101 07102 return; 07103 07104 } /* attr_semantics */ 07105 07106 /******************************************************************************\ 07107 |* *| 07108 |* Description: *| 07109 |* This does semantic checking for the end of an interface block. *| 07110 |* *| 07111 |* Input parameters: *| 07112 |* NONE *| 07113 |* *| 07114 |* Output parameters: *| 07115 |* NONE *| 07116 |* *| 07117 |* Returns: *| 07118 |* NONE *| 07119 |* *| 07120 \******************************************************************************/ 07121 static void namelist_resolution(int namelist_idx) 07122 { 07123 07124 int attr_idx; 07125 int entry_idx; 07126 boolean namelist_err; 07127 int namelist_grp_attr; 07128 int scp_idx; 07129 int sn_idx; 07130 boolean taskcommon; 07131 07132 07133 TRACE (Func_Entry, "namelist_resolution", NULL); 07134 07135 taskcommon = cmd_line_flags.taskcommon; 07136 07137 while (namelist_idx != NULL_IDX) { 07138 namelist_grp_attr = SN_ATTR_IDX(namelist_idx); 07139 sn_idx = ATN_FIRST_NAMELIST_IDX(namelist_grp_attr); 07140 07141 if (!AT_USE_ASSOCIATED(namelist_grp_attr)) { 07142 namelist_err = FALSE; 07143 07144 while (sn_idx != NULL_IDX) { 07145 attr_idx = SN_ATTR_IDX(sn_idx); 07146 07147 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 07148 attr_idx = AT_ATTR_LINK(attr_idx); 07149 } 07150 07151 /* If they have the same name, this will always be the pgm unit */ 07152 07153 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 07154 ATP_PGM_UNIT(attr_idx) == Function && 07155 ATP_PROC(attr_idx) != Intrin_Proc) { 07156 07157 if (attr_idx == SCP_ATTR_IDX(curr_scp_idx) || 07158 (ATP_ALT_ENTRY(attr_idx) && 07159 SCP_PARENT_IDX(curr_scp_idx) == NULL_IDX)) { 07160 goto FOUND; 07161 } 07162 07163 scp_idx = curr_scp_idx; 07164 07165 while (scp_idx != NULL_IDX) { 07166 07167 if (attr_idx == SCP_ATTR_IDX(scp_idx)) { 07168 goto FOUND; 07169 } 07170 07171 entry_idx = SCP_ENTRY_IDX(scp_idx); 07172 07173 while (entry_idx != NULL_IDX) { 07174 07175 if (attr_idx == AL_ATTR_IDX(entry_idx)) { 07176 goto FOUND; 07177 } 07178 entry_idx = AL_NEXT_IDX(entry_idx); 07179 } 07180 scp_idx = SCP_PARENT_IDX(scp_idx); 07181 } 07182 07183 PRINTMSG(SN_LINE_NUM(sn_idx), 657, Error, SN_COLUMN_NUM(sn_idx), 07184 AT_OBJ_NAME_PTR(attr_idx)); 07185 AT_DCL_ERR(attr_idx) = TRUE; 07186 AT_DCL_ERR(ATP_RSLT_IDX(attr_idx)) = TRUE; 07187 namelist_err = TRUE; 07188 07189 FOUND: 07190 if (!ATP_RSLT_NAME(attr_idx)) { 07191 07192 /* If the function and the result name are the same name */ 07193 /* switch it to use the result name. If they are different */ 07194 /* this will be caught by fnd_semantic_err. */ 07195 07196 attr_idx = ATP_RSLT_IDX(attr_idx); 07197 } 07198 } 07199 07200 AT_NAMELIST_OBJ(attr_idx) = TRUE; 07201 SN_ATTR_IDX(sn_idx) = attr_idx; 07202 07203 if (!AT_DCL_ERR(attr_idx) && 07204 !fnd_semantic_err(Obj_Namelist_Obj, 07205 SN_LINE_NUM(sn_idx), 07206 SN_COLUMN_NUM(sn_idx), 07207 attr_idx, 07208 TRUE)) { 07209 07210 if (ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX && 07211 SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Task_Common) { 07212 07213 taskcommon = TRUE; 07214 } 07215 07216 if (ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX && 07217 SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)) && 07218 SB_AUXILIARY(ATD_STOR_BLK_IDX(attr_idx))) { 07219 PRINTMSG(SN_LINE_NUM(sn_idx), 663, Error, 07220 SN_COLUMN_NUM(sn_idx), 07221 AT_OBJ_NAME_PTR(attr_idx), 07222 SB_NAME_PTR(ATD_STOR_BLK_IDX(attr_idx))); 07223 AT_DCL_ERR(attr_idx) = TRUE; /* Needed to prevent dup msg */ 07224 namelist_err = TRUE; 07225 } 07226 07227 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 07228 ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) { 07229 PRINTMSG(SN_LINE_NUM(sn_idx), 484, Error, 07230 SN_COLUMN_NUM(sn_idx), 07231 AT_OBJ_NAME_PTR(attr_idx)); 07232 namelist_err = TRUE; 07233 } 07234 07235 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 07236 !AT_PRIVATE(namelist_grp_attr) && AT_PRIVATE(attr_idx) && 07237 !AT_USE_ASSOCIATED(attr_idx)) { /* Interp 161 */ 07238 07239 PRINTMSG(SN_LINE_NUM(sn_idx), 438, Error, 07240 SN_COLUMN_NUM(sn_idx), 07241 AT_OBJ_NAME_PTR(namelist_grp_attr), 07242 AT_OBJ_NAME_PTR(attr_idx)); 07243 namelist_err = TRUE; 07244 } 07245 else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 07246 !AT_PRIVATE(namelist_grp_attr) && 07247 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 07248 ATT_PRIVATE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) { 07249 07250 PRINTMSG(SN_LINE_NUM(sn_idx), 1085, Error, 07251 SN_COLUMN_NUM(sn_idx), 07252 AT_OBJ_NAME_PTR(namelist_grp_attr), 07253 AT_OBJ_NAME_PTR(attr_idx)); 07254 namelist_err = TRUE; 07255 } 07256 } 07257 else { 07258 namelist_err = TRUE; 07259 } 07260 07261 sn_idx = SN_SIBLING_LINK(sn_idx); 07262 } 07263 07264 if (namelist_err) { 07265 AT_DCL_ERR(namelist_grp_attr) = TRUE; 07266 } 07267 else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Module || 07268 ! taskcommon) { 07269 /* need to have a way to know if it is referenced */ 07270 07271 /* April create_namelist_descriptor(namelist_grp_attr); */ 07272 } 07273 } 07274 else if (ATN_NAMELIST_DESC(namelist_grp_attr)) { 07275 AT_REFERENCED(ATN_NAMELIST_DESC(namelist_grp_attr)) = Referenced; 07276 ADD_ATTR_TO_LOCAL_LIST(ATN_NAMELIST_DESC(namelist_grp_attr)); 07277 /* check for rename of group name */ 07278 } 07279 07280 namelist_idx = SN_SIBLING_LINK(namelist_idx); 07281 07282 } 07283 07284 TRACE (Func_Exit, "namelist_resolution", NULL); 07285 07286 return; 07287 07288 } /* namelist_resolution */ 07289 07290 /******************************************************************************\ 07291 |* *| 07292 |* Description: *| 07293 |* This routine takes a statement and looks for a matching statement in *| 07294 |* the bounds list. If a match is found, it returns the attr_idx of *| 07295 |* the matched bound tmp. If there is no match, a compiler temp is *| 07296 |* generated and added to the end of the bounds tmp list. This assumes *| 07297 |* that the ir pointed to by ATD_TMP_IDX is always of the form *| 07298 |* TMP = ir_stream, so it passes to compare_ir the right operand of *| 07299 |* the compiler temp. And then if a new temp is needed, this routine *| 07300 |* generates the TMP =. An assumption is made that this tmp can never *| 07301 |* have more than one statement generated for it. This is because tmp *| 07302 |* stuff called with this routine is always made up of other tmps. *| 07303 |* Stuff that goes through here is extents, stride multipliers, and *| 07304 |* lengths. *| 07305 |* *| 07306 |* Input parameters: *| 07307 |* opnd A pointer to an operand pointing to the attribute or ir stream *| 07308 |* that needs a temp. This should NOT have TMP = generated yet. *| 07309 |* *| 07310 |* Output parameters: *| 07311 |* NONE *| 07312 |* *| 07313 |* Returns: *| 07314 |* attr_idx Index to attr table for this temp. *| 07315 |* *| 07316 \******************************************************************************/ 07317 07318 static int ntr_bnds_sh_tmp_list(opnd_type *opnd, 07319 int no_entry_list, 07320 int sh_idx, 07321 boolean gen_tmp_eq_0, 07322 int type_idx) 07323 07324 { 07325 int al_idx; 07326 int attr_idx; 07327 int column; 07328 int ir_idx; 07329 int line; 07330 int prev_al = NULL_IDX; 07331 07332 07333 TRACE (Func_Entry, "ntr_bnds_sh_tmp_list", NULL); 07334 07335 find_opnd_line_and_column(opnd, &line, &column); 07336 07337 if (SCP_IS_INTERFACE(curr_scp_idx)) { 07338 07339 /* This is in an interface block - so do not generate statement headers */ 07340 07341 GEN_COMPILER_TMP_ASG(ir_idx, 07342 attr_idx, 07343 TRUE, /* Semantics is done */ 07344 line, 07345 column, 07346 type_idx, 07347 Priv); 07348 07349 IR_IDX_R(ATD_TMP_IDX(attr_idx)) = OPND_IDX((*opnd)); 07350 IR_FLD_R(ATD_TMP_IDX(attr_idx)) = OPND_FLD((*opnd)); 07351 IR_LINE_NUM_R(ATD_TMP_IDX(attr_idx)) = line; 07352 IR_COL_NUM_R(ATD_TMP_IDX(attr_idx)) = column; 07353 07354 AT_REFERENCED(attr_idx) = Not_Referenced; 07355 goto EXIT; 07356 } 07357 07358 al_idx = SCP_TMP_FW_IDX2(curr_scp_idx); 07359 07360 while (al_idx != NULL_IDX) { 07361 attr_idx = AL_ATTR_IDX(al_idx); 07362 07363 /* Okay to pass a pointer to the operand here, because it should */ 07364 /* not move. This is only a call to compare operands. */ 07365 07366 if (compare_opnds(opnd, &(IR_OPND_R((ATD_TMP_IDX(attr_idx)))))) { 07367 break; 07368 } 07369 prev_al = al_idx; 07370 al_idx = AL_NEXT_IDX(al_idx); 07371 } 07372 07373 if (al_idx == NULL_IDX) { /* At the end of bounds list. Add new temp. */ 07374 GEN_COMPILER_TMP_ASG(ir_idx, 07375 attr_idx, 07376 TRUE, /* Semantics is done */ 07377 line, 07378 column, 07379 type_idx, 07380 Priv); 07381 07382 COPY_OPND(IR_OPND_R(ir_idx), (*opnd)); /* IR_OPND_R = *opnd */ 07383 SH_IR_IDX(sh_idx) = ir_idx; 07384 07385 /* can't assume that the SH_NEXT_IDX(save_sh_idx) is null */ 07386 /* I do assume that sh_idx is a stand alone sh. BHJ */ 07387 07388 if (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) { 07389 SH_NEXT_IDX(sh_idx) = SH_NEXT_IDX(curr_stmt_sh_idx); 07390 SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = sh_idx; 07391 } 07392 07393 SH_NEXT_IDX(curr_stmt_sh_idx) = sh_idx; 07394 SH_PREV_IDX(sh_idx) = curr_stmt_sh_idx; 07395 curr_stmt_sh_idx = sh_idx; 07396 07397 NTR_ATTR_LIST_TBL(al_idx); 07398 AL_ATTR_IDX(al_idx) = attr_idx; 07399 07400 /* Bounds must always go at the end of the list. */ 07401 07402 if (prev_al == NULL_IDX) { /* List is empty. Add first tmp to list */ 07403 SCP_TMP_FW_IDX2(curr_scp_idx) = al_idx; 07404 } 07405 else { 07406 AL_NEXT_IDX(prev_al) = al_idx; 07407 } 07408 07409 if (SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX) { 07410 ATD_NO_ENTRY_LIST(attr_idx) = merge_entry_lists(NULL_IDX, 07411 no_entry_list); 07412 insert_sh_after_entries(attr_idx, 07413 SH_PREV_IDX(curr_stmt_sh_idx), 07414 curr_stmt_sh_idx, 07415 gen_tmp_eq_0, 07416 TRUE); /* Advance ATP_FIRST_SH_IDX */ 07417 } 07418 } 07419 else { 07420 07421 /* If this shared bound is only used in alternate entries and */ 07422 /* gen_tmp_eq_0 is set, make sure that tmp = 0 gets generated */ 07423 /* in the entry points where tmp = IR is not generated. */ 07424 /* ATD_TMP_GEN_ZERO is set once tmp = 0 has been generated. */ 07425 07426 if (no_entry_list != NULL_IDX && !ATD_TMP_GEN_ZERO(attr_idx)) { 07427 gen_tmp_eq_zero_ir(attr_idx); 07428 } 07429 07430 FREE_SH_NODE(sh_idx); 07431 } 07432 07433 EXIT: 07434 07435 TRACE (Func_Exit, "ntr_bnds_sh_tmp_list", NULL); 07436 07437 return (attr_idx); 07438 07439 } /* ntr_bnds_sh_tmp_list */ 07440 07441 /******************************************************************************\ 07442 |* *| 07443 |* Description: *| 07444 |* This routine merges two no entry lists. The combined list is the *| 07445 |* first list. *| 07446 |* *| 07447 |* Input parameters: *| 07448 |* merged_list - Index to the list to have attr added to it. *| 07449 |* new_list - List to add to the merged list. *| 07450 |* *| 07451 |* Output parameters: *| 07452 |* NONE *| 07453 |* *| 07454 |* Returns: *| 07455 |* An index to the start of the merged list. *| 07456 |* *| 07457 \******************************************************************************/ 07458 static int merge_entry_lists(int merged_list, 07459 int new_list) 07460 07461 { 07462 int list_idx = NULL_IDX; 07463 int merged_list_start; 07464 int prev_idx; 07465 07466 07467 TRACE (Func_Entry, "merge_entry_lists", NULL); 07468 07469 merged_list_start = merged_list; 07470 07471 if (merged_list == NULL_IDX) { /* Just make a new list */ 07472 07473 while (new_list != NULL_IDX) { 07474 prev_idx = list_idx; 07475 NTR_ATTR_LIST_TBL(list_idx); 07476 07477 if (prev_idx == NULL_IDX) { 07478 merged_list_start = list_idx; 07479 AL_ENTRY_COUNT(merged_list_start) = AL_ENTRY_COUNT(new_list); 07480 } 07481 else { 07482 AL_NEXT_IDX(prev_idx) = list_idx; 07483 } 07484 07485 AL_ATTR_IDX(list_idx) = AL_ATTR_IDX(new_list); 07486 new_list = AL_NEXT_IDX(new_list); 07487 } 07488 } 07489 else { 07490 07491 while (new_list != NULL_IDX) { 07492 07493 list_idx = merged_list; 07494 07495 while (list_idx != NULL_IDX && 07496 AL_ATTR_IDX(new_list) != AL_ATTR_IDX(list_idx)) { 07497 prev_idx = list_idx; 07498 list_idx = AL_NEXT_IDX(list_idx); 07499 } 07500 07501 /* If list_idx is NULL, the attr was not found on the list, so add */ 07502 /* the attribute to the bottom of the list. Prev_idx is pointing */ 07503 /* to the bottom of the list. */ 07504 07505 if (list_idx == NULL_IDX) { 07506 NTR_ATTR_LIST_TBL(list_idx); 07507 AL_NEXT_IDX(prev_idx) = list_idx; 07508 AL_ATTR_IDX(list_idx) = AL_ATTR_IDX(new_list); 07509 AL_ENTRY_COUNT(merged_list) += 1; 07510 } 07511 07512 new_list = AL_NEXT_IDX(new_list); 07513 } 07514 } 07515 07516 TRACE (Func_Exit, "merge_entry_lists", NULL); 07517 07518 return(merged_list_start); 07519 07520 } /* merge_entry_lists */ 07521 07522 /******************************************************************************\ 07523 |* *| 07524 |* Description: *| 07525 |* This routine merges two no entry lists. The combined list is the *| 07526 |* first list. *| 07527 |* *| 07528 |* Input parameters: *| 07529 |* merged_list - Index to the list to have attr added to it. *| 07530 |* new_list - List to add to the merged list. *| 07531 |* *| 07532 |* Output parameters: *| 07533 |* NONE *| 07534 |* *| 07535 |* Returns: *| 07536 |* An index to the start of the merged list. *| 07537 |* *| 07538 \******************************************************************************/ 07539 static int merge_entry_list_count(int merged_list, 07540 int new_list) 07541 07542 { 07543 int count; 07544 int list_idx = NULL_IDX; 07545 07546 07547 TRACE (Func_Entry, "merge_entry_list_count", NULL); 07548 07549 if (merged_list == NULL_IDX) { 07550 count = (new_list != NULL_IDX) ? AL_ENTRY_COUNT(new_list) : 0; 07551 } 07552 else { 07553 07554 /* Count the different members of the two lists */ 07555 07556 count = AL_ENTRY_COUNT(merged_list); 07557 07558 while (new_list != NULL_IDX) { 07559 list_idx = merged_list; 07560 07561 while (list_idx != NULL_IDX && 07562 AL_ATTR_IDX(new_list) != AL_ATTR_IDX(list_idx)) { 07563 list_idx = AL_NEXT_IDX(list_idx); 07564 } 07565 07566 /* If list_idx is NULL, the attr was not found on the list, */ 07567 /* so add one to the count. The assumption is that there are */ 07568 /* never duplicates on a list. */ 07569 07570 if (list_idx == NULL_IDX) { 07571 count++; 07572 } 07573 07574 new_list = AL_NEXT_IDX(new_list); 07575 } 07576 } 07577 07578 TRACE (Func_Exit, "merge_entry_list_count", NULL); 07579 07580 return(count); 07581 07582 } /* merge_entry_list_count */ 07583 07584 /******************************************************************************\ 07585 |* *| 07586 |* Description: *| 07587 |* This returns TRUE if the entry point is NOT in the NO_ENTRY_LIST *| 07588 |* for the given attr. *| 07589 |* *| 07590 |* Input parameters: *| 07591 |* entry_attr - Entry point attr to check *| 07592 |* attr_idx - Attr_idx with list. *| 07593 |* *| 07594 |* Output parameters: *| 07595 |* NONE *| 07596 |* *| 07597 |* Returns: *| 07598 |* FALSE if the entry attr is on the list. *| 07599 |* *| 07600 \******************************************************************************/ 07601 static boolean gen_ir_at_this_entry(int entry_attr, 07602 int attr_idx) 07603 07604 { 07605 boolean not_in_list = TRUE; 07606 int list_idx; 07607 07608 07609 TRACE (Func_Entry, "gen_ir_at_this_entry", NULL); 07610 07611 list_idx = (ATD_CLASS(attr_idx) == Function_Result) ? 07612 ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) : 07613 ATD_NO_ENTRY_LIST(attr_idx); 07614 07615 while (list_idx != NULL_IDX) { 07616 07617 if (AL_ATTR_IDX(list_idx) == entry_attr) { 07618 not_in_list = FALSE; 07619 break; 07620 } 07621 07622 list_idx = AL_NEXT_IDX(list_idx); 07623 } 07624 07625 TRACE (Func_Exit, "gen_ir_at_this_entry", NULL); 07626 07627 return(not_in_list); 07628 07629 } /* gen_ir_at_this_entry */ 07630 07631 /******************************************************************************\ 07632 |* *| 07633 |* Description: *| 07634 |* This generates tmp code at entry points. It works off of *| 07635 |* ATD_NO_ENTRY_LIST for the tmp. If gen_tmp_eq_0 is TRUE, tmp = 0 *| 07636 |* is generated at those entry points where the IR cannot be generated. *| 07637 |* NOTE: There is an assumption that if gen_tmp_eq_0 is TRUE, there is *| 07638 |* only one SH for this bound. There is a debug check for this. *| 07639 |* If there were multiple SH's, we wouldn't know which one to *| 07640 |* replace with the tmp = 0. *| 07641 |* *| 07642 |* Input parameters: *| 07643 |* attr_idx - Attr index of tmp (or the attr to use for the *| 07644 |* ATD_NO_ENTRY_LIST and AT_OPTIONAL. *| 07645 |* start_sh_idx - SH index to index BEFORE the first SH to be copied. *| 07646 |* end_sh_idx - SH index of last SH to be copied. *| 07647 |* gen_tmp_eq_0 - If TRUE, need tmp = 0, gen'd where tmp = IR can't be. *| 07648 |* advance_first_sh - If TRUE, advance ATP_FIRST_SH_IDX, else don't. *| 07649 |* *| 07650 |* Output parameters: *| 07651 |* NONE *| 07652 |* *| 07653 |* Returns: *| 07654 |* NONE *| 07655 |* *| 07656 \******************************************************************************/ 07657 static void insert_sh_after_entries(int attr_idx, 07658 int start_sh_idx, 07659 int end_sh_idx, 07660 boolean gen_tmp_eq_0, 07661 boolean advance_first_sh) 07662 { 07663 boolean bump_curr_sh; 07664 int entry_attr_idx; 07665 int entry_list_idx; 07666 int entry_sh_idx; 07667 int ir_idx; 07668 int new_start_sh_idx; 07669 int new_end_sh_idx; 07670 int next_sh_idx; 07671 int no_entry_list; 07672 int save_curr_sh_idx; 07673 int sh_idx; 07674 07675 07676 TRACE (Func_Entry, "insert_sh_after_entries", NULL); 07677 07678 if (SH_NEXT_IDX(start_sh_idx) == NULL_IDX) { 07679 return; /* Nothing to add */ 07680 } 07681 07682 entry_list_idx = SCP_ENTRY_IDX(curr_scp_idx); 07683 07684 no_entry_list = (ATD_CLASS(attr_idx) == Function_Result) ? 07685 ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) : 07686 ATD_NO_ENTRY_LIST(attr_idx); 07687 07688 while (entry_list_idx != NULL_IDX) { 07689 entry_attr_idx = AL_ATTR_IDX(entry_list_idx); 07690 07691 if (no_entry_list == NULL_IDX || 07692 gen_ir_at_this_entry(entry_attr_idx, attr_idx)) { 07693 entry_sh_idx = ATP_FIRST_SH_IDX(entry_attr_idx); 07694 next_sh_idx = SH_NEXT_IDX(entry_sh_idx); 07695 07696 copy_entry_exit_sh_list(SH_NEXT_IDX(start_sh_idx), 07697 end_sh_idx, 07698 &new_start_sh_idx, 07699 &new_end_sh_idx); 07700 07701 if (new_start_sh_idx != NULL_IDX) { 07702 SH_NEXT_IDX(entry_sh_idx) = new_start_sh_idx; 07703 SH_PREV_IDX(new_start_sh_idx) = entry_sh_idx; 07704 07705 entry_sh_idx = new_end_sh_idx; 07706 07707 SH_PREV_IDX(next_sh_idx) = entry_sh_idx; 07708 SH_NEXT_IDX(entry_sh_idx) = next_sh_idx; 07709 # if 0 /*fzhao */ 07710 if (AT_OPTIONAL(attr_idx)) { 07711 gen_present_ir(attr_idx, 07712 SH_NEXT_IDX(ATP_FIRST_SH_IDX(entry_attr_idx)), 07713 entry_sh_idx); 07714 entry_sh_idx = SH_NEXT_IDX(entry_sh_idx); 07715 } 07716 # endif 07717 07718 if (advance_first_sh) { 07719 ATP_FIRST_SH_IDX(entry_attr_idx) = entry_sh_idx; 07720 } 07721 } 07722 } 07723 07724 else if (gen_tmp_eq_0) { 07725 07726 /* This tmp is used to generate a length. If the length can't be */ 07727 /* calculated at this entry point, generate tmp = 0 */ 07728 07729 save_curr_sh_idx = curr_stmt_sh_idx; 07730 curr_stmt_sh_idx = ATP_FIRST_SH_IDX(entry_attr_idx); 07731 07732 /* Find Entry_Opr */ 07733 07734 while (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) != Entry_Opr) { 07735 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07736 } 07737 07738 gen_sh(After, 07739 Assignment_Stmt, 07740 SH_GLB_LINE(curr_stmt_sh_idx), 07741 SH_COL_NUM(curr_stmt_sh_idx), 07742 FALSE, /* Err flag */ 07743 FALSE, /* labeled */ 07744 TRUE); /* Compiler generated */ 07745 07746 NTR_IR_TBL(ir_idx); 07747 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 07748 07749 COPY_TBL_NTRY(ir_tbl, ir_idx, ATD_TMP_IDX(attr_idx)); 07750 07751 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 07752 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 07753 IR_LINE_NUM_R(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 07754 IR_COL_NUM_R(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx); 07755 07756 ATD_TMP_GEN_ZERO(attr_idx) = TRUE; 07757 07758 /* ignore the advance_first_sh flag, not needed here */ 07759 07760 if (IR_OPR(SH_IR_IDX(ATP_FIRST_SH_IDX(entry_attr_idx))) == Entry_Opr) { 07761 ATP_FIRST_SH_IDX(entry_attr_idx) = curr_stmt_sh_idx; 07762 } 07763 07764 curr_stmt_sh_idx = save_curr_sh_idx; 07765 } 07766 entry_list_idx = AL_NEXT_IDX(entry_list_idx); 07767 } 07768 07769 end_sh_idx = SH_NEXT_IDX(end_sh_idx); 07770 07771 if (no_entry_list != NULL_IDX && 07772 !gen_ir_at_this_entry(SCP_ATTR_IDX(curr_scp_idx), attr_idx)) { 07773 07774 /* At this point, start_sh_idx points to the stmt header BEFORE */ 07775 /* the first stmt header to delete or replace. end_sh_idx points */ 07776 /* to the stmt header after the last statement to delete. */ 07777 07778 /* Remove it from the main entry, if it doesn't belong here. */ 07779 07780 sh_idx = SH_NEXT_IDX(start_sh_idx); 07781 curr_stmt_sh_idx = start_sh_idx; 07782 07783 do { 07784 next_sh_idx = SH_NEXT_IDX(sh_idx); 07785 FREE_SH_NODE(sh_idx); 07786 sh_idx = next_sh_idx; 07787 } 07788 while (sh_idx != end_sh_idx); 07789 07790 SH_NEXT_IDX(start_sh_idx) = end_sh_idx; 07791 07792 if (end_sh_idx != NULL_IDX) { 07793 SH_PREV_IDX(end_sh_idx) = start_sh_idx; 07794 } 07795 07796 if (gen_tmp_eq_0) { 07797 07798 /* Insert tmp = 0, but these must be inserted first after the */ 07799 /* Entry_Opr because variable length character functions have */ 07800 /* their length temps equivalenced. Thus we have to make sure */ 07801 /* that tmp1 = 0 happens before tmp2 = I in case tmp1 and tmp2 */ 07802 /* are equivalenced together. */ 07803 07804 save_curr_sh_idx = curr_stmt_sh_idx; 07805 bump_curr_sh = TRUE; 07806 07807 /* Find Entry_Opr */ 07808 07809 while (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) != Entry_Opr) { 07810 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07811 bump_curr_sh = FALSE; 07812 } 07813 07814 gen_sh(After, 07815 Assignment_Stmt, 07816 SH_GLB_LINE(curr_stmt_sh_idx), 07817 SH_COL_NUM(curr_stmt_sh_idx), 07818 FALSE, /* Err flag */ 07819 FALSE, /* labeled */ 07820 TRUE); /* Compiler generated */ 07821 07822 NTR_IR_TBL(ir_idx); 07823 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 07824 IR_OPR(ir_idx) = Asg_Opr; 07825 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 07826 IR_LINE_NUM(ir_idx) = AT_DEF_LINE(attr_idx); 07827 IR_COL_NUM(ir_idx) = AT_DEF_COLUMN(attr_idx); 07828 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 07829 IR_IDX_L(ir_idx) = attr_idx; 07830 IR_LINE_NUM_L(ir_idx) = AT_DEF_LINE(attr_idx); 07831 IR_COL_NUM_L(ir_idx) = AT_DEF_COLUMN(attr_idx); 07832 IR_LINE_NUM_R(ir_idx) = AT_DEF_LINE(attr_idx); 07833 IR_COL_NUM_R(ir_idx) = AT_DEF_COLUMN(attr_idx); 07834 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 07835 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 07836 ATD_TMP_GEN_ZERO(attr_idx) = TRUE; 07837 07838 curr_stmt_sh_idx = (bump_curr_sh) ? SH_NEXT_IDX(save_curr_sh_idx) : 07839 save_curr_sh_idx; 07840 } 07841 } 07842 else if (AT_OPTIONAL(attr_idx)) { 07843 # if 0 /*fzhao */ 07844 gen_present_ir(attr_idx, 07845 SH_NEXT_IDX(start_sh_idx), 07846 curr_stmt_sh_idx); 07847 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 07848 07849 #endif 07850 ; 07851 } 07852 07853 TRACE (Func_Exit, "insert_sh_after_entries", NULL); 07854 07855 return; 07856 07857 } /* insert_sh_after_entries */ 07858 07859 /******************************************************************************\ 07860 |* *| 07861 |* Description: *| 07862 |* This generated tmp = 0 IR for entry points, where tmp = IR cannot be *| 07863 |* generated. This assumes that TMP=IR has been generated previously. *| 07864 |* *| 07865 |* Input parameters: *| 07866 |* attr_idx - Attr_idx of tmp. *| 07867 |* *| 07868 |* Output parameters: *| 07869 |* NONE *| 07870 |* *| 07871 |* Returns: *| 07872 |* NONE *| 07873 |* *| 07874 \******************************************************************************/ 07875 static void gen_tmp_eq_zero_ir(int attr_idx) 07876 { 07877 int entry_attr_idx; 07878 int entry_list_idx; 07879 int entry_sh_idx; 07880 int ir_idx; 07881 int next_sh_idx; 07882 int new_sh_idx; 07883 07884 07885 TRACE (Func_Entry, "gen_tmp_eq_zero_ir", NULL); 07886 07887 entry_list_idx = SCP_ENTRY_IDX(curr_scp_idx); 07888 07889 while (entry_list_idx != NULL_IDX) { 07890 entry_attr_idx = AL_ATTR_IDX(entry_list_idx); 07891 07892 if (!gen_ir_at_this_entry(entry_attr_idx, attr_idx)) { 07893 entry_sh_idx = ATP_FIRST_SH_IDX(entry_attr_idx); 07894 next_sh_idx = SH_NEXT_IDX(entry_sh_idx); 07895 new_sh_idx = ntr_sh_tbl(); 07896 SH_NEXT_IDX(entry_sh_idx) = new_sh_idx; 07897 SH_NEXT_IDX(new_sh_idx) = next_sh_idx; 07898 SH_PREV_IDX(new_sh_idx) = entry_sh_idx; 07899 SH_PREV_IDX(next_sh_idx) = new_sh_idx; 07900 SH_STMT_TYPE(new_sh_idx) = Automatic_Base_Size_Stmt; 07901 SH_GLB_LINE(new_sh_idx) = AT_DEF_LINE(attr_idx); 07902 SH_COL_NUM(new_sh_idx) = AT_DEF_COLUMN(attr_idx); 07903 SH_COMPILER_GEN(new_sh_idx) = TRUE; 07904 SH_P2_SKIP_ME(new_sh_idx) = TRUE; 07905 NTR_IR_TBL(ir_idx); 07906 SH_IR_IDX(new_sh_idx) = ir_idx; 07907 IR_OPR(ir_idx) = Asg_Opr; 07908 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 07909 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 07910 IR_IDX_L(ir_idx) = attr_idx; 07911 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 07912 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 07913 IR_LINE_NUM_L(ir_idx) = AT_DEF_LINE(attr_idx); 07914 IR_LINE_NUM_R(ir_idx) = AT_DEF_LINE(attr_idx); 07915 IR_LINE_NUM(ir_idx) = AT_DEF_LINE(attr_idx); 07916 IR_COL_NUM_L(ir_idx) = AT_DEF_COLUMN(attr_idx); 07917 IR_COL_NUM_R(ir_idx) = AT_DEF_COLUMN(attr_idx); 07918 IR_COL_NUM(ir_idx) = AT_DEF_COLUMN(attr_idx); 07919 ATD_TMP_GEN_ZERO(attr_idx) = TRUE; 07920 ATP_FIRST_SH_IDX(entry_attr_idx) = new_sh_idx; 07921 ATD_TMP_GEN_ZERO(attr_idx) = TRUE; 07922 } 07923 entry_list_idx = AL_NEXT_IDX(entry_list_idx); 07924 } 07925 07926 if (!gen_ir_at_this_entry(SCP_ATTR_IDX(curr_scp_idx), attr_idx)) { 07927 new_sh_idx = ntr_sh_tbl(); 07928 SH_NEXT_IDX(curr_stmt_sh_idx) = new_sh_idx; 07929 SH_PREV_IDX(new_sh_idx) = curr_stmt_sh_idx; 07930 SH_STMT_TYPE(new_sh_idx) = Automatic_Base_Size_Stmt; 07931 SH_GLB_LINE(new_sh_idx) = AT_DEF_LINE(attr_idx); 07932 SH_COL_NUM(new_sh_idx) = AT_DEF_COLUMN(attr_idx); 07933 SH_COMPILER_GEN(new_sh_idx) = TRUE; 07934 SH_P2_SKIP_ME(new_sh_idx) = TRUE; 07935 NTR_IR_TBL(ir_idx); 07936 SH_IR_IDX(new_sh_idx) = ir_idx; 07937 IR_OPR(ir_idx) = Asg_Opr; 07938 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 07939 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 07940 IR_IDX_L(ir_idx) = attr_idx; 07941 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 07942 IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX; 07943 IR_LINE_NUM_L(ir_idx) = AT_DEF_LINE(attr_idx); 07944 IR_LINE_NUM_R(ir_idx) = AT_DEF_LINE(attr_idx); 07945 IR_LINE_NUM(ir_idx) = AT_DEF_LINE(attr_idx); 07946 IR_COL_NUM_L(ir_idx) = AT_DEF_COLUMN(attr_idx); 07947 IR_COL_NUM_R(ir_idx) = AT_DEF_COLUMN(attr_idx); 07948 IR_COL_NUM(ir_idx) = AT_DEF_COLUMN(attr_idx); 07949 ATD_TMP_GEN_ZERO(attr_idx) = TRUE; 07950 curr_stmt_sh_idx = new_sh_idx; 07951 } 07952 07953 TRACE (Func_Exit, "gen_tmp_eq_zero_ir", NULL); 07954 07955 return; 07956 07957 } /* gen_tmp_eq_zero_ir */ 07958 07959 /******************************************************************************\ 07960 |* *| 07961 |* Description: *| 07962 |* This generates if PRESENT code for optional dummy arguments. *| 07963 |* *| 07964 |* Input parameters: *| 07965 |* attr_idx - Attr_idx of darg that is optional *| 07966 |* start_sh_idx - Index to start of IR to have an if present put around *| 07967 |* end_sh_idx - Index to end of IR to have an if present put around *| 07968 |* This gets updated to point to the new last sh idx. *| 07969 |* *| 07970 |* Output parameters: *| 07971 |* NONE *| 07972 |* *| 07973 |* Returns: *| 07974 |* NONE *| 07975 |* *| 07976 \******************************************************************************/ 07977 static void gen_present_ir(int attr_idx, 07978 int start_sh_idx, 07979 int end_sh_idx) 07980 { 07981 int br_around_opt; 07982 int br_idx; 07983 int cont_idx; 07984 int present_idx; 07985 int not_idx; 07986 int save_sh_idx; 07987 07988 07989 TRACE (Func_Entry, "gen_present_ir", NULL); 07990 07991 save_sh_idx = curr_stmt_sh_idx; 07992 curr_stmt_sh_idx = start_sh_idx; 07993 07994 gen_sh(Before, 07995 Goto_Stmt, 07996 SH_GLB_LINE(start_sh_idx), 07997 SH_COL_NUM(start_sh_idx), 07998 FALSE, 07999 FALSE, 08000 TRUE); 08001 08002 SH_P2_SKIP_ME(SH_PREV_IDX(start_sh_idx)) = TRUE; 08003 08004 br_around_opt = gen_internal_lbl(stmt_start_line); 08005 08006 NTR_IR_TBL(br_idx); 08007 NTR_IR_TBL(present_idx); 08008 NTR_IR_TBL(not_idx); 08009 08010 IR_OPR(br_idx) = Br_True_Opr; 08011 IR_OPR(not_idx) = Not_Opr; 08012 IR_OPR(present_idx) = Present_Opr; 08013 IR_TYPE_IDX(present_idx) = LOGICAL_DEFAULT_TYPE; 08014 IR_TYPE_IDX(br_idx) = LOGICAL_DEFAULT_TYPE; 08015 IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE; 08016 08017 SH_IR_IDX(SH_PREV_IDX(start_sh_idx)) = br_idx; 08018 IR_LINE_NUM(br_idx) = AT_DEF_LINE(attr_idx); 08019 IR_COL_NUM(br_idx) = AT_DEF_COLUMN(attr_idx); 08020 IR_LINE_NUM(not_idx) = AT_DEF_LINE(attr_idx); 08021 IR_COL_NUM(not_idx) = AT_DEF_COLUMN(attr_idx); 08022 IR_LINE_NUM(present_idx) = AT_DEF_LINE(attr_idx); 08023 IR_COL_NUM(present_idx) = AT_DEF_COLUMN(attr_idx); 08024 08025 IR_FLD_R(br_idx) = AT_Tbl_Idx; 08026 IR_IDX_R(br_idx) = br_around_opt; 08027 IR_COL_NUM_R(br_idx) = AT_DEF_COLUMN(attr_idx); 08028 IR_LINE_NUM_R(br_idx) = AT_DEF_LINE(attr_idx); 08029 08030 IR_FLD_L(br_idx) = IR_Tbl_Idx; 08031 IR_IDX_L(br_idx) = not_idx; 08032 08033 IR_FLD_L(not_idx) = IR_Tbl_Idx; 08034 IR_IDX_L(not_idx) = present_idx; 08035 08036 IR_FLD_L(present_idx) = AT_Tbl_Idx; 08037 IR_IDX_L(present_idx) = attr_idx; 08038 IR_COL_NUM_L(present_idx) = AT_DEF_COLUMN(attr_idx); 08039 IR_LINE_NUM_L(present_idx) = AT_DEF_LINE(attr_idx); 08040 08041 NTR_IR_TBL(cont_idx); 08042 IR_OPR(cont_idx) = Label_Opr; 08043 IR_TYPE_IDX(cont_idx) = TYPELESS_DEFAULT_TYPE; 08044 IR_LINE_NUM(cont_idx) = AT_DEF_LINE(attr_idx); 08045 IR_COL_NUM(cont_idx) = AT_DEF_COLUMN(attr_idx); 08046 IR_IDX_L(cont_idx) = br_around_opt; 08047 IR_FLD_L(cont_idx) = AT_Tbl_Idx; 08048 IR_LINE_NUM_L(cont_idx) = AT_DEF_LINE(attr_idx); 08049 IR_COL_NUM_L(cont_idx) = AT_DEF_COLUMN(attr_idx); 08050 curr_stmt_sh_idx = end_sh_idx; 08051 08052 gen_sh(After, 08053 Continue_Stmt, 08054 SH_GLB_LINE(end_sh_idx), 08055 SH_COL_NUM(end_sh_idx), 08056 FALSE, 08057 TRUE, 08058 TRUE); 08059 08060 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 08061 SH_IR_IDX(curr_stmt_sh_idx) = cont_idx; 08062 curr_stmt_sh_idx = save_sh_idx; 08063 08064 TRACE (Func_Exit, "gen_present_ir", NULL); 08065 08066 return; 08067 08068 } /* gen_present_ir */ 08069 08070 /******************************************************************************\ 08071 |* *| 08072 |* Description: *| 08073 |* *| 08074 |* Input parameters: *| 08075 |* ir_idx => ir to check *| 08076 |* *| 08077 |* Output parameters: *| 08078 |* NONE *| 08079 |* *| 08080 |* Returns: *| 08081 |* NONE *| 08082 |* *| 08083 \******************************************************************************/ 08084 static void tmp_ir_resolution(int ir_idx) 08085 { 08086 08087 TRACE (Func_Entry, "tmp_ir_resolution", NULL); 08088 08089 08090 switch (IR_FLD_L(ir_idx)) { 08091 08092 case AT_Tbl_Idx: 08093 attr_semantics(IR_IDX_L(ir_idx), FALSE); 08094 break; 08095 08096 case IR_Tbl_Idx: 08097 tmp_ir_resolution(IR_IDX_L(ir_idx)); 08098 break; 08099 08100 case IL_Tbl_Idx: 08101 tmp_il_resolution(IR_IDX_L(ir_idx)); 08102 break; 08103 } 08104 08105 08106 switch (IR_FLD_R(ir_idx)) { 08107 08108 case AT_Tbl_Idx: 08109 attr_semantics(IR_IDX_R(ir_idx), FALSE); 08110 break; 08111 08112 case IR_Tbl_Idx: 08113 tmp_ir_resolution(IR_IDX_R(ir_idx)); 08114 break; 08115 08116 case IL_Tbl_Idx: 08117 tmp_il_resolution(IR_IDX_R(ir_idx)); 08118 break; 08119 } 08120 08121 TRACE (Func_Exit, "tmp_ir_resolution", NULL); 08122 08123 return; 08124 08125 } /* tmp_ir_resolution */ 08126 08127 /******************************************************************************\ 08128 |* *| 08129 |* Description: *| 08130 |* *| 08131 |* Input parameters: *| 08132 |* list_idx => il to check *| 08133 |* *| 08134 |* Output parameters: *| 08135 |* NONE *| 08136 |* *| 08137 |* Returns: *| 08138 |* NONE *| 08139 |* *| 08140 \******************************************************************************/ 08141 static void tmp_il_resolution(int list_idx) 08142 { 08143 08144 TRACE (Func_Entry, "tmp_il_resolution", NULL); 08145 08146 while (list_idx != NULL_IDX) { 08147 08148 switch (IL_FLD(list_idx)) { 08149 08150 case AT_Tbl_Idx: 08151 attr_semantics(IL_IDX(list_idx), FALSE); 08152 break; 08153 08154 case IR_Tbl_Idx: 08155 tmp_ir_resolution(IL_IDX(list_idx)); 08156 break; 08157 08158 case IL_Tbl_Idx: 08159 tmp_il_resolution(IL_IDX(list_idx)); 08160 break; 08161 08162 } 08163 list_idx = IL_NEXT_LIST_IDX(list_idx); 08164 } 08165 08166 TRACE (Func_Exit, "tmp_il_resolution", NULL); 08167 08168 return; 08169 08170 } /* tmp_il_resolution */ 08171 08172 /******************************************************************************\ 08173 |* *| 08174 |* Description: *| 08175 |* Go through the list pointed to by allocatable_list_idx and set up a *| 08176 |* call to _DEALLOC for all the local allocatable arrays. *| 08177 |* *| 08178 |* Input parameters: *| 08179 |* NONE *| 08180 |* *| 08181 |* Output parameters: *| 08182 |* NONE *| 08183 |* *| 08184 |* Returns: *| 08185 |* NOTHING *| 08186 |* *| 08187 \******************************************************************************/ 08188 08189 static void deallocate_local_allocatables(void) 08190 08191 { 08192 int asg_idx; 08193 int cn_idx; 08194 int col; 08195 boolean has_normal_ref = FALSE; 08196 boolean has_pe_ref = FALSE; 08197 int line; 08198 int list_idx; 08199 int loc_idx; 08200 int save_curr_stmt_sh_idx; 08201 int sn_idx; 08202 int start_sh_idx; 08203 08204 08205 TRACE (Func_Entry, "deallocate_local_allocatables", NULL); 08206 08207 line = stmt_start_line; 08208 col = stmt_start_col; 08209 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 08210 08211 if (glb_tbl_idx[Dealloc_Attr_Idx] == NULL_IDX) { 08212 glb_tbl_idx[Dealloc_Attr_Idx] = create_lib_entry_attr(DEALLOC_LIB_ENTRY, 08213 DEALLOC_NAME_LEN, 08214 line, 08215 col); 08216 } 08217 08218 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Dealloc_Attr_Idx]); 08219 08220 # ifdef _SEPARATE_DEALLOCATES 08221 sn_idx = allocatable_list_idx; 08222 08223 start_sh_idx = ntr_sh_tbl(); 08224 curr_stmt_sh_idx = start_sh_idx; 08225 08226 SH_STMT_TYPE(curr_stmt_sh_idx) = Assignment_Stmt; 08227 SH_GLB_LINE(curr_stmt_sh_idx) = line; 08228 SH_COL_NUM(curr_stmt_sh_idx) = col; 08229 SH_COMPILER_GEN(curr_stmt_sh_idx) = TRUE; 08230 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 08231 08232 while (sn_idx) { 08233 08234 if (ATD_ALLOCATABLE(SN_ATTR_IDX(sn_idx)) && 08235 ATD_PE_ARRAY_IDX(SN_ATTR_IDX(sn_idx)) != NULL_IDX) { 08236 has_pe_ref = TRUE; 08237 } 08238 else { 08239 has_pe_ref = FALSE; 08240 } 08241 08242 NTR_IR_LIST_TBL(list_idx); 08243 asg_idx = gen_ir(IL_Tbl_Idx, list_idx, 08244 Deallocate_Opr, TYPELESS_DEFAULT_TYPE, line, col, 08245 NO_Tbl_Idx, NULL_IDX); 08246 08247 loc_idx = gen_ir(AT_Tbl_Idx, SN_ATTR_IDX(sn_idx), 08248 Aloc_Opr, CRI_Ptr_8, line, col, 08249 NO_Tbl_Idx, NULL_IDX); 08250 08251 IL_FLD(list_idx) = IR_Tbl_Idx; 08252 IL_IDX(list_idx) = loc_idx; 08253 08254 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 08255 08256 # ifdef _ALLOCATE_IS_CALL 08257 set_up_allocate_as_call(asg_idx, 08258 glb_tbl_idx[Dealloc_Attr_Idx], 08259 NULL_IDX, 08260 has_pe_ref); 08261 # else 08262 08263 list_idx = gen_il(3, FALSE, line, col, 08264 AT_Tbl_Idx, glb_tbl_idx[Dealloc_Attr_Idx], 08265 CN_Tbl_Idx, gen_alloc_header_const(Integer_8, 08266 1, 08267 has_pe_ref, 08268 &cn_idx), 08269 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 08270 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 08271 IR_IDX_R(asg_idx) = list_idx; 08272 IR_LIST_CNT_R(asg_idx) = 3; 08273 # endif 08274 08275 08276 sn_idx = SN_SIBLING_LINK(sn_idx); 08277 08278 if (sn_idx) { 08279 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 08280 } 08281 } 08282 08283 # else 08284 08285 NTR_IR_TBL(asg_idx); 08286 IR_OPR(asg_idx) = Deallocate_Opr; 08287 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 08288 IR_LINE_NUM(asg_idx) = line; 08289 IR_COL_NUM(asg_idx) = col; 08290 08291 NTR_IR_LIST_TBL(list_idx); 08292 IR_FLD_L(asg_idx) = IL_Tbl_Idx; 08293 IR_IDX_L(asg_idx) = list_idx; 08294 IR_LIST_CNT_L(asg_idx) = number_of_allocatables; 08295 08296 sn_idx = allocatable_list_idx; 08297 08298 while (sn_idx) { 08299 08300 if (ATD_ALLOCATABLE(SN_ATTR_IDX(sn_idx)) && 08301 ATD_PE_ARRAY_IDX(SN_ATTR_IDX(sn_idx)) != NULL_IDX) { 08302 has_pe_ref = TRUE; 08303 } 08304 else { 08305 has_normal_ref = TRUE; 08306 } 08307 08308 NTR_IR_TBL(loc_idx); 08309 IR_OPR(loc_idx) = Aloc_Opr; 08310 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 08311 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 08312 IR_IDX_L(loc_idx) = SN_ATTR_IDX(sn_idx); 08313 IR_LINE_NUM(loc_idx) = line; 08314 IR_COL_NUM(loc_idx) = col; 08315 IR_LINE_NUM_L(loc_idx) = line; 08316 IR_COL_NUM_L(loc_idx) = col; 08317 IL_FLD(list_idx) = IR_Tbl_Idx; 08318 IL_IDX(list_idx) = loc_idx; 08319 08320 sn_idx = SN_SIBLING_LINK(sn_idx); 08321 08322 if (sn_idx) { 08323 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 08324 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 08325 list_idx = IL_NEXT_LIST_IDX(list_idx); 08326 } 08327 } 08328 08329 start_sh_idx = ntr_sh_tbl(); 08330 curr_stmt_sh_idx = start_sh_idx; 08331 08332 SH_STMT_TYPE(curr_stmt_sh_idx) = Assignment_Stmt; 08333 SH_GLB_LINE(curr_stmt_sh_idx) = line; 08334 SH_COL_NUM(curr_stmt_sh_idx) = col; 08335 SH_COMPILER_GEN(curr_stmt_sh_idx) = TRUE; 08336 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 08337 08338 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 08339 08340 if (has_pe_ref && has_normal_ref) { 08341 /* must pull the normal refs off on their own call */ 08342 gen_split_alloc(asg_idx, 08343 glb_tbl_idx[Dealloc_Attr_Idx], 08344 NULL_IDX); 08345 } 08346 08347 08348 # ifdef _ALLOCATE_IS_CALL 08349 set_up_allocate_as_call(asg_idx, 08350 glb_tbl_idx[Dealloc_Attr_Idx], 08351 NULL_IDX, 08352 has_pe_ref); 08353 # else 08354 list_idx = gen_il(3, FALSE, line, col, 08355 AT_Tbl_Idx, glb_tbl_idx[Dealloc_Attr_Idx], 08356 CN_Tbl_Idx, 08357 gen_alloc_header_const(Integer_8, 08358 number_of_allocatables, 08359 has_pe_ref, 08360 &cn_idx), 08361 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 08362 IR_FLD_R(asg_idx) = IL_Tbl_Idx; 08363 IR_IDX_R(asg_idx) = list_idx; 08364 IR_LIST_CNT_R(asg_idx) = 3; 08365 08366 # endif 08367 # endif 08368 08369 while (SH_PREV_IDX(start_sh_idx)) { 08370 start_sh_idx = SH_PREV_IDX(start_sh_idx); 08371 } 08372 08373 if (SH_NEXT_IDX(curr_stmt_sh_idx)) { 08374 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 08375 } 08376 08377 if (SCP_EXIT_IR_SH_IDX(curr_scp_idx) != NULL_IDX) { 08378 SH_NEXT_IDX(curr_stmt_sh_idx) = SCP_EXIT_IR_SH_IDX(curr_scp_idx); 08379 SCP_EXIT_IR_SH_IDX(curr_scp_idx) = start_sh_idx; 08380 } 08381 else { 08382 SCP_EXIT_IR_SH_IDX(curr_scp_idx) = start_sh_idx; 08383 } 08384 08385 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 08386 08387 TRACE (Func_Exit, "deallocate_local_allocatables", NULL); 08388 08389 return; 08390 08391 } /* deallocate_local_allocatables */ 08392 08393 /******************************************************************************\ 08394 |* *| 08395 |* Description: *| 08396 |* darg_in_entry_list searches the secondary name table entries of *| 08397 |* an explicit interface for an attr. The entries in the secondary *| 08398 |* name table must be in sequential order. *| 08399 |* *| 08400 |* Input parameters: *| 08401 |* srch_idx Attribute index to search for. *| 08402 |* entry_idx Attribute index of entry that contains the list of *| 08403 |* dummy arguments to search. *| 08404 |* *| 08405 |* Output parameters: *| 08406 |* NONE *| 08407 |* *| 08408 |* Returns: *| 08409 |* TRUE if this darg's attr is in the entry list, otherwise FALSE *| 08410 |* *| 08411 \******************************************************************************/ 08412 static boolean darg_in_entry_list (int srch_idx, 08413 int entry_idx) 08414 { 08415 register int i; 08416 register boolean matched = FALSE; 08417 register int member_cnt; 08418 register long *sn_tbl_base; 08419 08420 08421 TRACE (Func_Entry, "darg_in_entry_list", NULL); 08422 08423 member_cnt = ATP_NUM_DARGS(entry_idx); 08424 08425 #ifdef _HOST_LITTLE_ENDIAN 08426 /* found by PV 778027 */ 08427 08428 for (i = ATP_FIRST_IDX(entry_idx); 08429 i < ATP_FIRST_IDX(entry_idx) + member_cnt; 08430 i++) { 08431 if (SN_ATTR_IDX(i) == srch_idx) { 08432 matched = TRUE; 08433 break; 08434 } 08435 } /* for i */ 08436 #else 08437 08438 sn_tbl_base = (long *) (sec_name_tbl + ATP_FIRST_IDX(entry_idx)) + 08439 (NUM_SN_WDS - 1); 08440 08441 # pragma _CRI ivdep 08442 08443 for (i = 0; i < member_cnt; i++) { 08444 08445 if ((sn_tbl_base[0] & 077777777) == srch_idx) { 08446 matched = TRUE; 08447 break; 08448 } 08449 sn_tbl_base = sn_tbl_base + NUM_SN_WDS; 08450 } 08451 08452 #endif 08453 08454 TRACE (Func_Exit, "darg_in_entry_list", NULL); 08455 08456 return (matched); 08457 08458 } /* darg_in_entry_list */ 08459 08460 /******************************************************************************\ 08461 |* *| 08462 |* Description: *| 08463 |* This generates ir to change a byte length into a word aligned length *| 08464 |* The new length is a word length. *| 08465 |* *| 08466 |* Input/Output parameters: *| 08467 |* len_opnd Operand containing the length to be converted. Should *| 08468 |* have a valid line and column number. At return, len_opnd *| 08469 |* contains the new word aligned word length. *| 08470 |* *| 08471 |* Output parameters: *| 08472 |* NONE *| 08473 |* *| 08474 |* Returns: *| 08475 |* The new length in len opnd. *| 08476 |* *| 08477 \******************************************************************************/ 08478 # if defined(_TARGET_WORD_ADDRESS) || \ 08479 (defined(_HEAP_REQUEST_IN_WORDS) && defined(_TARGET_BYTE_ADDRESS)) 08480 static void gen_word_align_byte_length_ir(opnd_type *len_opnd) 08481 { 08482 int column; 08483 int div_idx; 08484 int line; 08485 int paren_idx; 08486 int plus_idx; 08487 int type_idx; 08488 08489 08490 TRACE (Func_Entry, "gen_word_align_byte_length_ir", NULL); 08491 08492 line = OPND_LINE_NUM((*len_opnd)); 08493 column = OPND_COL_NUM((*len_opnd)); 08494 08495 NTR_IR_TBL(div_idx); 08496 NTR_IR_TBL(paren_idx); 08497 NTR_IR_TBL(plus_idx); 08498 IR_LINE_NUM(div_idx) = line; 08499 IR_COL_NUM(div_idx) = column; 08500 IR_LINE_NUM(paren_idx) = line; 08501 IR_COL_NUM(paren_idx) = column; 08502 IR_LINE_NUM(plus_idx) = line; 08503 IR_COL_NUM(plus_idx) = column; 08504 08505 type_idx = check_type_for_size_address(len_opnd); 08506 08507 COPY_OPND(IR_OPND_L(plus_idx), (*len_opnd)); 08508 08509 /* Div_Opr (Left is paren IR, Right is number of bytes per word) */ 08510 08511 IR_OPR(div_idx) = Div_Opr; 08512 IR_TYPE_IDX(div_idx) = type_idx; 08513 IR_FLD_L(div_idx) = IR_Tbl_Idx; 08514 IR_IDX_L(div_idx) = paren_idx; 08515 IR_FLD_R(div_idx) = CN_Tbl_Idx; 08516 IR_IDX_R(div_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08517 TARGET_BYTES_PER_WORD); 08518 IR_LINE_NUM_R(div_idx) = line; 08519 IR_COL_NUM_R(div_idx) = column; 08520 08521 /* Paren_Opr (Left is plus IR, Right is NULL) */ 08522 08523 IR_OPR(paren_idx) = Paren_Opr; 08524 IR_TYPE_IDX(div_idx) = type_idx; 08525 IR_TYPE_IDX(paren_idx) = type_idx; 08526 IR_FLD_L(paren_idx) = IR_Tbl_Idx; 08527 IR_IDX_L(paren_idx) = plus_idx; 08528 IR_LINE_NUM_L(paren_idx) = line; 08529 IR_COL_NUM_L(paren_idx) = column; 08530 08531 /* Plus_Opr (Left is num of bytes, Right is (word byte size - 1)) */ 08532 08533 IR_OPR(plus_idx) = Plus_Opr; 08534 IR_TYPE_IDX(div_idx) = type_idx; 08535 IR_LINE_NUM_R(plus_idx) = line; 08536 IR_COL_NUM_R(plus_idx) = column; 08537 IR_FLD_R(plus_idx) = CN_Tbl_Idx; 08538 IR_IDX_R(plus_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08539 TARGET_BYTES_PER_WORD - 1); 08540 OPND_FLD((*len_opnd)) = IR_Tbl_Idx; 08541 OPND_IDX((*len_opnd)) = div_idx; 08542 08543 TRACE (Func_Exit, "gen_word_align_byte_length_ir", NULL); 08544 08545 return; 08546 08547 } /* gen_word_align_byte_length_ir */ 08548 # endif 08549 08550 /******************************************************************************\ 08551 |* *| 08552 |* Description: *| 08553 |* This names a new equiv block. *| 08554 |* *| 08555 |* Output parameters: *| 08556 |* NONE *| 08557 |* *| 08558 |* Returns: *| 08559 |* The new blocks index. *| 08560 |* *| 08561 \******************************************************************************/ 08562 int create_equiv_stor_blk(int attr_idx, 08563 sb_type_type sb_type) 08564 { 08565 08566 static char equivblk[8]; 08567 static int ceb = 64; 08568 id_str_type storage_name; 08569 int sb_idx; 08570 08571 08572 TRACE (Func_Entry, "create_equiv_stor_blk", NULL); 08573 08574 ceb = ceb + 1; 08575 08576 if (ceb == 91) { 08577 ceb = 65; /* start over at "A" again */ 08578 } 08579 08580 # if defined(_NO_AT_SIGN_IN_NAMES) 08581 equivblk[0] = '.'; 08582 # else 08583 equivblk[0] = '@'; 08584 # endif 08585 equivblk[1] = 'E'; 08586 equivblk[2] = 'Q'; 08587 equivblk[3] = 'U'; 08588 equivblk[4] = 'I'; 08589 equivblk[5] = 'V'; 08590 equivblk[6] = (char)ceb; 08591 08592 CREATE_ID(storage_name, equivblk, 7); 08593 08594 if (sb_type == Stack) { 08595 sb_type = Equivalenced; 08596 } 08597 08598 sb_idx = ntr_stor_blk_tbl(storage_name.string, 7, 08599 AT_DEF_LINE(attr_idx), 08600 AT_DEF_COLUMN(attr_idx), 08601 sb_type); 08602 08603 SB_EQUIVALENCED(sb_idx) = TRUE; 08604 SB_MODULE(sb_idx) = SB_MODULE(SCP_SB_STATIC_IDX(curr_scp_idx)); 08605 /* fzhao add */ 08606 08607 TRACE (Func_Exit, "create_equiv_stor_blk", NULL); 08608 08609 return(sb_idx); 08610 08611 } /* create_equiv_stor_blk */ 08612 08613 /******************************************************************************\ 08614 |* *| 08615 |* Description: *| 08616 |* <description> *| 08617 |* *| 08618 |* Input parameters: *| 08619 |* NONE *| 08620 |* *| 08621 |* Output parameters: *| 08622 |* NONE *| 08623 |* *| 08624 |* Returns: *| 08625 |* NOTHING *| 08626 |* *| 08627 \******************************************************************************/ 08628 08629 static void insert_argchck_calls(int sh_idx, 08630 int pgm_attr_idx) 08631 08632 { 08633 int argchck_darg_idx; 08634 int br_true_idx; 08635 int col; 08636 int ir_idx; 08637 int label_idx; 08638 int line; 08639 int list_idx; 08640 int loc_idx; 08641 int not_idx; 08642 opnd_type opnd; 08643 int save_curr_stmt_sh_idx; 08644 08645 # if 0 08646 int cn_idx; 08647 long_type the_constant; 08648 # endif 08649 08650 08651 TRACE (Func_Entry, "insert_argchck_calls", NULL); 08652 08653 line = SH_GLB_LINE(curr_stmt_sh_idx); 08654 col = SH_COL_NUM(curr_stmt_sh_idx); 08655 08656 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 08657 curr_stmt_sh_idx = sh_idx; 08658 08659 /* create branch around test on argchck flag present */ 08660 08661 label_idx = gen_internal_lbl(line); 08662 08663 # if 1 08664 NTR_IR_TBL(ir_idx); 08665 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 08666 IR_OPR(ir_idx) = Argchck_Present_Opr; 08667 IR_LINE_NUM(ir_idx) = line; 08668 IR_COL_NUM(ir_idx) = col; 08669 08670 NTR_IR_TBL(not_idx); 08671 IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE; 08672 IR_OPR(not_idx) = Not_Opr; 08673 IR_LINE_NUM(not_idx) = line; 08674 IR_COL_NUM(not_idx) = col; 08675 08676 IR_FLD_L(not_idx) = IR_Tbl_Idx; 08677 IR_IDX_L(not_idx) = ir_idx; 08678 # else 08679 cn_idx = set_up_logical_constant(&the_constant, 08680 CG_LOGICAL_DEFAULT_TYPE, 08681 TRUE_VALUE, 08682 TRUE); 08683 NTR_IR_TBL(not_idx); 08684 IR_TYPE_IDX(not_idx) = LOGICAL_DEFAULT_TYPE; 08685 IR_OPR(not_idx) = Not_Opr; 08686 IR_LINE_NUM(not_idx) = line; 08687 IR_COL_NUM(not_idx) = col; 08688 08689 IR_FLD_L(not_idx) = CN_Tbl_Idx; 08690 IR_IDX_L(not_idx) = cn_idx; 08691 IR_LINE_NUM_L(not_idx) = line; 08692 IR_COL_NUM_L(not_idx) = col; 08693 # endif 08694 08695 NTR_IR_TBL(br_true_idx); 08696 IR_OPR(br_true_idx) = Br_True_Opr; 08697 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 08698 IR_LINE_NUM(br_true_idx) = line; 08699 IR_COL_NUM(br_true_idx) = col; 08700 IR_FLD_R(br_true_idx) = AT_Tbl_Idx; 08701 IR_IDX_R(br_true_idx) = label_idx; 08702 IR_LINE_NUM_R(br_true_idx) = line; 08703 IR_COL_NUM_R(br_true_idx) = col; 08704 08705 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 08706 IR_IDX_L(br_true_idx) = not_idx; 08707 08708 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 08709 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 08710 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08711 08712 /* put call to argchck routine here */ 08713 08714 OPND_FLD(opnd) = AT_Tbl_Idx; 08715 OPND_IDX(opnd) = pgm_attr_idx; 08716 OPND_LINE_NUM(opnd) = line; 08717 OPND_COL_NUM(opnd) = col; 08718 argchck_darg_idx = create_argchck_descriptor(&opnd); 08719 08720 NTR_IR_TBL(ir_idx); 08721 IR_OPR(ir_idx) = Call_Opr; 08722 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 08723 IR_LINE_NUM(ir_idx) = line; 08724 IR_COL_NUM(ir_idx) = col; 08725 08726 if (glb_tbl_idx[Argchck_Attr_Idx] == NULL_IDX) { 08727 glb_tbl_idx[Argchck_Attr_Idx] = create_lib_entry_attr(ARGCHCK_LIB_ENTRY, 08728 ARGCHCK_NAME_LEN, 08729 line, 08730 col); 08731 } 08732 08733 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Argchck_Attr_Idx]); 08734 08735 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 08736 IR_IDX_L(ir_idx) = glb_tbl_idx[Argchck_Attr_Idx]; 08737 IR_LINE_NUM_L(ir_idx) = line; 08738 IR_COL_NUM_L(ir_idx) = col; 08739 08740 NTR_IR_LIST_TBL(list_idx); 08741 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 08742 IR_IDX_R(ir_idx) = list_idx; 08743 IR_LIST_CNT_R(ir_idx) = 2; 08744 08745 NTR_IR_TBL(loc_idx); 08746 IR_OPR(loc_idx) = Argchck_Loc_Opr; 08747 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 08748 IR_LINE_NUM(loc_idx) = line; 08749 IR_COL_NUM(loc_idx) = col; 08750 IL_FLD(list_idx) = IR_Tbl_Idx; 08751 IL_IDX(list_idx) = loc_idx; 08752 08753 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 08754 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 08755 list_idx = IL_NEXT_LIST_IDX(list_idx); 08756 08757 NTR_IR_TBL(loc_idx); 08758 IR_OPR(loc_idx) = Aloc_Opr; 08759 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 08760 IR_LINE_NUM(loc_idx) = line; 08761 IR_COL_NUM(loc_idx) = col; 08762 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 08763 IR_IDX_L(loc_idx) = argchck_darg_idx; 08764 IR_LINE_NUM_L(loc_idx) = line; 08765 IR_COL_NUM_L(loc_idx) = col; 08766 IL_FLD(list_idx) = IR_Tbl_Idx; 08767 IL_IDX(list_idx) = loc_idx; 08768 08769 gen_sh(Before, Call_Stmt, line, col, FALSE, FALSE, TRUE); 08770 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 08771 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08772 08773 08774 /* now, put label in it's place */ 08775 08776 NTR_IR_TBL(ir_idx); 08777 IR_OPR(ir_idx) = Label_Opr; 08778 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 08779 IR_LINE_NUM(ir_idx) = line; 08780 IR_COL_NUM(ir_idx) = col; 08781 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 08782 IR_IDX_L(ir_idx) = label_idx; 08783 IR_COL_NUM_L(ir_idx) = col; 08784 IR_LINE_NUM_L(ir_idx) = line; 08785 08786 AT_DEFINED(label_idx) = TRUE; 08787 08788 gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 08789 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08790 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 08791 08792 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 08793 08794 TRACE (Func_Exit, "insert_argchck_calls", NULL); 08795 08796 return; 08797 08798 } /* insert_argchck_calls */ 08799 08800 /******************************************************************************\ 08801 |* *| 08802 |* Description: *| 08803 |* <description> *| 08804 |* *| 08805 |* Input parameters: *| 08806 |* NONE *| 08807 |* *| 08808 |* Output parameters: *| 08809 |* NONE *| 08810 |* *| 08811 |* Returns: *| 08812 |* NOTHING *| 08813 |* *| 08814 \******************************************************************************/ 08815 08816 static void gen_assumed_shape_copy(opnd_type *top_opnd) 08817 08818 { 08819 int addr_asg_idx; 08820 int addr_tmp_idx; 08821 int asg_idx; 08822 int attr_idx; 08823 int br_true_idx; 08824 int cn_idx; 08825 int col; 08826 opnd_type dv_opnd; 08827 int entry_attr_idx; 08828 int entry_list_idx; 08829 expr_arg_type exp_desc; 08830 int i; 08831 int intent; 08832 int ir_idx; 08833 int label_idx1; 08834 int label_idx2; 08835 int label_idx3; 08836 expr_arg_type l_exp_desc; 08837 opnd_type left_opnd; 08838 int line; 08839 int ne_idx; 08840 int new_end_idx; 08841 int new_start_idx; 08842 opnd_type opnd; 08843 int place_holder_sh_idx; 08844 expr_arg_type r_exp_desc; 08845 opnd_type right_opnd; 08846 int save_curr_stmt_sh_idx; 08847 cif_usage_code_type save_xref_state; 08848 int save_sh; 08849 int sh_idx; 08850 int tmp_idx; 08851 08852 08853 TRACE (Func_Entry, "gen_assumed_shape_copy", NULL); 08854 08855 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 08856 attr_idx = OPND_IDX((*top_opnd)); 08857 line = OPND_LINE_NUM((*top_opnd)); 08858 col = OPND_COL_NUM((*top_opnd)); 08859 08860 set_up_which_entry_tmp(); 08861 08862 /* gen a stmt to hold onto any stmts generated by create_tmp_asg */ 08863 08864 curr_stmt_sh_idx = ntr_sh_tbl(); 08865 SH_STMT_TYPE(curr_stmt_sh_idx) = Assignment_Stmt; 08866 SH_GLB_LINE(curr_stmt_sh_idx) = line; 08867 SH_COL_NUM(curr_stmt_sh_idx) = col; 08868 08869 place_holder_sh_idx = curr_stmt_sh_idx; 08870 08871 OPND_FLD(right_opnd) = AT_Tbl_Idx; 08872 OPND_IDX(right_opnd) = attr_idx; 08873 OPND_LINE_NUM(right_opnd) = line; 08874 OPND_COL_NUM(right_opnd) = col; 08875 08876 exp_desc = init_exp_desc; 08877 exp_desc.rank = 0; 08878 08879 save_xref_state = xref_state; 08880 xref_state = CIF_No_Usage_Rec; 08881 expr_semantics(&right_opnd, &exp_desc); 08882 xref_state = save_xref_state; 08883 08884 label_idx1 = gen_internal_lbl(line); 08885 label_idx2 = gen_internal_lbl(line); 08886 label_idx3 = gen_internal_lbl(line); 08887 08888 /* find the dope vector opnd */ 08889 08890 OPND_FLD(dv_opnd) = AT_Tbl_Idx; 08891 OPND_IDX(dv_opnd) = attr_idx; 08892 OPND_LINE_NUM(dv_opnd) = line; 08893 OPND_COL_NUM(dv_opnd) = col; 08894 08895 /* generate if (contig) for contig_test_ir_idx */ 08896 08897 NTR_IR_TBL(ir_idx); 08898 IR_OPR(ir_idx) = Dv_Access_A_Contig; 08899 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 08900 IR_LINE_NUM(ir_idx) = line; 08901 IR_COL_NUM(ir_idx) = col; 08902 08903 COPY_OPND(IR_OPND_L(ir_idx), dv_opnd); 08904 08905 NTR_IR_TBL(ne_idx); 08906 IR_OPR(ne_idx) = Ne_Opr; 08907 IR_TYPE_IDX(ne_idx) = LOGICAL_DEFAULT_TYPE; 08908 08909 IR_LINE_NUM(ne_idx) = line; 08910 IR_COL_NUM(ne_idx) = col; 08911 08912 IR_FLD_L(ne_idx) = IR_Tbl_Idx; 08913 IR_IDX_L(ne_idx) = ir_idx; 08914 08915 IR_FLD_R(ne_idx) = CN_Tbl_Idx; 08916 IR_IDX_R(ne_idx) = CN_INTEGER_ONE_IDX; 08917 IR_LINE_NUM_R(ne_idx) = line; 08918 IR_COL_NUM_R(ne_idx) = col; 08919 08920 br_true_idx = gen_ir(IR_Tbl_Idx, ne_idx, 08921 Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col, 08922 AT_Tbl_Idx, label_idx1); 08923 08924 gen_opnd(&opnd, ne_idx, IR_Tbl_Idx, line, col); 08925 copy_subtree(&opnd, &opnd); 08926 IR_OPR(OPND_IDX(opnd)) = Eq_Opr; 08927 08928 contig_test_ir_idx = OPND_IDX(opnd); 08929 08930 /* generate branch around label_idx3 After */ 08931 08932 NTR_IR_TBL(ir_idx); 08933 IR_OPR(ir_idx) = Label_Opr; 08934 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 08935 IR_LINE_NUM(ir_idx) = line; 08936 IR_COL_NUM(ir_idx) = col; 08937 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 08938 IR_IDX_L(ir_idx) = label_idx3; 08939 IR_COL_NUM_L(ir_idx) = col; 08940 IR_LINE_NUM_L(ir_idx) = line; 08941 08942 AT_DEFINED(label_idx3) = TRUE; 08943 08944 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 08945 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 08946 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 08947 08948 ATL_DEF_STMT_IDX(label_idx3) = curr_stmt_sh_idx; 08949 08950 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 08951 08952 /* do copy in Before */ 08953 08954 intent = Intent_Inout; 08955 08956 if (ATD_INTENT(attr_idx) == Intent_Out) { 08957 intent = Intent_Out; 08958 } 08959 else if (ATD_INTENT(attr_idx) == Intent_In) { 08960 intent = Intent_In; 08961 } 08962 08963 tmp_idx = create_tmp_asg(&right_opnd, 08964 &exp_desc, 08965 &left_opnd, 08966 intent, 08967 FALSE, 08968 FALSE); 08969 08970 addr_tmp_idx = ATD_AUTO_BASE_IDX(tmp_idx); 08971 08972 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 08973 08974 while (sh_idx) { 08975 08976 if (IR_OPR(SH_IR_IDX(sh_idx)) == Asg_Opr && 08977 IR_FLD_R(SH_IR_IDX(sh_idx)) == IR_Tbl_Idx && 08978 IR_OPR(IR_IDX_R(SH_IR_IDX(sh_idx))) == Alloc_Opr) { 08979 08980 break; 08981 } 08982 08983 sh_idx = SH_PREV_IDX(sh_idx); 08984 08985 # ifdef _DEBUG 08986 if (sh_idx == NULL_IDX) { 08987 PRINTMSG(line, 626, Internal, col, 08988 "Alloc_Opr", "gen_assumed_shape_copy"); 08989 } 08990 # endif 08991 } 08992 08993 curr_stmt_sh_idx = sh_idx; 08994 08995 /* generate if (contig) Before */ 08996 08997 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 08998 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 08999 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09000 09001 contig_test_ir_idx = NULL_IDX; 09002 09003 /* set address temp = address from dope vector */ 09004 /* Before */ 09005 09006 if (cmd_line_flags.runtime_conformance) { 09007 get_shape_from_attr(&l_exp_desc, 09008 tmp_idx, 09009 BD_RANK(ATD_ARRAY_IDX(tmp_idx)), 09010 line, 09011 col); 09012 l_exp_desc.rank = BD_RANK(ATD_ARRAY_IDX(tmp_idx)); 09013 09014 get_shape_from_attr(&r_exp_desc, 09015 attr_idx, 09016 BD_RANK(ATD_ARRAY_IDX(attr_idx)), 09017 line, 09018 col); 09019 r_exp_desc.rank = BD_RANK(ATD_ARRAY_IDX(attr_idx)); 09020 09021 OPND_FLD(opnd) = AT_Tbl_Idx; 09022 OPND_IDX(opnd) = tmp_idx; 09023 OPND_LINE_NUM(opnd) = line; 09024 OPND_COL_NUM(opnd) = col; 09025 09026 gen_runtime_conformance(&opnd, 09027 &l_exp_desc, 09028 &right_opnd, 09029 &r_exp_desc); 09030 09031 } 09032 09033 NTR_IR_TBL(addr_asg_idx); 09034 IR_OPR(addr_asg_idx) = Asg_Opr; 09035 IR_FLD_L(addr_asg_idx) = AT_Tbl_Idx; 09036 IR_IDX_L(addr_asg_idx) = addr_tmp_idx; 09037 IR_TYPE_IDX(addr_asg_idx) = ATD_TYPE_IDX(addr_tmp_idx); 09038 09039 IR_LINE_NUM(addr_asg_idx) = line; 09040 IR_COL_NUM(addr_asg_idx) = col; 09041 IR_LINE_NUM_L(addr_asg_idx) = line; 09042 IR_COL_NUM_L(addr_asg_idx) = col; 09043 09044 NTR_IR_TBL(ir_idx); 09045 IR_OPR(ir_idx) = Dv_Access_Base_Addr; 09046 IR_TYPE_IDX(ir_idx) = SA_INTEGER_DEFAULT_TYPE; 09047 IR_LINE_NUM(ir_idx) = line; 09048 IR_COL_NUM(ir_idx) = col; 09049 09050 COPY_OPND(IR_OPND_L(ir_idx), dv_opnd); 09051 09052 IR_FLD_R(addr_asg_idx) = IR_Tbl_Idx; 09053 IR_IDX_R(addr_asg_idx) = ir_idx; 09054 09055 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09056 09057 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = addr_asg_idx; 09058 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09059 09060 /* generate goto label_idx2 Before */ 09061 09062 NTR_IR_TBL(ir_idx); 09063 IR_OPR(ir_idx) = Br_Uncond_Opr; 09064 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 09065 IR_LINE_NUM(ir_idx) = line; 09066 IR_COL_NUM(ir_idx) = col; 09067 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 09068 IR_IDX_R(ir_idx) = label_idx2; 09069 IR_LINE_NUM_R(ir_idx) = line; 09070 IR_COL_NUM_R(ir_idx) = col; 09071 09072 gen_sh(Before, Goto_Stmt, line, col, FALSE, FALSE, TRUE); 09073 09074 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 09075 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09076 09077 /* insert label_idx1 */ 09078 09079 NTR_IR_TBL(ir_idx); 09080 IR_OPR(ir_idx) = Label_Opr; 09081 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 09082 IR_LINE_NUM(ir_idx) = line; 09083 IR_COL_NUM(ir_idx) = col; 09084 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 09085 IR_IDX_L(ir_idx) = label_idx1; 09086 IR_COL_NUM_L(ir_idx) = col; 09087 IR_LINE_NUM_L(ir_idx) = line; 09088 09089 AT_DEFINED(label_idx1) = TRUE; 09090 09091 gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 09092 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09093 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 09094 09095 ATL_DEF_STMT_IDX(label_idx1) = SH_PREV_IDX(curr_stmt_sh_idx); 09096 09097 curr_stmt_sh_idx = place_holder_sh_idx; 09098 09099 /* insert label_idx2 Before */ 09100 09101 NTR_IR_TBL(ir_idx); 09102 IR_OPR(ir_idx) = Label_Opr; 09103 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 09104 IR_LINE_NUM(ir_idx) = line; 09105 IR_COL_NUM(ir_idx) = col; 09106 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 09107 IR_IDX_L(ir_idx) = label_idx2; 09108 IR_COL_NUM_L(ir_idx) = col; 09109 IR_LINE_NUM_L(ir_idx) = line; 09110 09111 AT_DEFINED(label_idx2) = TRUE; 09112 09113 gen_sh(Before, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 09114 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09115 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 09116 09117 ATL_DEF_STMT_IDX(label_idx2) = SH_PREV_IDX(curr_stmt_sh_idx); 09118 09119 09120 09121 /* generate if (!contig) test After */ 09122 09123 NTR_IR_TBL(ir_idx); 09124 IR_OPR(ir_idx) = Dv_Access_A_Contig; 09125 IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE; 09126 IR_LINE_NUM(ir_idx) = line; 09127 IR_COL_NUM(ir_idx) = col; 09128 09129 COPY_OPND(IR_OPND_L(ir_idx), dv_opnd); 09130 09131 NTR_IR_TBL(ne_idx); 09132 IR_OPR(ne_idx) = Eq_Opr; 09133 IR_TYPE_IDX(ne_idx) = LOGICAL_DEFAULT_TYPE; 09134 09135 IR_LINE_NUM(ne_idx) = line; 09136 IR_COL_NUM(ne_idx) = col; 09137 09138 IR_FLD_L(ne_idx) = IR_Tbl_Idx; 09139 IR_IDX_L(ne_idx) = ir_idx; 09140 09141 IR_FLD_R(ne_idx) = CN_Tbl_Idx; 09142 IR_IDX_R(ne_idx) = CN_INTEGER_ONE_IDX; 09143 IR_LINE_NUM_R(ne_idx) = line; 09144 IR_COL_NUM_R(ne_idx) = col; 09145 09146 NTR_IR_TBL(ir_idx); 09147 IR_OPR(ir_idx) = Br_True_Opr; 09148 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 09149 IR_LINE_NUM(ir_idx) = line; 09150 IR_COL_NUM(ir_idx) = col; 09151 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 09152 IR_IDX_R(ir_idx) = label_idx3; 09153 IR_LINE_NUM_R(ir_idx) = line; 09154 IR_COL_NUM_R(ir_idx) = col; 09155 09156 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 09157 IR_IDX_L(ir_idx) = ne_idx; 09158 09159 gen_sh(After, If_Stmt, line, col, FALSE, FALSE, TRUE); 09160 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 09161 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 09162 09163 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09164 09165 ATD_SF_ARG_IDX(attr_idx) = tmp_idx; 09166 ATD_COPY_ASSUMED_SHAPE(attr_idx) = TRUE; 09167 09168 ATD_TMP_IDX(tmp_idx) = attr_idx; 09169 ATD_FLD(tmp_idx) = AT_Tbl_Idx; 09170 09171 ATD_COPY_ASSUMED_SHAPE(tmp_idx) = TRUE; 09172 09173 /* find beginning sh idx */ 09174 09175 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09176 09177 while(SH_PREV_IDX(sh_idx)) { 09178 sh_idx = SH_PREV_IDX(sh_idx); 09179 } 09180 09181 /* check OPTIONAL darg's presence */ 09182 09183 if (AT_OPTIONAL(attr_idx)) { 09184 gen_present_ir(attr_idx, sh_idx, SH_PREV_IDX(curr_stmt_sh_idx)); 09185 09186 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09187 09188 while(SH_PREV_IDX(sh_idx)) { 09189 sh_idx = SH_PREV_IDX(sh_idx); 09190 } 09191 } 09192 09193 if (shared_bd_idx < 0) { 09194 shared_bd_idx = ATD_ARRAY_IDX(tmp_idx); 09195 09196 if (reassign_XT_temps) { 09197 /* preset XT temp to -1 */ 09198 save_sh = curr_stmt_sh_idx; 09199 curr_stmt_sh_idx = sh_idx; 09200 09201 cn_idx = CN_INTEGER_NEG_ONE_IDX; 09202 09203 for (i = 1; i <= BD_RANK(shared_bd_idx); i++) { 09204 NTR_IR_TBL(asg_idx); 09205 IR_OPR(asg_idx) = Asg_Opr; 09206 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(BD_XT_IDX(shared_bd_idx,i)); 09207 IR_LINE_NUM(asg_idx) = line; 09208 IR_COL_NUM(asg_idx) = col; 09209 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 09210 IR_IDX_L(asg_idx) = BD_XT_IDX(shared_bd_idx,i); 09211 IR_LINE_NUM_L(asg_idx) = line; 09212 IR_COL_NUM_L(asg_idx) = col; 09213 IR_FLD_R(asg_idx) = CN_Tbl_Idx; 09214 IR_IDX_R(asg_idx) = cn_idx; 09215 IR_LINE_NUM_R(asg_idx) = line; 09216 IR_COL_NUM_R(asg_idx) = col; 09217 09218 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 09219 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 09220 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 09221 } 09222 09223 curr_stmt_sh_idx = save_sh; 09224 09225 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 09226 09227 while(SH_PREV_IDX(sh_idx)) { 09228 sh_idx = SH_PREV_IDX(sh_idx); 09229 } 09230 } 09231 } 09232 09233 if (gen_ir_at_this_entry(SCP_ATTR_IDX(curr_scp_idx), attr_idx)) { 09234 SH_PREV_IDX(sh_idx) = SH_PREV_IDX(save_curr_stmt_sh_idx); 09235 SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = sh_idx; 09236 SH_PREV_IDX(save_curr_stmt_sh_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 09237 SH_NEXT_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = save_curr_stmt_sh_idx; 09238 } 09239 09240 09241 entry_list_idx = SCP_ENTRY_IDX(curr_scp_idx); 09242 09243 while (entry_list_idx != NULL_IDX) { 09244 entry_attr_idx = AL_ATTR_IDX(entry_list_idx); 09245 09246 if (gen_ir_at_this_entry(entry_attr_idx, attr_idx)) { 09247 copy_entry_exit_sh_list(sh_idx, SH_PREV_IDX(curr_stmt_sh_idx), 09248 &new_start_idx, &new_end_idx); 09249 09250 /* insert the stmt string before ATP_ENTRY_LABEL_SH_IDX */ 09251 09252 SH_PREV_IDX(new_start_idx) = 09253 SH_PREV_IDX(ATP_ENTRY_LABEL_SH_IDX(entry_attr_idx)); 09254 SH_NEXT_IDX(SH_PREV_IDX(new_start_idx)) = new_start_idx; 09255 SH_NEXT_IDX(new_end_idx) = ATP_ENTRY_LABEL_SH_IDX(entry_attr_idx); 09256 SH_PREV_IDX(ATP_ENTRY_LABEL_SH_IDX(entry_attr_idx)) = new_end_idx; 09257 09258 } 09259 09260 entry_list_idx = AL_NEXT_IDX(entry_list_idx); 09261 } 09262 09263 /* find end sh idx */ 09264 09265 sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 09266 09267 while(SH_NEXT_IDX(sh_idx)) { 09268 sh_idx = SH_NEXT_IDX(sh_idx); 09269 } 09270 09271 /* check OPTIONAL darg's presence */ 09272 09273 if (AT_OPTIONAL(attr_idx)) { 09274 gen_present_ir(attr_idx, SH_NEXT_IDX(curr_stmt_sh_idx), sh_idx); 09275 09276 sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 09277 09278 while(SH_NEXT_IDX(sh_idx)) { 09279 sh_idx = SH_NEXT_IDX(sh_idx); 09280 } 09281 } 09282 09283 if (SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX) { 09284 gen_branch_around_ir(gen_darg_branch_test(attr_idx), 09285 SH_NEXT_IDX(curr_stmt_sh_idx), sh_idx); 09286 09287 sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 09288 09289 while(SH_NEXT_IDX(sh_idx)) { 09290 sh_idx = SH_NEXT_IDX(sh_idx); 09291 } 09292 } 09293 09294 if (sh_idx) { 09295 if (SCP_EXIT_IR_SH_IDX(curr_scp_idx) != NULL_IDX) { 09296 SH_NEXT_IDX(sh_idx) = SCP_EXIT_IR_SH_IDX(curr_scp_idx); 09297 SCP_EXIT_IR_SH_IDX(curr_scp_idx) = SH_NEXT_IDX(curr_stmt_sh_idx); 09298 } 09299 else { 09300 SCP_EXIT_IR_SH_IDX(curr_scp_idx) = SH_NEXT_IDX(curr_stmt_sh_idx); 09301 } 09302 } 09303 09304 FREE_SH_NODE(curr_stmt_sh_idx); 09305 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 09306 09307 TRACE (Func_Exit, "gen_assumed_shape_copy", NULL); 09308 09309 return; 09310 09311 } /* gen_assumed_shape_copy */ 09312 09313 /******************************************************************************\ 09314 |* *| 09315 |* Description: *| 09316 |* <description> *| 09317 |* *| 09318 |* Input parameters: *| 09319 |* NONE *| 09320 |* *| 09321 |* Output parameters: *| 09322 |* NONE *| 09323 |* *| 09324 |* Returns: *| 09325 |* NOTHING *| 09326 |* *| 09327 \******************************************************************************/ 09328 09329 static int gen_darg_branch_test(int attr_idx) 09330 09331 { 09332 int al_idx; 09333 int col; 09334 int entry_al_idx; 09335 int i; 09336 int ir_idx; 09337 int line; 09338 opnd_type opnd; 09339 int or_idx; 09340 int pgm_idx; 09341 long_type the_constant; 09342 09343 TRACE (Func_Entry, "gen_darg_branch_test", NULL); 09344 09345 the_constant = 1; 09346 pgm_idx = SCP_ATTR_IDX(curr_scp_idx); 09347 line = AT_DEF_LINE(pgm_idx); 09348 col = AT_DEF_COLUMN(pgm_idx); 09349 09350 gen_opnd(&opnd, NULL_IDX, NO_Tbl_Idx, line, col); 09351 09352 al_idx = ATD_NO_ENTRY_LIST(attr_idx); 09353 09354 while (al_idx) { 09355 09356 if (pgm_idx == AL_ATTR_IDX(al_idx)) { 09357 /* branch around on this */ 09358 09359 NTR_IR_TBL(ir_idx); 09360 IR_OPR(ir_idx) = Eq_Opr; 09361 IR_TYPE_IDX(ir_idx) = CG_LOGICAL_DEFAULT_TYPE; 09362 IR_LINE_NUM(ir_idx) = line; 09363 IR_COL_NUM(ir_idx) = col; 09364 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 09365 IR_IDX_L(ir_idx) = SCP_WHICH_ENTRY_TMP(curr_scp_idx); 09366 IR_LINE_NUM_L(ir_idx) = line; 09367 IR_COL_NUM_L(ir_idx) = col; 09368 09369 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 09370 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 09371 the_constant); 09372 IR_LINE_NUM_R(ir_idx) = line; 09373 IR_COL_NUM_R(ir_idx) = col; 09374 09375 if (OPND_FLD(opnd) == NO_Tbl_Idx) { 09376 OPND_FLD(opnd) = IR_Tbl_Idx; 09377 OPND_IDX(opnd) = ir_idx; 09378 } 09379 else { 09380 NTR_IR_TBL(or_idx); 09381 IR_OPR(or_idx) = Or_Opr; 09382 IR_TYPE_IDX(or_idx) = CG_LOGICAL_DEFAULT_TYPE; 09383 IR_LINE_NUM(or_idx) = line; 09384 IR_COL_NUM(or_idx) = col; 09385 09386 IR_FLD_R(or_idx) = IR_Tbl_Idx; 09387 IR_IDX_R(or_idx) = ir_idx; 09388 09389 COPY_OPND(IR_OPND_L(or_idx), opnd); 09390 OPND_FLD(opnd) = IR_Tbl_Idx; 09391 OPND_IDX(opnd) = or_idx; 09392 } 09393 09394 break; 09395 } 09396 al_idx = AL_NEXT_IDX(al_idx); 09397 } 09398 09399 entry_al_idx = SCP_ENTRY_IDX(curr_scp_idx); 09400 09401 for (i = 0; i < SCP_ALT_ENTRY_CNT(curr_scp_idx); i++) { 09402 the_constant++; 09403 pgm_idx = AL_ATTR_IDX(entry_al_idx); 09404 09405 al_idx = ATD_NO_ENTRY_LIST(attr_idx); 09406 09407 while (al_idx) { 09408 if (pgm_idx == AL_ATTR_IDX(al_idx)) { 09409 /* branch around on this */ 09410 NTR_IR_TBL(ir_idx); 09411 IR_OPR(ir_idx) = Eq_Opr; 09412 IR_TYPE_IDX(ir_idx) = CG_LOGICAL_DEFAULT_TYPE; 09413 IR_LINE_NUM(ir_idx) = line; 09414 IR_COL_NUM(ir_idx) = col; 09415 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 09416 IR_IDX_L(ir_idx) = SCP_WHICH_ENTRY_TMP(curr_scp_idx); 09417 IR_LINE_NUM_L(ir_idx) = line; 09418 IR_COL_NUM_L(ir_idx) = col; 09419 09420 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 09421 IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 09422 the_constant); 09423 IR_LINE_NUM_R(ir_idx) = line; 09424 IR_COL_NUM_R(ir_idx) = col; 09425 09426 if (OPND_FLD(opnd) == NO_Tbl_Idx) { 09427 OPND_FLD(opnd) = IR_Tbl_Idx; 09428 OPND_IDX(opnd) = ir_idx; 09429 } 09430 else { 09431 NTR_IR_TBL(or_idx); 09432 IR_OPR(or_idx) = Or_Opr; 09433 IR_TYPE_IDX(or_idx) = CG_LOGICAL_DEFAULT_TYPE; 09434 IR_LINE_NUM(or_idx) = line; 09435 IR_COL_NUM(or_idx) = col; 09436 09437 IR_FLD_R(or_idx) = IR_Tbl_Idx; 09438 IR_IDX_R(or_idx) = ir_idx; 09439 09440 COPY_OPND(IR_OPND_L(or_idx), opnd); 09441 OPND_FLD(opnd) = IR_Tbl_Idx; 09442 OPND_IDX(opnd) = or_idx; 09443 } 09444 09445 break; 09446 } 09447 al_idx = AL_NEXT_IDX(al_idx); 09448 } 09449 09450 entry_al_idx = AL_NEXT_IDX(entry_al_idx); 09451 } 09452 09453 09454 TRACE (Func_Exit, "gen_darg_branch_test", NULL); 09455 09456 return(OPND_IDX(opnd)); 09457 09458 } /* gen_darg_branch_test */ 09459 09460 /******************************************************************************\ 09461 |* *| 09462 |* Description: *| 09463 |* This generates if condition code for a branch around test *| 09464 |* *| 09465 |* Input parameters: *| 09466 |* condition_idx- Index to an IR_Tbl_Idx for the branch around condition *| 09467 |* start_sh_idx - Index to start of IR to have an if present put around *| 09468 |* end_sh_idx - Index to end of IR to have an if present put around *| 09469 |* This gets updated to point to the new last sh idx. *| 09470 |* *| 09471 |* Output parameters: *| 09472 |* NONE *| 09473 |* *| 09474 |* Returns: *| 09475 |* NONE *| 09476 |* *| 09477 \******************************************************************************/ 09478 static void gen_branch_around_ir(int condition_idx, 09479 int start_sh_idx, 09480 int end_sh_idx) 09481 { 09482 int br_around_opt; 09483 int br_idx; 09484 int col; 09485 int cont_idx; 09486 int line; 09487 int save_sh_idx; 09488 09489 09490 TRACE (Func_Entry, "gen_branch_around_ir", NULL); 09491 09492 save_sh_idx = curr_stmt_sh_idx; 09493 curr_stmt_sh_idx = start_sh_idx; 09494 line = SH_GLB_LINE(start_sh_idx); 09495 col = SH_COL_NUM(start_sh_idx); 09496 09497 gen_sh(Before, 09498 Goto_Stmt, 09499 line, 09500 col, 09501 FALSE, 09502 FALSE, 09503 TRUE); 09504 09505 SH_P2_SKIP_ME(SH_PREV_IDX(start_sh_idx)) = TRUE; 09506 09507 br_around_opt = gen_internal_lbl(line); 09508 09509 NTR_IR_TBL(br_idx); 09510 09511 IR_OPR(br_idx) = Br_True_Opr; 09512 IR_TYPE_IDX(br_idx) = LOGICAL_DEFAULT_TYPE; 09513 09514 SH_IR_IDX(SH_PREV_IDX(start_sh_idx)) = br_idx; 09515 IR_LINE_NUM(br_idx) = line; 09516 IR_COL_NUM(br_idx) = col; 09517 09518 IR_FLD_R(br_idx) = AT_Tbl_Idx; 09519 IR_IDX_R(br_idx) = br_around_opt; 09520 IR_COL_NUM_R(br_idx) = col; 09521 IR_LINE_NUM_R(br_idx) = line; 09522 09523 IR_FLD_L(br_idx) = IR_Tbl_Idx; 09524 IR_IDX_L(br_idx) = condition_idx; 09525 09526 NTR_IR_TBL(cont_idx); 09527 IR_OPR(cont_idx) = Label_Opr; 09528 IR_TYPE_IDX(cont_idx) = TYPELESS_DEFAULT_TYPE; 09529 IR_LINE_NUM(cont_idx) = line; 09530 IR_COL_NUM(cont_idx) = col; 09531 IR_IDX_L(cont_idx) = br_around_opt; 09532 IR_FLD_L(cont_idx) = AT_Tbl_Idx; 09533 IR_LINE_NUM_L(cont_idx) = line; 09534 IR_COL_NUM_L(cont_idx) = col; 09535 curr_stmt_sh_idx = end_sh_idx; 09536 09537 gen_sh(After, 09538 Continue_Stmt, 09539 line, 09540 col, 09541 FALSE, 09542 TRUE, 09543 TRUE); 09544 09545 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 09546 SH_IR_IDX(curr_stmt_sh_idx) = cont_idx; 09547 curr_stmt_sh_idx = save_sh_idx; 09548 09549 TRACE (Func_Exit, "gen_branch_around_ir", NULL); 09550 09551 return; 09552 09553 } /* gen_branch_around_ir */ 09554 09555 /******************************************************************************\ 09556 |* *| 09557 |* Description: *| 09558 |* Go through a list of assumed shape attrs for COPY_ASSUMED_SHAPE to *| 09559 |* look for optional args. If a nonoptional arg exists, put in first *| 09560 |* and return false (no need to reassign extent temps). If all are *| 09561 |* optional, return true (the shared extent temp must have assignment *| 09562 |* statements generated for each darg). *| 09563 |* *| 09564 |* Input parameters: *| 09565 |* NONE *| 09566 |* *| 09567 |* Output parameters: *| 09568 |* NONE *| 09569 |* *| 09570 |* Returns: *| 09571 |* NOTHING *| 09572 |* *| 09573 \******************************************************************************/ 09574 09575 static boolean must_reassign_XT_temp(opnd_type *top_opnd) 09576 09577 { 09578 boolean all_optional = TRUE; 09579 int list_idx; 09580 09581 TRACE (Func_Entry, "must_reassign_XT_temp", NULL); 09582 09583 list_idx = OPND_IDX((*top_opnd)); 09584 09585 if (! AT_OPTIONAL(IL_IDX(list_idx))) { 09586 all_optional = FALSE; 09587 } 09588 else { 09589 while (list_idx) { 09590 if (! AT_OPTIONAL(IL_IDX(list_idx))) { 09591 all_optional = FALSE; 09592 break; 09593 } 09594 09595 list_idx = IL_NEXT_LIST_IDX(list_idx); 09596 } 09597 09598 if (! all_optional) { 09599 /* move the non optional attr to the front */ 09600 09601 if (IL_PREV_LIST_IDX(list_idx) != NULL_IDX) { 09602 IL_NEXT_LIST_IDX(IL_PREV_LIST_IDX(list_idx)) = 09603 IL_NEXT_LIST_IDX(list_idx); 09604 } 09605 09606 if (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 09607 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = 09608 IL_PREV_LIST_IDX(list_idx); 09609 } 09610 09611 IL_NEXT_LIST_IDX(list_idx) = OPND_IDX((*top_opnd)); 09612 if (OPND_IDX((*top_opnd)) != NULL_IDX) { 09613 IL_PREV_LIST_IDX(OPND_IDX((*top_opnd))) = list_idx; 09614 } 09615 09616 OPND_IDX((*top_opnd)) = list_idx; 09617 09618 } 09619 } 09620 09621 TRACE (Func_Exit, "must_reassign_XT_temp", NULL); 09622 09623 return(all_optional); 09624 09625 } /* must_reassign_XT_temp */ 09626 09627 /******************************************************************************\ 09628 |* *| 09629 |* Description: *| 09630 |* *| 09631 |* Input parameters: *| 09632 |* NONE *| 09633 |* *| 09634 |* Output parameters: *| 09635 |* NONE *| 09636 |* *| 09637 |* Returns: *| 09638 |* NOTHING *| 09639 |* *| 09640 \******************************************************************************/ 09641 static int gen_auto_length(int attr_idx, 09642 opnd_type *len_opnd) 09643 09644 { 09645 int bd_idx; 09646 int column; 09647 expr_arg_type expr_desc; 09648 int len_idx; 09649 int line; 09650 09651 opnd_type opnd1; 09652 opnd_type opnd2; 09653 int result_type_idx; 09654 int type_idx; 09655 int type1_idx; 09656 int type2_idx; 09657 09658 # if !defined(_TARGET_WORD_ADDRESS) 09659 int mult_idx; 09660 long word_byte_size; 09661 # endif 09662 09663 09664 TRACE (Func_Entry, "gen_auto_length", NULL); 09665 09666 bd_idx = ATD_ARRAY_IDX(attr_idx); 09667 type_idx = ATD_TYPE_IDX(attr_idx); 09668 line = AT_DEF_LINE(attr_idx); 09669 column = AT_DEF_COLUMN(attr_idx); 09670 09671 if (TYP_TYPE(type_idx) == Character || 09672 (TYP_TYPE(type_idx) == Structure && ATT_CHAR_SEQ(TYP_IDX(type_idx)) ) ) { 09673 09674 /* The allocation is in bytes for SGI and solaris. */ 09675 /* The allocation is in words for Crays. */ 09676 /* The allocation is in words for _TARGET_OS_MAX, but */ 09677 /* we calculate the allocation length in bytes because */ 09678 /* TARGET_OS_MAX is for a byte addressable machine and */ 09679 /* all tmps that address into the allocated area must */ 09680 /* be in bytes. This way we use already existing code */ 09681 /* and the only thing we have to do special is divide */ 09682 /* by TARGET_BYTES_PER_WORD to get the allocation */ 09683 /* length in words. */ 09684 09685 /* this assumes that chars are one byte BHJ */ 09686 09687 /* Get character length */ 09688 09689 OPND_LINE_NUM((*len_opnd))= line; 09690 OPND_COL_NUM((*len_opnd)) = column; 09691 09692 if (TYP_TYPE(type_idx) == Structure) { 09693 OPND_FLD(opnd1) = BD_LEN_FLD(bd_idx); 09694 OPND_IDX(opnd1) = BD_LEN_IDX(bd_idx); 09695 OPND_LINE_NUM(opnd1) = line; 09696 OPND_COL_NUM(opnd1) = column; 09697 09698 type1_idx = check_type_for_size_address(&opnd1); 09699 09700 OPND_FLD(opnd2) = BD_SM_FLD(bd_idx,1); 09701 OPND_IDX(opnd2) = BD_SM_IDX(bd_idx,1); 09702 OPND_LINE_NUM(opnd2) = line; 09703 OPND_COL_NUM(opnd2) = column; 09704 09705 type2_idx = check_type_for_size_address(&opnd2); 09706 09707 result_type_idx = TYP_LINEAR(type1_idx) > TYP_LINEAR(type2_idx)? 09708 type1_idx : type2_idx; 09709 09710 /* If this is a character sequence structure, we know the size */ 09711 /* of the structure. Assume this must be an array. The stride */ 09712 /* multiplier of the array is set to number of bytes for char */ 09713 /* sequence structures. */ 09714 09715 NTR_IR_TBL(len_idx); 09716 IR_OPR(len_idx) = Mult_Opr; 09717 IR_TYPE_IDX(len_idx) = result_type_idx; 09718 IR_LINE_NUM(len_idx) = line; 09719 IR_COL_NUM(len_idx) = column; 09720 COPY_OPND(IR_OPND_L(len_idx), opnd2); 09721 COPY_OPND(IR_OPND_R(len_idx), opnd1); 09722 09723 OPND_FLD((*len_opnd)) = IR_Tbl_Idx; 09724 OPND_IDX((*len_opnd)) = len_idx; 09725 } 09726 else if (bd_idx == NULL_IDX) { 09727 OPND_FLD((*len_opnd)) = AT_Tbl_Idx; 09728 OPND_IDX((*len_opnd)) = TYP_IDX(type_idx); 09729 result_type_idx = check_type_for_size_address(&(*len_opnd)); 09730 } 09731 else { /* If array - multiply num of chars by num of elements. */ 09732 OPND_FLD(opnd1) = BD_LEN_FLD(bd_idx); 09733 OPND_IDX(opnd1) = BD_LEN_IDX(bd_idx); 09734 OPND_LINE_NUM(opnd1) = line; 09735 OPND_COL_NUM(opnd1) = column; 09736 09737 type1_idx = check_type_for_size_address(&opnd1); 09738 09739 OPND_FLD(opnd2) = TYP_FLD(type_idx); 09740 OPND_IDX(opnd2) = TYP_IDX(type_idx); 09741 OPND_LINE_NUM(opnd2) = line; 09742 OPND_COL_NUM(opnd2) = column; 09743 09744 type2_idx = check_type_for_size_address(&opnd2); 09745 09746 result_type_idx = TYP_LINEAR(type1_idx) > TYP_LINEAR(type2_idx)? 09747 type1_idx : type2_idx; 09748 NTR_IR_TBL(len_idx); 09749 IR_OPR(len_idx) = Mult_Opr; 09750 IR_TYPE_IDX(len_idx) = result_type_idx; 09751 IR_LINE_NUM(len_idx) = line; 09752 IR_COL_NUM(len_idx) = column; 09753 09754 COPY_OPND(IR_OPND_L(len_idx), opnd2); 09755 COPY_OPND(IR_OPND_R(len_idx), opnd1); 09756 09757 OPND_FLD((*len_opnd)) = IR_Tbl_Idx; 09758 OPND_IDX((*len_opnd)) = len_idx; 09759 } 09760 09761 # ifdef _TARGET_WORD_ADDRESS 09762 09763 /* Alloc is in words, but all character lengths are in number of */ 09764 /* chars. Change byte length to word length. DO NOT do this for */ 09765 /* byte addressable machines, because addressing needs to be in bytes. */ 09766 /* If heap allocation must be in words, it will be switched to words */ 09767 /* right before the allocation IR is added to the ir stream. */ 09768 09769 gen_word_align_byte_length_ir(len_opnd); 09770 09771 # endif 09772 09773 } 09774 else { /* Non-Character */ 09775 OPND_FLD(opnd1) = BD_LEN_FLD(bd_idx); 09776 OPND_IDX(opnd1) = BD_LEN_IDX(bd_idx); 09777 OPND_LINE_NUM(opnd1) = line; 09778 OPND_COL_NUM(opnd1) = column; 09779 09780 type1_idx = check_type_for_size_address(&opnd1); 09781 09782 OPND_FLD(opnd2) = BD_SM_FLD(bd_idx,1); 09783 OPND_IDX(opnd2) = BD_SM_IDX(bd_idx,1); 09784 OPND_LINE_NUM(opnd2) = line; 09785 OPND_COL_NUM(opnd2) = column; 09786 09787 type2_idx = check_type_for_size_address(&opnd2); 09788 09789 result_type_idx = TYP_LINEAR(type1_idx) > TYP_LINEAR(type2_idx)? 09790 type1_idx : type2_idx; 09791 09792 /* If this is a character sequence structure, we know the size */ 09793 09794 NTR_IR_TBL(len_idx); 09795 IR_OPR(len_idx) = Mult_Opr; 09796 IR_TYPE_IDX(len_idx) = result_type_idx; 09797 IR_LINE_NUM(len_idx) = line; 09798 IR_COL_NUM(len_idx) = column; 09799 09800 COPY_OPND(IR_OPND_L(len_idx), opnd2); 09801 COPY_OPND(IR_OPND_R(len_idx), opnd1); 09802 09803 # ifdef _TARGET_WORD_ADDRESS 09804 09805 /* addressing is words */ 09806 09807 OPND_FLD((*len_opnd)) = IR_Tbl_Idx; 09808 OPND_IDX((*len_opnd)) = len_idx; 09809 # else 09810 09811 /* addressing is bytes */ 09812 09813 NTR_IR_TBL(mult_idx); 09814 IR_OPR(mult_idx) = Mult_Opr; 09815 IR_TYPE_IDX(mult_idx) = result_type_idx; 09816 IR_LINE_NUM(mult_idx) = line; 09817 IR_COL_NUM(mult_idx) = column; 09818 IR_LINE_NUM_L(mult_idx) = line; 09819 IR_COL_NUM_L(mult_idx) = column; 09820 09821 IR_FLD_L(mult_idx) = CN_Tbl_Idx; 09822 09823 #if defined(_TARGET_PACK_HALF_WORD_TYPES) 09824 09825 /* Check if this is a packed storage type. If */ 09826 /* so, it only needs one half word for storage. */ 09827 09828 if (TARGET_MAX_HALF_WORD_STORAGE_TYPE(type_idx)) { 09829 word_byte_size = TARGET_BYTES_PER_WORD / 2; 09830 } 09831 else { 09832 word_byte_size = TARGET_BYTES_PER_WORD; 09833 } 09834 # else 09835 word_byte_size = TARGET_BYTES_PER_WORD; 09836 # endif 09837 09838 IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 09839 word_byte_size); 09840 09841 IR_LINE_NUM_R(mult_idx) = line; 09842 IR_COL_NUM_R(mult_idx) = column; 09843 IR_FLD_R(mult_idx) = IR_Tbl_Idx; 09844 IR_IDX_R(mult_idx) = len_idx; 09845 09846 OPND_FLD((*len_opnd)) = IR_Tbl_Idx; 09847 OPND_IDX((*len_opnd)) = mult_idx; 09848 09849 # endif 09850 09851 } 09852 09853 expr_desc.rank = 0; 09854 xref_state = CIF_No_Usage_Rec; 09855 09856 if (!expr_semantics(&(*len_opnd), &expr_desc)) { 09857 09858 # if defined(_CHECK_MAX_MEMORY) 09859 09860 if (!target_t3e) { 09861 AT_DCL_ERR(attr_idx) = TRUE; 09862 } 09863 # endif 09864 } 09865 09866 TRACE (Func_Exit, "gen_auto_length", NULL); 09867 09868 return(result_type_idx); 09869 09870 } /* gen_auto_length */ 09871 09872 /******************************************************************************\ 09873 |* *| 09874 |* Description: *| 09875 |* This routine generates the allocatation IR for automatic arrays ands *| 09876 |* character. It is called from char_len_resolution for scalar chars, *| 09877 |* and from array_dim_resolution for ALL automatic objects. This is *| 09878 |* where arrays of automatic characters get handled. The IR is inserted *| 09879 |* using curr_stmt_sh_idx. This routine generates an allocate for each *| 09880 |* automatic within the program unit. *| 09881 |* *| 09882 |* NOTE: The type of the base is CRI_Ptr for the single allocate case. *| 09883 |* *| 09884 |* Input parameters: *| 09885 |* attr_idx - The attr idx for the automatic object. *| 09886 |* *| 09887 |* Output parameters: *| 09888 |* NONE *| 09889 |* *| 09890 |* Returns: *| 09891 |* NOTHING *| 09892 |* *| 09893 \******************************************************************************/ 09894 static void gen_single_automatic_allocate(int attr_idx) 09895 { 09896 int alloc_idx; 09897 int base_ir_idx; 09898 int base_tmp_idx; 09899 int base_tmp_type_idx; 09900 int column; 09901 int dealloc_idx; 09902 int line; 09903 opnd_type opnd; 09904 int save_next_sh_idx; 09905 int sh_idx; 09906 int start_sh_idx; 09907 09908 # if defined(_HEAP_REQUEST_IN_WORDS) && defined(_TARGET_BYTE_ADDRESS) 09909 expr_arg_type expr_desc; 09910 # endif 09911 09912 09913 TRACE (Func_Entry, "gen_single_automatic_allocate", NULL); 09914 09915 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 09916 start_sh_idx = curr_stmt_sh_idx; 09917 09918 base_tmp_type_idx = gen_auto_length(attr_idx, &opnd); 09919 09920 /* Do not need allocate or deallocate for an automatic pointee. */ 09921 09922 if (ATD_CLASS(attr_idx) == CRI__Pointee) { 09923 goto EXIT; 09924 } 09925 09926 line = AT_DEF_LINE(attr_idx); 09927 column = AT_DEF_COLUMN(attr_idx); 09928 09929 # if defined(GENERATE_WHIRL) 09930 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character || 09931 (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 09932 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx))))) { 09933 base_tmp_type_idx = CRI_Ch_Ptr_8; 09934 } 09935 else { 09936 base_tmp_type_idx = CRI_Ptr_8; 09937 } 09938 # endif 09939 09940 NTR_IR_TBL(alloc_idx); 09941 IR_TYPE_IDX(alloc_idx) = TYPELESS_DEFAULT_TYPE; 09942 IR_LINE_NUM(alloc_idx) = line; 09943 IR_COL_NUM(alloc_idx) = column; 09944 COPY_OPND(IR_OPND_L(alloc_idx), opnd); 09945 09946 NTR_IR_TBL(dealloc_idx); 09947 IR_TYPE_IDX(dealloc_idx) = TYPELESS_DEFAULT_TYPE; 09948 IR_LINE_NUM(dealloc_idx) = line; 09949 IR_COL_NUM(dealloc_idx) = column; 09950 09951 if (ATD_AUXILIARY(attr_idx)) { 09952 IR_OPR(alloc_idx) = SSD_Alloc_Opr; 09953 IR_OPR(dealloc_idx) = SSD_Dealloc_Opr; 09954 } 09955 else if (ATD_SYMMETRIC(attr_idx)) { 09956 IR_OPR(alloc_idx) = Symmetric_Alloc_Opr; 09957 IR_OPR(dealloc_idx) = Symmetric_Dealloc_Opr; 09958 } 09959 else { 09960 IR_OPR(alloc_idx) = Alloc_Opr; 09961 IR_OPR(dealloc_idx) = Dealloc_Opr; 09962 } 09963 09964 GEN_COMPILER_TMP_ASG(base_ir_idx, 09965 base_tmp_idx, 09966 TRUE, /* Semantics is done */ 09967 stmt_start_line, 09968 stmt_start_col, 09969 base_tmp_type_idx, 09970 Priv); 09971 09972 AT_SEMANTICS_DONE(base_tmp_idx) = TRUE; 09973 09974 ATD_STOR_BLK_IDX(base_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 09975 ATD_AUTO_BASE_IDX(attr_idx) = base_tmp_idx; 09976 09977 IR_FLD_R(base_ir_idx) = IR_Tbl_Idx; 09978 IR_IDX_R(base_ir_idx) = alloc_idx; 09979 IR_LINE_NUM_R(base_ir_idx) = line; 09980 IR_COL_NUM_R(base_ir_idx) = column; 09981 09982 /* If the address is in bytes, but the allocation is in words, generate */ 09983 /* additional code on the allocation to change the byte length to a */ 09984 /* word length. */ 09985 09986 /* NOTE: We do not handle the case of HEAP_REQUEST_IN_BYTES and TARGET_ */ 09987 /* _WORD_ADDRESS. Code will have to be added, if that case comes up. */ 09988 09989 # if defined(_HEAP_REQUEST_IN_WORDS) && defined(_TARGET_BYTE_ADDRESS) 09990 09991 COPY_OPND(opnd, IR_OPND_L(alloc_idx)); 09992 gen_word_align_byte_length_ir(&opnd); 09993 09994 expr_desc.rank = 0; 09995 xref_state = CIF_No_Usage_Rec; 09996 09997 expr_semantics(&opnd, &expr_desc); 09998 09999 COPY_OPND(IR_OPND_L(alloc_idx), opnd); 10000 # endif 10001 10002 sh_idx = curr_stmt_sh_idx; 10003 10004 gen_sh(After, 10005 Automatic_Base_Calc_Stmt, 10006 AT_DEF_LINE(base_tmp_idx), 10007 AT_DEF_COLUMN(base_tmp_idx), 10008 FALSE, 10009 FALSE, 10010 TRUE); /* Compiler generated */ 10011 10012 SH_IR_IDX(curr_stmt_sh_idx) = base_ir_idx; 10013 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10014 10015 if (SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX) { /* Add at alternate entries */ 10016 10017 if (save_next_sh_idx != NULL_IDX) { 10018 sh_idx = SH_PREV_IDX(save_next_sh_idx); 10019 } 10020 else { 10021 10022 sh_idx = curr_stmt_sh_idx; 10023 10024 while (SH_NEXT_IDX(sh_idx) != NULL_IDX) { 10025 sh_idx = SH_NEXT_IDX(sh_idx); 10026 } 10027 } 10028 10029 insert_sh_after_entries(attr_idx, 10030 start_sh_idx, 10031 sh_idx, 10032 FALSE, /* Don't generate tmp = 0 */ 10033 TRUE); /* Advance ATP_FIRST_SH_IDX */ 10034 } 10035 10036 /* Generate the dealloc */ 10037 10038 IR_FLD_L(dealloc_idx) = AT_Tbl_Idx; 10039 IR_IDX_L(dealloc_idx) = base_tmp_idx; 10040 IR_LINE_NUM_L(dealloc_idx) = line; 10041 IR_COL_NUM_L(dealloc_idx) = column; 10042 10043 sh_idx = ntr_sh_tbl(); 10044 SH_COMPILER_GEN(sh_idx) = TRUE; 10045 SH_P2_SKIP_ME(sh_idx) = TRUE; 10046 SH_GLB_LINE(sh_idx) = stmt_start_line; 10047 SH_COL_NUM(sh_idx) = stmt_start_col; 10048 SH_IR_IDX(sh_idx) = dealloc_idx; 10049 10050 if (SCP_EXIT_IR_SH_IDX(curr_scp_idx) != NULL_IDX) { 10051 SH_NEXT_IDX(sh_idx) = SCP_EXIT_IR_SH_IDX(curr_scp_idx); 10052 SH_PREV_IDX(SCP_EXIT_IR_SH_IDX(curr_scp_idx)) = sh_idx; 10053 } 10054 10055 SCP_EXIT_IR_SH_IDX(curr_scp_idx) = sh_idx; 10056 10057 EXIT: 10058 10059 TRACE (Func_Exit, "gen_single_automatic_allocate", NULL); 10060 10061 return; 10062 10063 } /* gen_single_automatic_allocate */ 10064 10065 /******************************************************************************\ 10066 |* *| 10067 |* Description: *| 10068 |* This routine generates the allocatation IR for automatic arrays ands *| 10069 |* character. It is called from char_len_resolution for scalar chars, *| 10070 |* and from array_dim_resolution for ALL automatic objects. This is *| 10071 |* where arrays of automatic characters get handled. The IR is inserted *| 10072 |* using curr_stmt_sh_idx. This routine generates one allocate for all *| 10073 |* automatics within the program unit. *| 10074 |* *| 10075 |* NOTE: The type of the base is Integer for the multiple allocate case.*| 10076 |* *| 10077 |* Input parameters: *| 10078 |* attr_idx - The attr idx for the automatic object. *| 10079 |* *| 10080 |* Output parameters: *| 10081 |* NONE *| 10082 |* *| 10083 |* Returns: *| 10084 |* NOTHING *| 10085 |* *| 10086 \******************************************************************************/ 10087 # if !defined(_SINGLE_ALLOCS_FOR_AUTOMATIC) 10088 static void gen_multiple_automatic_allocate(int attr_idx) 10089 { 10090 10091 boolean adjust = FALSE; 10092 int al_idx; 10093 int alloc_idx; 10094 static int auto_aux_base_ir_idx = NULL_IDX; 10095 static int auto_aux_base_len_idx = NULL_IDX; 10096 static int auto_aux_base_tmp_idx = NULL_IDX; 10097 static boolean auto_aux_base_word_align= FALSE; 10098 static int auto_base_ir_idx = NULL_IDX; 10099 static int auto_base_len_idx = NULL_IDX; 10100 static int auto_base_list_end = NULL_IDX; 10101 static int auto_base_list_start = NULL_IDX; 10102 static int auto_base_tmp_idx = NULL_IDX; 10103 static boolean auto_base_word_align = FALSE; 10104 static int auto_sym_base_ir_idx = NULL_IDX; 10105 static int auto_sym_base_len_idx = NULL_IDX; 10106 static int auto_sym_base_tmp_idx = NULL_IDX; 10107 static boolean auto_sym_base_word_align= FALSE; 10108 int base_ir_idx; 10109 fld_type base_len_fld; 10110 int base_len_idx; 10111 int base_tmp_idx; 10112 boolean base_word_align; 10113 int column; 10114 int div_idx; 10115 # if defined(_HEAP_REQUEST_IN_WORDS) && defined(_TARGET_BYTE_ADDRESS) 10116 expr_arg_type expr_desc; 10117 # endif 10118 int ir_idx; 10119 int len_ir_idx; 10120 int line; 10121 int mult_idx; 10122 int new_len_idx; 10123 int new_base_attr_idx; 10124 int new_base_ir_idx; 10125 opnd_type opnd; 10126 operator_type opr; 10127 int plus_idx; 10128 int result_type_idx; 10129 int save_next_sh_idx; 10130 int sh_idx; 10131 int start_sh_idx; 10132 int type_idx; 10133 int tmp_ir_idx; 10134 long word_byte_size = TARGET_BYTES_PER_WORD; 10135 int word_byte_size_idx; 10136 10137 10138 TRACE (Func_Entry, "gen_multiple_automatic_allocate", NULL); 10139 10140 if (attr_idx == NULL_IDX) { 10141 goto FINISH; 10142 } 10143 10144 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 10145 start_sh_idx = curr_stmt_sh_idx; 10146 line = AT_DEF_LINE(attr_idx); 10147 column = AT_DEF_COLUMN(attr_idx); 10148 type_idx = ATD_TYPE_IDX(attr_idx); 10149 10150 result_type_idx = gen_auto_length(attr_idx, &opnd); 10151 10152 /* Do not need allocate or deallocate for an automatic pointee. */ 10153 10154 if (ATD_CLASS(attr_idx) == CRI__Pointee) { 10155 goto EXIT; 10156 } 10157 10158 if (ATD_AUXILIARY(attr_idx)) { 10159 base_tmp_idx = auto_aux_base_tmp_idx; 10160 base_len_idx = auto_aux_base_len_idx; 10161 base_ir_idx = auto_aux_base_ir_idx; 10162 base_word_align = auto_aux_base_word_align; 10163 opr = SSD_Alloc_Opr; 10164 } 10165 else if (ATD_SYMMETRIC(attr_idx)) { 10166 base_tmp_idx = auto_sym_base_tmp_idx; 10167 base_len_idx = auto_sym_base_len_idx; 10168 base_ir_idx = auto_sym_base_ir_idx; 10169 base_word_align = auto_sym_base_word_align; 10170 opr = Symmetric_Alloc_Opr; 10171 } 10172 else { 10173 base_tmp_idx = auto_base_tmp_idx; 10174 base_len_idx = auto_base_len_idx; 10175 base_ir_idx = auto_base_ir_idx; 10176 base_word_align = auto_base_word_align; 10177 opr = Alloc_Opr; 10178 } 10179 10180 /* There are two global variables and one static variable to control */ 10181 /* the automatic implementation. */ 10182 /* auto_base_tmp_idx -> This is the allocation tmp. */ 10183 /* auto_base_len_idx -> This is the accumulated length tmp. */ 10184 /* This increases for each new automatic var. */ 10185 /* base_ir_idx -> This is the ir index to the allocation length*/ 10186 /* for auto_base_tmp_idx. It gets updated each */ 10187 /* time there is a new length. */ 10188 10189 if (base_tmp_idx == NULL_IDX) { 10190 10191 /* First automatic or auxiliary variable. There are three lists. */ 10192 /* Plain, AUXILIARY and SYMMETRIC automatics. */ 10193 10194 base_len_fld = CN_Tbl_Idx; 10195 base_len_idx = CN_INTEGER_ZERO_IDX; 10196 10197 GEN_COMPILER_TMP_ASG(base_ir_idx, 10198 base_tmp_idx, 10199 TRUE, /* Semantics is done */ 10200 stmt_start_line, 10201 stmt_start_col, 10202 CG_INTEGER_DEFAULT_TYPE, 10203 Priv); 10204 10205 AT_SEMANTICS_DONE(base_tmp_idx) = TRUE; 10206 ATD_STOR_BLK_IDX(base_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 10207 10208 NTR_IR_TBL(alloc_idx); 10209 IR_OPR(alloc_idx) = opr; 10210 IR_TYPE_IDX(alloc_idx) = TYPELESS_DEFAULT_TYPE; 10211 IR_LINE_NUM(alloc_idx) = line; 10212 IR_COL_NUM(alloc_idx) = column; 10213 IR_LINE_NUM_L(alloc_idx) = line; 10214 IR_COL_NUM_L(alloc_idx) = column; 10215 IR_LINE_NUM_R(alloc_idx) = line; 10216 IR_COL_NUM_R(alloc_idx) = column; 10217 10218 /* IR_IDX_L(alloc_idx) gets filled in with length, each time the */ 10219 /* length changes, so at the end, it has the correct length. */ 10220 /* This opr has no IR_FLD_R or IR_IDX_R. */ 10221 10222 IR_FLD_R(base_ir_idx) = IR_Tbl_Idx; 10223 IR_IDX_R(base_ir_idx) = alloc_idx; 10224 IR_LINE_NUM_R(base_ir_idx)= line; 10225 IR_COL_NUM_R(base_ir_idx) = column; 10226 base_ir_idx = alloc_idx; 10227 10228 NTR_ATTR_LIST_TBL(al_idx); 10229 AL_ATTR_IDX(al_idx) = base_tmp_idx; 10230 10231 if (auto_base_list_start == NULL_IDX) { 10232 auto_base_list_start = al_idx; 10233 auto_base_list_end = al_idx; 10234 } 10235 else { 10236 AL_NEXT_IDX(auto_base_list_end) = al_idx; 10237 auto_base_list_end = al_idx; 10238 } 10239 10240 /* Generate the dealloc */ 10241 10242 NTR_IR_TBL(ir_idx); 10243 10244 if (ATD_AUXILIARY(attr_idx)) { 10245 IR_OPR(ir_idx) = SSD_Dealloc_Opr; 10246 } 10247 else if (ATD_SYMMETRIC(attr_idx)) { 10248 IR_OPR(ir_idx) = Symmetric_Dealloc_Opr; 10249 } 10250 else { 10251 IR_OPR(ir_idx) = Dealloc_Opr; 10252 } 10253 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 10254 IR_LINE_NUM(ir_idx) = line; 10255 IR_COL_NUM(ir_idx) = column; 10256 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 10257 IR_IDX_L(ir_idx) = base_tmp_idx; 10258 IR_LINE_NUM_L(ir_idx) = line; 10259 IR_COL_NUM_L(ir_idx) = column; 10260 sh_idx = ntr_sh_tbl(); 10261 SH_COMPILER_GEN(sh_idx) = TRUE; 10262 SH_P2_SKIP_ME(sh_idx) = TRUE; 10263 SH_GLB_LINE(sh_idx) = stmt_start_line; 10264 SH_COL_NUM(sh_idx) = stmt_start_col; 10265 SH_IR_IDX(sh_idx) = ir_idx; 10266 10267 if (SCP_EXIT_IR_SH_IDX(curr_scp_idx) != NULL_IDX) { 10268 SH_NEXT_IDX(sh_idx) = SCP_EXIT_IR_SH_IDX(curr_scp_idx); 10269 SH_PREV_IDX(SCP_EXIT_IR_SH_IDX(curr_scp_idx)) = sh_idx; 10270 } 10271 10272 SCP_EXIT_IR_SH_IDX(curr_scp_idx) = sh_idx; 10273 10274 /* Set base_word_align for next call to this routine. */ 10275 10276 # if defined(_TARGET_BYTE_ADDRESS) 10277 10278 if (TYP_TYPE(type_idx) == Character || 10279 (TYP_TYPE(type_idx) == Structure && 10280 ATT_CHAR_SEQ(TYP_IDX(type_idx)) ) ) { 10281 base_word_align = FALSE; 10282 } 10283 else { 10284 10285 # if defined(_TARGET_OS_MAX) 10286 base_word_align = !(PACK_HALF_WORD_TEST_CONDITION(type_idx)); 10287 # else 10288 base_word_align = TRUE; 10289 # endif 10290 } 10291 # endif 10292 } 10293 else { 10294 base_len_fld = AT_Tbl_Idx; 10295 adjust = FALSE; 10296 10297 # if defined(_TARGET_BYTE_ADDRESS) 10298 10299 /* If this type is numeric, it needs to be aligned on a word boundary. */ 10300 /* This check if it is necessary to generate code to do this. */ 10301 10302 if (TYP_TYPE(type_idx) == Character || 10303 (TYP_TYPE(type_idx) == Structure && 10304 ATT_CHAR_SEQ(TYP_IDX(type_idx)) ) ) { 10305 10306 /* Intentionally blank */ 10307 10308 base_word_align = FALSE; 10309 } 10310 else { 10311 10312 if (!base_word_align) { 10313 adjust = TRUE; 10314 } 10315 10316 # if defined(_TARGET_OS_MAX) 10317 10318 /* We do double word packing on MPP. This word needs to */ 10319 /* be either aligned on a word boundary or a half word */ 10320 /* boundary, so make sure it is by checking the type. */ 10321 10322 if (PACK_HALF_WORD_TEST_CONDITION(type_idx)) { 10323 word_byte_size = TARGET_BYTES_PER_WORD / 2; 10324 base_word_align = FALSE; 10325 } 10326 else { 10327 word_byte_size = TARGET_BYTES_PER_WORD; 10328 base_word_align = TRUE; 10329 } 10330 # else 10331 word_byte_size = TARGET_BYTES_PER_WORD; 10332 base_word_align = TRUE; 10333 # endif 10334 10335 } 10336 10337 # endif 10338 10339 # if defined(_TARGET_DOUBLE_ALIGN) 10340 10341 /* Check if this next item needs to be double aligned. If it does */ 10342 /* make sure that the accumulated length is a double word boundary. */ 10343 10344 if (DALIGN_TEST_CONDITION(type_idx)) { 10345 word_byte_size = (2 * TARGET_BYTES_PER_WORD); 10346 adjust = TRUE; 10347 base_word_align = TRUE; 10348 } 10349 # endif 10350 10351 if (adjust) { 10352 NTR_IR_TBL(ir_idx); 10353 IR_OPR(ir_idx) = Plus_Opr; 10354 IR_TYPE_IDX(ir_idx) = result_type_idx; 10355 IR_LINE_NUM(ir_idx) = line; 10356 IR_COL_NUM(ir_idx) = column; 10357 IR_LINE_NUM_L(ir_idx) = line; 10358 IR_COL_NUM_L(ir_idx) = column; 10359 IR_LINE_NUM_R(ir_idx) = line; 10360 IR_COL_NUM_R(ir_idx) = column; 10361 IR_FLD_L(ir_idx) = CN_Tbl_Idx; 10362 IR_IDX_L(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 10363 (word_byte_size - 1)); 10364 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 10365 IR_IDX_R(ir_idx) = base_len_idx; 10366 10367 NTR_IR_TBL(div_idx); 10368 IR_OPR(div_idx) = Div_Opr; 10369 IR_TYPE_IDX(div_idx) = result_type_idx; 10370 IR_LINE_NUM(div_idx) = line; 10371 IR_COL_NUM(div_idx) = column; 10372 IR_LINE_NUM_L(div_idx) = line; 10373 IR_COL_NUM_L(div_idx) = column; 10374 IR_LINE_NUM_R(div_idx) = line; 10375 IR_COL_NUM_R(div_idx) = column; 10376 IR_FLD_R(div_idx) = CN_Tbl_Idx; 10377 word_byte_size_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 10378 word_byte_size); 10379 IR_IDX_R(div_idx) = word_byte_size_idx; 10380 IR_FLD_L(div_idx) = IR_Tbl_Idx; 10381 IR_IDX_L(div_idx) = ir_idx; 10382 10383 NTR_IR_TBL(mult_idx); 10384 IR_OPR(mult_idx) = Mult_Opr; 10385 IR_TYPE_IDX(mult_idx) = result_type_idx; 10386 IR_LINE_NUM(mult_idx) = line; 10387 IR_COL_NUM(mult_idx) = column; 10388 IR_LINE_NUM_L(mult_idx)= line; 10389 IR_COL_NUM_L(mult_idx) = column; 10390 IR_LINE_NUM_R(mult_idx)= line; 10391 IR_COL_NUM_R(mult_idx) = column; 10392 IR_FLD_R(mult_idx) = CN_Tbl_Idx; 10393 IR_IDX_R(mult_idx) = word_byte_size_idx; 10394 IR_FLD_L(mult_idx) = IR_Tbl_Idx; 10395 IR_IDX_L(mult_idx) = div_idx; 10396 10397 GEN_COMPILER_TMP_ASG(tmp_ir_idx, 10398 base_len_idx, 10399 TRUE, /* Semantics is done */ 10400 stmt_start_line, 10401 stmt_start_col, 10402 result_type_idx, 10403 Priv); 10404 10405 IR_FLD_R(tmp_ir_idx) = IR_Tbl_Idx; 10406 IR_IDX_R(tmp_ir_idx) = mult_idx; 10407 10408 gen_sh(After, 10409 Automatic_Base_Size_Stmt, 10410 line, 10411 column, 10412 FALSE, 10413 FALSE, 10414 TRUE); /* Compiler generated */ 10415 10416 base_len_fld = AT_Tbl_Idx; 10417 SH_IR_IDX(curr_stmt_sh_idx) = tmp_ir_idx; 10418 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10419 } 10420 } 10421 10422 /* Generate a base for this automatic. It is equal to the base_tmp_idx */ 10423 /* plus the accumulated length (base_len_idx). This tmp goes on the */ 10424 /* automatic tmp list, because it cannot be added to the IR until all */ 10425 /* the lengths for all the automatics have been generated. */ 10426 10427 GEN_COMPILER_TMP_ASG(new_base_ir_idx, 10428 new_base_attr_idx, 10429 TRUE, /* Semantics is done */ 10430 line, 10431 column, 10432 result_type_idx, 10433 Priv); 10434 10435 NTR_IR_TBL(plus_idx); 10436 10437 IR_IDX_R(new_base_ir_idx) = plus_idx; 10438 IR_FLD_R(new_base_ir_idx) = IR_Tbl_Idx; 10439 IR_LINE_NUM_R(new_base_ir_idx) = line; 10440 IR_COL_NUM_R(new_base_ir_idx) = column; 10441 ATD_AUTO_BASE_IDX(attr_idx) = new_base_attr_idx; 10442 10443 IR_OPR(plus_idx) = Plus_Opr; 10444 IR_TYPE_IDX(plus_idx) = result_type_idx; 10445 IR_IDX_L(plus_idx) = base_tmp_idx; /* Alloc base */ 10446 IR_FLD_L(plus_idx) = AT_Tbl_Idx; 10447 IR_IDX_R(plus_idx) = base_len_idx; /* Old accumulated len */ 10448 IR_FLD_R(plus_idx) = base_len_fld; 10449 IR_LINE_NUM(plus_idx) = line; 10450 IR_COL_NUM(plus_idx) = column; 10451 IR_LINE_NUM_L(plus_idx) = line; 10452 IR_COL_NUM_L(plus_idx) = column; 10453 IR_LINE_NUM_R(plus_idx) = line; 10454 IR_COL_NUM_R(plus_idx) = column; 10455 10456 NTR_ATTR_LIST_TBL(al_idx); 10457 AL_ATTR_IDX(al_idx) = new_base_attr_idx; 10458 AL_NEXT_IDX(auto_base_list_end) = al_idx; 10459 auto_base_list_end = al_idx; 10460 10461 /* Generate tmp = auto_base_len_idx (tmp holding old accumulated len) + */ 10462 /* len of this variable. This new tmp then becomes base_len_idx. */ 10463 10464 NTR_IR_TBL(new_len_idx); 10465 IR_OPR(new_len_idx) = Plus_Opr; 10466 IR_TYPE_IDX(new_len_idx) = result_type_idx; 10467 IR_IDX_L(new_len_idx) = base_len_idx; /* Old accumulated len */ 10468 IR_FLD_L(new_len_idx) = base_len_fld; 10469 IR_LINE_NUM(new_len_idx) = line; 10470 IR_COL_NUM(new_len_idx) = column; 10471 IR_LINE_NUM_L(new_len_idx) = line; 10472 IR_COL_NUM_L(new_len_idx) = column; 10473 IR_LINE_NUM_R(new_len_idx) = line; 10474 IR_COL_NUM_R(new_len_idx) = column; 10475 10476 /* The right side of new_len_idx gets the length accumulation */ 10477 /* for the variable. */ 10478 10479 COPY_OPND(IR_OPND_R(new_len_idx), opnd); 10480 10481 gen_sh(After, 10482 Automatic_Base_Size_Stmt, 10483 line, 10484 column, 10485 FALSE, 10486 FALSE, 10487 TRUE); /* Compiler generated */ 10488 10489 GEN_COMPILER_TMP_ASG(len_ir_idx, 10490 base_len_idx, /* New accumulated length */ 10491 TRUE, /* Semantics is done */ 10492 line, 10493 column, 10494 result_type_idx, 10495 Priv); 10496 10497 base_len_fld = AT_Tbl_Idx; 10498 SH_IR_IDX(curr_stmt_sh_idx) = len_ir_idx; 10499 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 10500 IR_FLD_R(len_ir_idx) = IR_Tbl_Idx; 10501 IR_IDX_R(len_ir_idx) = new_len_idx; 10502 IR_LINE_NUM_R(len_ir_idx) = line; 10503 IR_COL_NUM_R(len_ir_idx) = column; 10504 10505 /* Change the length being allocated to the new accumulated length. */ 10506 10507 IR_IDX_L(base_ir_idx) = base_len_idx; 10508 IR_FLD_L(base_ir_idx) = base_len_fld; 10509 10510 if (SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX) { 10511 10512 if (save_next_sh_idx != NULL_IDX) { 10513 sh_idx = SH_PREV_IDX(save_next_sh_idx); 10514 } 10515 else { 10516 10517 sh_idx = curr_stmt_sh_idx; 10518 10519 while (SH_NEXT_IDX(sh_idx) != NULL_IDX) { 10520 sh_idx = SH_NEXT_IDX(sh_idx); 10521 } 10522 } 10523 10524 insert_sh_after_entries(attr_idx, 10525 start_sh_idx, 10526 sh_idx, 10527 FALSE, /* Don't generate tmp = 0 */ 10528 TRUE); /* Advance ATP_FIRST_SH_IDX */ 10529 } 10530 10531 if (ATD_AUXILIARY(attr_idx)) { 10532 auto_aux_base_tmp_idx = base_tmp_idx; 10533 auto_aux_base_len_idx = base_len_idx; 10534 auto_aux_base_ir_idx = base_ir_idx; 10535 auto_aux_base_word_align = base_word_align; 10536 } 10537 else if (ATD_SYMMETRIC(attr_idx)) { 10538 auto_sym_base_tmp_idx = base_tmp_idx; 10539 auto_sym_base_len_idx = base_len_idx; 10540 auto_sym_base_ir_idx = base_ir_idx; 10541 auto_sym_base_word_align = base_word_align; 10542 } 10543 else { 10544 auto_base_tmp_idx = base_tmp_idx; 10545 auto_base_len_idx = base_len_idx; 10546 auto_base_ir_idx = base_ir_idx; 10547 auto_base_word_align = base_word_align; 10548 } 10549 10550 FINISH: 10551 10552 if (attr_idx == NULL_IDX) { 10553 10554 /* Automatics are done for this scope. Generate the rest of bounds ir */ 10555 /* and clear static variables for the next scope. */ 10556 10557 /* If the address is in bytes, but the allocation is in words, */ 10558 /* generate additional code on the allocation to change the byte */ 10559 /* length to a word length. */ 10560 10561 /* NOTE: We do not handle the case of HEAP_REQUEST_IN_BYTES and */ 10562 /* TARGET_WORD_ADDRESS. Code will have to be added, if that case */ 10563 /* comes up. */ 10564 10565 # if defined(_HEAP_REQUEST_IN_WORDS) && defined(_TARGET_BYTE_ADDRESS) 10566 10567 if (auto_base_ir_idx != NULL_IDX) { 10568 COPY_OPND(opnd, IR_OPND_L(auto_base_ir_idx)); 10569 gen_word_align_byte_length_ir(&opnd); 10570 10571 expr_desc.rank = 0; 10572 xref_state = CIF_No_Usage_Rec; 10573 10574 expr_semantics(&opnd, &expr_desc); 10575 10576 COPY_OPND(IR_OPND_L(auto_base_ir_idx), opnd); 10577 } 10578 10579 if (auto_aux_base_ir_idx != NULL_IDX) { 10580 COPY_OPND(opnd, IR_OPND_L(auto_aux_base_ir_idx)); 10581 gen_word_align_byte_length_ir(&opnd); 10582 10583 expr_desc.rank = 0; 10584 xref_state = CIF_No_Usage_Rec; 10585 10586 expr_semantics(&opnd, &expr_desc); 10587 10588 COPY_OPND(IR_OPND_L(auto_aux_base_ir_idx), opnd); 10589 } 10590 10591 if (auto_sym_base_ir_idx != NULL_IDX) { 10592 COPY_OPND(opnd, IR_OPND_L(auto_sym_base_ir_idx)); 10593 gen_word_align_byte_length_ir(&opnd); 10594 10595 expr_desc.rank = 0; 10596 xref_state = CIF_No_Usage_Rec; 10597 10598 expr_semantics(&opnd, &expr_desc); 10599 10600 COPY_OPND(IR_OPND_L(auto_sym_base_ir_idx), opnd); 10601 } 10602 10603 # endif 10604 10605 al_idx = auto_base_list_start; 10606 sh_idx = curr_stmt_sh_idx; 10607 10608 while (al_idx != NULL_IDX) { 10609 gen_sh(After, 10610 Automatic_Base_Calc_Stmt, 10611 AT_DEF_LINE(AL_ATTR_IDX(al_idx)), 10612 AT_DEF_COLUMN(AL_ATTR_IDX(al_idx)), 10613 FALSE, 10614 FALSE, 10615 TRUE); /* Compiler generated */ 10616 10617 SH_IR_IDX(curr_stmt_sh_idx) = ATD_TMP_IDX(AL_ATTR_IDX(al_idx)); 10618 SH_P2_SKIP_ME(curr_stmt_sh_idx)= TRUE; 10619 al_idx = AL_NEXT_IDX(al_idx); 10620 } 10621 10622 if (auto_base_list_start != NULL_IDX && 10623 SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX) { 10624 insert_sh_after_entries(auto_base_tmp_idx, 10625 sh_idx, 10626 curr_stmt_sh_idx, 10627 FALSE, /* Don't generate tmp = 0 */ 10628 TRUE); /* Advance ATP_FIRST_SH_IDX */ 10629 } 10630 10631 auto_base_ir_idx = NULL_IDX; 10632 auto_base_len_idx = NULL_IDX; 10633 auto_base_list_end = NULL_IDX; 10634 auto_base_list_start = NULL_IDX; 10635 auto_base_tmp_idx = NULL_IDX; 10636 auto_base_word_align = TRUE; 10637 auto_aux_base_ir_idx = NULL_IDX; 10638 auto_aux_base_len_idx = NULL_IDX; 10639 auto_aux_base_tmp_idx = NULL_IDX; 10640 auto_aux_base_word_align = TRUE; 10641 auto_sym_base_ir_idx = NULL_IDX; 10642 auto_sym_base_len_idx = NULL_IDX; 10643 auto_sym_base_tmp_idx = NULL_IDX; 10644 auto_sym_base_word_align = TRUE; 10645 } 10646 10647 EXIT: 10648 10649 TRACE (Func_Exit, "gen_multiple_automatic_allocate", NULL); 10650 10651 return; 10652 10653 } /* gen_multiple_automatic_allocate */ 10654 # endif 10655 10656 /******************************************************************************\ 10657 |* *| 10658 |* Description: *| 10659 |* This routine resolves the lower and upper bounds to a constant or a *| 10660 |* temp. Calculate the extent and stride multiplier for each dimension. *| 10661 |* *| 10662 |* Input parameters: *| 10663 |* attr_idx -> Index to attribute for array. *| 10664 |* *| 10665 |* Output parameters: *| 10666 |* NONE *| 10667 |* *| 10668 |* Returns: *| 10669 |* NONE *| 10670 |* *| 10671 \******************************************************************************/ 10672 static void distribution_resolution(int attr_idx) 10673 { 10674 int bd_idx; 10675 int dim; 10676 expr_arg_type expr_desc; 10677 opnd_type opnd; 10678 10679 10680 TRACE (Func_Entry, "distribution_resolution", NULL); 10681 10682 bd_idx = ATD_DISTRIBUTION_IDX(attr_idx); 10683 10684 if (!BD_RESOLVED(bd_idx)) { 10685 10686 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 10687 10688 if (BD_CYCLIC_FLD(bd_idx, dim) != NO_Tbl_Idx) { 10689 OPND_FLD(opnd) = BD_CYCLIC_FLD(bd_idx, dim); 10690 OPND_IDX(opnd) = BD_CYCLIC_IDX(bd_idx, dim); 10691 OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx); 10692 OPND_COL_NUM(opnd) = BD_COLUMN_NUM(bd_idx); 10693 10694 expr_desc.rank = 0; 10695 xref_state = CIF_No_Usage_Rec; 10696 10697 expr_semantics(&opnd, &expr_desc); 10698 10699 BD_CYCLIC_FLD(bd_idx, dim) = OPND_FLD(opnd); 10700 BD_CYCLIC_IDX(bd_idx, dim) = OPND_IDX(opnd); 10701 } 10702 10703 if (BD_ONTO_FLD(bd_idx, dim) != NO_Tbl_Idx) { 10704 OPND_FLD(opnd) = BD_ONTO_FLD(bd_idx, dim); 10705 OPND_IDX(opnd) = BD_ONTO_IDX(bd_idx, dim); 10706 OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx); 10707 OPND_COL_NUM(opnd) = BD_COLUMN_NUM(bd_idx); 10708 10709 expr_desc.rank = 0; 10710 xref_state = CIF_No_Usage_Rec; 10711 10712 expr_semantics(&opnd, &expr_desc); 10713 10714 BD_ONTO_FLD(bd_idx, dim) = OPND_FLD(opnd); 10715 BD_ONTO_IDX(bd_idx, dim) = OPND_IDX(opnd); 10716 } 10717 } 10718 } 10719 10720 /* KAY - Semantic checks here */ 10721 10722 TRACE (Func_Exit, "distribution_resolution", NULL); 10723 10724 return; 10725 10726 } /* distribution_resolution */ 10727 10728 /******************************************************************************\ 10729 |* *| 10730 |* Description: *| 10731 |* Verify the specific interfaces in a generic interface. *| 10732 |* Check for ambiguity and other rules for generic interfaces and *| 10733 |* overloaded operators and assignment. *| 10734 |* *| 10735 |* Input parameters: *| 10736 |* interface_idx - index to generic interface attr. *| 10737 |* *| 10738 |* Output parameters: *| 10739 |* NONE *| 10740 |* *| 10741 |* Returns: *| 10742 |* NOTHING *| 10743 |* *| 10744 \******************************************************************************/ 10745 static void verify_interface(int interface_idx) 10746 10747 { 10748 boolean ambiguous; 10749 int attr_idx; 10750 int correct_num; 10751 int curr_attr_idx; 10752 int curr_darg_idx; 10753 int curr_darg_sn_idx; 10754 int curr_num_dargs; 10755 int curr_sn_idx; 10756 int curr_type_idx; 10757 int darg_idx; 10758 int darg_sn_idx; 10759 boolean found_intrin = FALSE; 10760 int i; 10761 int idx; 10762 int ktr_sn_idx; 10763 int kwd_darg_idx; 10764 int kwd_sn_idx; 10765 int loop_cnt; 10766 int num_dargs; 10767 int optional_sn_idx; 10768 int rank_l; 10769 int rank_r; 10770 boolean same_dargs; 10771 int save_curr_darg_sn_idx; 10772 int save_curr_num_dargs; 10773 int save_darg_sn_idx; 10774 int save_num_dargs; 10775 int sn_idx; 10776 int type_idx_l; 10777 int type_idx_r; 10778 10779 10780 10781 TRACE (Func_Entry, "verify_interface", NULL); 10782 10783 if (AT_DCL_ERR(interface_idx)) { 10784 goto EXIT; 10785 } 10786 10787 curr_sn_idx = ATI_FIRST_SPECIFIC_IDX(interface_idx); 10788 10789 while (curr_sn_idx != NULL_IDX) { 10790 curr_attr_idx = SN_ATTR_IDX(curr_sn_idx); 10791 10792 if (AT_IS_INTRIN(curr_attr_idx)) { 10793 found_intrin = TRUE; 10794 curr_type_idx = (ATP_PGM_UNIT(curr_attr_idx) != Function) ? NULL_IDX : 10795 ATD_TYPE_IDX(ATP_RSLT_IDX(curr_attr_idx)); 10796 10797 if (AT_DCL_ERR(curr_attr_idx)) { 10798 curr_sn_idx = SN_SIBLING_LINK(curr_sn_idx); 10799 continue; 10800 } 10801 } 10802 else { 10803 10804 if (found_intrin) { /* A non-intrinsic follows the intrinsics */ 10805 PRINTMSG(AT_DEF_LINE(curr_attr_idx), 1534, Internal, 10806 AT_DEF_COLUMN(curr_attr_idx), 10807 AT_OBJ_NAME_PTR(curr_attr_idx)); 10808 } 10809 10810 if (ATP_PROC(curr_attr_idx) == Module_Proc && 10811 ATP_PGM_UNIT(curr_attr_idx) == Pgm_Unknown) { 10812 10813 while (AT_ATTR_LINK(curr_attr_idx) != NULL_IDX) { 10814 curr_attr_idx = AT_ATTR_LINK(curr_attr_idx); 10815 } 10816 10817 if (AT_OBJ_CLASS(curr_attr_idx) == Interface) { 10818 curr_attr_idx = ATI_PROC_IDX(curr_attr_idx); 10819 } 10820 10821 if (curr_attr_idx == NULL_IDX) { 10822 10823 if (!AT_DCL_ERR(SN_ATTR_IDX(curr_sn_idx))) { 10824 10825 /* The module procedure must be defined or use associated */ 10826 10827 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 368, Error, 10828 SN_COLUMN_NUM(curr_sn_idx), 10829 AT_OBJ_NAME_PTR(SN_ATTR_IDX(curr_sn_idx))); 10830 } 10831 curr_attr_idx = SN_ATTR_IDX(curr_sn_idx); 10832 AT_DCL_ERR(curr_attr_idx) = TRUE; 10833 AT_DCL_ERR(interface_idx) = TRUE; 10834 break; 10835 } 10836 10837 if (AT_OBJ_CLASS(curr_attr_idx) != Pgm_Unit || 10838 ATP_PROC(curr_attr_idx) != Module_Proc || 10839 ATP_PGM_UNIT(curr_attr_idx) == Pgm_Unknown) { 10840 10841 /* MODULE PROCEDURE specified in INTERFACE, but the MODULE */ 10842 /* PROCEDURE was never accessed in the MODULE or from USE. */ 10843 10844 if (!AT_DCL_ERR(curr_attr_idx) && 10845 !AT_DCL_ERR(SN_ATTR_IDX(curr_sn_idx))) { 10846 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 368, Error, 10847 SN_COLUMN_NUM(curr_sn_idx), 10848 AT_OBJ_NAME_PTR(curr_attr_idx)); 10849 } 10850 curr_attr_idx = SN_ATTR_IDX(curr_sn_idx); 10851 AT_DCL_ERR(curr_attr_idx) = TRUE; 10852 AT_DCL_ERR(interface_idx) = TRUE; 10853 break; 10854 } 10855 10856 SN_ATTR_IDX(curr_sn_idx) = curr_attr_idx; 10857 SN_NAME_IDX(curr_sn_idx) = AT_NAME_IDX(curr_attr_idx); 10858 } 10859 10860 # if 0 10861 /* Save this until we allow generic interfaces to be specified */ 10862 /* with INLINE ALWAYS/NEVER. */ 10863 10864 if (!ATP_INLINE_ALWAYS(curr_attr_idx) && 10865 !ATP_INLINE_NEVER(curr_attr_idx)) { 10866 10867 /* Specific does not have INLINE ALWAYS or INLINE NEVER set, */ 10868 /* so copy the generic interface's INLINE attribute. */ 10869 10870 ATP_INLINE_ALWAYS(curr_attr_idx) = ATP_INLINE_ALWAYS(interface_idx); 10871 ATP_INLINE_NEVER(curr_attr_idx) = ATP_INLINE_NEVER(interface_idx); 10872 } 10873 # endif 10874 10875 attr_semantics(curr_attr_idx, FALSE); 10876 10877 curr_type_idx = (ATP_PGM_UNIT(curr_attr_idx) != Function) ? NULL_IDX : 10878 ATD_TYPE_IDX(ATP_RSLT_IDX(curr_attr_idx)); 10879 10880 if (AT_DCL_ERR(curr_attr_idx)) { 10881 curr_sn_idx = SN_SIBLING_LINK(curr_sn_idx); 10882 continue; 10883 } 10884 10885 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 10886 !AT_PRIVATE(interface_idx)) { 10887 10888 if (ATP_PGM_UNIT(curr_attr_idx) == Function && 10889 TYP_TYPE(curr_type_idx) == Structure && 10890 AT_PRIVATE(TYP_IDX(curr_type_idx)) && 10891 !AT_USE_ASSOCIATED(TYP_IDX(curr_type_idx))) { /* Interp 161 */ 10892 10893 /* Issue error if generic interface is PUBLIC, but one of its */ 10894 /* routines has a FUNCTION result that is a private type. */ 10895 10896 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 686, Error, 10897 SN_COLUMN_NUM(curr_sn_idx), 10898 AT_OBJ_NAME_PTR(interface_idx), 10899 AT_OBJ_NAME_PTR(curr_attr_idx)); 10900 AT_DCL_ERR(interface_idx) = TRUE; 10901 } 10902 10903 /* Check everything in the darg list to make sure there */ 10904 /* are no PRIVATE types used for the dummy arguments. */ 10905 /* Don't check intrinsic dargs. They are not typed. */ 10906 10907 for (i = (ATP_EXTRA_DARG(curr_attr_idx) ? 1 : 0); 10908 i < ATP_NUM_DARGS(curr_attr_idx); i++) { 10909 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(curr_attr_idx) + i); 10910 10911 /* Issue error if the Module procedure is PUBLIC, */ 10912 /* but one of its dummy arguments is a PRIVATE */ 10913 /* type, unless interp 161 applies. */ 10914 10915 if (AT_OBJ_CLASS(darg_idx) == Data_Obj && 10916 TYP_TYPE(ATD_TYPE_IDX(darg_idx)) == Structure && 10917 AT_PRIVATE(TYP_IDX(ATD_TYPE_IDX(darg_idx))) && 10918 !AT_USE_ASSOCIATED(TYP_IDX(ATD_TYPE_IDX(darg_idx)))) { 10919 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 687, Error, 10920 SN_COLUMN_NUM(curr_sn_idx), 10921 AT_OBJ_NAME_PTR(interface_idx), 10922 AT_OBJ_NAME_PTR(darg_idx), 10923 AT_OBJ_NAME_PTR(curr_attr_idx)); 10924 AT_DCL_ERR(interface_idx) = TRUE; 10925 } 10926 } 10927 } 10928 } 10929 10930 /* single attr checks here */ 10931 10932 switch (ATI_INTERFACE_CLASS(interface_idx)) { 10933 case Generic_Unknown_Interface: 10934 ATI_INTERFACE_CLASS(interface_idx) = 10935 (ATP_PGM_UNIT(curr_attr_idx) == Function) ? 10936 Generic_Function_Interface: 10937 Generic_Subroutine_Interface; 10938 break; 10939 10940 case Generic_Function_Interface : 10941 10942 if (ATP_PGM_UNIT(curr_attr_idx) == Subroutine && 10943 !AT_DCL_ERR(interface_idx)) { 10944 PRINTMSG(AT_DEF_LINE(interface_idx), 1059, Error, 10945 AT_DEF_COLUMN(interface_idx), 10946 AT_OBJ_NAME_PTR(interface_idx)); 10947 AT_DCL_ERR(interface_idx) = TRUE; 10948 } 10949 break; 10950 10951 case Generic_Subroutine_Interface : 10952 10953 if (ATP_PGM_UNIT(curr_attr_idx) == Function && 10954 !AT_DCL_ERR(interface_idx)) { 10955 PRINTMSG(AT_DEF_LINE(interface_idx), 1059, Error, 10956 AT_DEF_COLUMN(interface_idx), 10957 AT_OBJ_NAME_PTR(interface_idx)); 10958 AT_DCL_ERR(interface_idx) = TRUE; 10959 } 10960 break; 10961 10962 case Defined_Assign_Interface : 10963 10964 /* must be subroutine with two arguments */ 10965 10966 if (ATP_PGM_UNIT(curr_attr_idx) != Subroutine) { 10967 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 475, Error, 10968 SN_COLUMN_NUM(curr_sn_idx), 10969 AT_OBJ_NAME_PTR(curr_attr_idx)); 10970 AT_DCL_ERR(interface_idx) = TRUE; 10971 AT_DCL_ERR(curr_attr_idx) = TRUE; 10972 } 10973 10974 correct_num = (ATP_EXTRA_DARG(curr_attr_idx)) ? 3 : 2; 10975 10976 if (ATP_NUM_DARGS(curr_attr_idx) != correct_num) { 10977 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 489, Error, 10978 SN_COLUMN_NUM(curr_sn_idx), 10979 AT_OBJ_NAME_PTR(curr_attr_idx)); 10980 AT_DCL_ERR(interface_idx) = TRUE; 10981 AT_DCL_ERR(curr_attr_idx) = TRUE; 10982 } 10983 else { 10984 sn_idx = (ATP_EXTRA_DARG(curr_attr_idx)) ? 10985 (ATP_FIRST_IDX(curr_attr_idx) + 1) : 10986 ATP_FIRST_IDX(curr_attr_idx); 10987 attr_idx = SN_ATTR_IDX(sn_idx); 10988 10989 if (AT_OPTIONAL(attr_idx)) { 10990 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1071, Error, 10991 SN_COLUMN_NUM(curr_sn_idx), 10992 "ASSIGNMENT", 10993 AT_OBJ_NAME_PTR(interface_idx), /* Interface name */ 10994 AT_OBJ_NAME_PTR(curr_attr_idx), /* Procedure name */ 10995 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 10996 AT_DCL_ERR(interface_idx) = TRUE; 10997 } 10998 10999 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11000 type_idx_l = ATD_TYPE_IDX(attr_idx); 11001 rank_l = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) ? 11002 0 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11003 11004 /* first intent = OUT or INOUT */ 11005 11006 if (ATD_INTENT(attr_idx) == Intent_In || 11007 ATD_INTENT(attr_idx) == Intent_Unseen) { 11008 11009 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1074, Error, 11010 SN_COLUMN_NUM(curr_sn_idx), 11011 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11012 AT_OBJ_NAME_PTR(attr_idx), /* Dummy Arg name */ 11013 "INOUT"); 11014 AT_DCL_ERR(interface_idx) = TRUE; 11015 } 11016 } 11017 # ifdef _DEBUG 11018 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) { 11019 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 884, Internal, 11020 SN_COLUMN_NUM(attr_idx), 11021 AT_OBJ_NAME_PTR(attr_idx), 11022 AT_OBJ_NAME_PTR(curr_attr_idx)); 11023 } 11024 # endif 11025 else { 11026 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1073, Error, 11027 SN_COLUMN_NUM(curr_sn_idx), 11028 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11029 "ASSIGNMENT", 11030 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11031 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11032 AT_DCL_ERR(interface_idx) = TRUE; 11033 } 11034 11035 sn_idx++; 11036 attr_idx = SN_ATTR_IDX(sn_idx); 11037 11038 if (AT_OPTIONAL(attr_idx)) { 11039 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1071, Error, 11040 SN_COLUMN_NUM(curr_sn_idx), 11041 "ASSIGNMENT", 11042 AT_OBJ_NAME_PTR(interface_idx), /* Interface name */ 11043 AT_OBJ_NAME_PTR(curr_attr_idx), /* Procedure name */ 11044 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11045 AT_DCL_ERR(interface_idx) = TRUE; 11046 } 11047 11048 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11049 type_idx_r = ATD_TYPE_IDX(attr_idx); 11050 rank_r = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) ? 11051 0 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11052 11053 /* second intent = IN */ 11054 11055 if (ATD_INTENT(attr_idx) != Intent_In) { 11056 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1074, Error, 11057 SN_COLUMN_NUM(curr_sn_idx), 11058 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11059 AT_OBJ_NAME_PTR(attr_idx), /* Dummy Arg name */ 11060 "IN"); 11061 AT_DCL_ERR(interface_idx) = TRUE; 11062 } 11063 else if (operation_is_intrinsic((operator_type) 11064 ATI_DEFINED_OPR(interface_idx), 11065 type_idx_l, 11066 rank_l, 11067 type_idx_r, 11068 rank_r)) { 11069 11070 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 495, Error, 11071 SN_COLUMN_NUM(curr_sn_idx), 11072 AT_OBJ_NAME_PTR(curr_attr_idx), 11073 AT_OBJ_NAME_PTR(interface_idx)); 11074 AT_DCL_ERR(interface_idx) = TRUE; 11075 } 11076 } 11077 # ifdef _DEBUG 11078 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) { 11079 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 884, Internal, 11080 SN_COLUMN_NUM(curr_sn_idx), 11081 AT_OBJ_NAME_PTR(attr_idx), 11082 AT_OBJ_NAME_PTR(curr_attr_idx)); 11083 } 11084 # endif 11085 else { 11086 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1073, Error, 11087 SN_COLUMN_NUM(curr_sn_idx), 11088 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11089 "ASSIGNMENT", 11090 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11091 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11092 AT_DCL_ERR(interface_idx) = TRUE; 11093 } 11094 } 11095 break; 11096 11097 11098 case Defined_Unary_Interface : /* must be function with one argument */ 11099 11100 if (ATP_PGM_UNIT(curr_attr_idx) != Function) { 11101 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 492, Error, 11102 SN_COLUMN_NUM(curr_sn_idx), 11103 AT_OBJ_NAME_PTR(curr_attr_idx)); 11104 AT_DCL_ERR(interface_idx) = TRUE; 11105 AT_DCL_ERR(curr_attr_idx) = TRUE; 11106 } 11107 else if (TYP_TYPE(curr_type_idx) == Character && 11108 TYP_CHAR_CLASS(curr_type_idx) == Assumed_Size_Char) { 11109 11110 /* function result cannot have assumed char length */ 11111 11112 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 493, Error, 11113 SN_COLUMN_NUM(curr_sn_idx), 11114 AT_OBJ_NAME_PTR(curr_attr_idx)); 11115 AT_DCL_ERR(interface_idx) = TRUE; 11116 AT_DCL_ERR(curr_attr_idx) = TRUE; 11117 } 11118 11119 correct_num = (ATP_EXTRA_DARG(curr_attr_idx)) ? 2 : 1; 11120 11121 if (ATP_NUM_DARGS(curr_attr_idx) != correct_num) { 11122 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 494, Error, 11123 SN_COLUMN_NUM(curr_sn_idx), 11124 AT_OBJ_NAME_PTR(curr_attr_idx)); 11125 AT_DCL_ERR(interface_idx) = TRUE; 11126 AT_DCL_ERR(curr_attr_idx) = TRUE; 11127 } 11128 else { 11129 sn_idx = (ATP_EXTRA_DARG(curr_attr_idx)) ? 11130 (ATP_FIRST_IDX(curr_attr_idx) + 1) : 11131 ATP_FIRST_IDX(curr_attr_idx); 11132 attr_idx = SN_ATTR_IDX(sn_idx); 11133 11134 if (AT_OPTIONAL(attr_idx)) { 11135 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1071, Error, 11136 SN_COLUMN_NUM(curr_sn_idx), 11137 "OPERATOR", 11138 AT_OBJ_NAME_PTR(interface_idx), /* Interface name */ 11139 AT_OBJ_NAME_PTR(curr_attr_idx), /* Procedure name */ 11140 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11141 AT_DCL_ERR(interface_idx) = TRUE; 11142 } 11143 11144 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11145 type_idx_l = ATD_TYPE_IDX(attr_idx); 11146 rank_l = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) ? 11147 0 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11148 11149 /* intent = IN */ 11150 11151 if (ATD_INTENT(attr_idx) != Intent_In) { 11152 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1072, Error, 11153 SN_COLUMN_NUM(curr_sn_idx), 11154 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11155 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11156 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11157 11158 AT_DCL_ERR(interface_idx) = TRUE; 11159 } 11160 11161 type_idx_r = TYPELESS_DEFAULT_TYPE; 11162 rank_r = 0; 11163 11164 if (operation_is_intrinsic((operator_type) 11165 ATI_DEFINED_OPR(interface_idx), 11166 type_idx_l, 11167 rank_l, 11168 type_idx_r, 11169 rank_r)) { 11170 11171 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 495, Error, 11172 SN_COLUMN_NUM(curr_sn_idx), 11173 AT_OBJ_NAME_PTR(curr_attr_idx), 11174 AT_OBJ_NAME_PTR(interface_idx)); 11175 AT_DCL_ERR(interface_idx) = TRUE; 11176 } 11177 } 11178 # ifdef _DEBUG 11179 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) { 11180 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 884, Internal, 11181 SN_COLUMN_NUM(curr_sn_idx), 11182 AT_OBJ_NAME_PTR(attr_idx), 11183 AT_OBJ_NAME_PTR(curr_attr_idx)); 11184 } 11185 # endif 11186 else { 11187 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1073, Error, 11188 SN_COLUMN_NUM(curr_sn_idx), 11189 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11190 "OPERATOR", 11191 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11192 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11193 AT_DCL_ERR(interface_idx) = TRUE; 11194 } 11195 } 11196 break; 11197 11198 11199 case Defined_Binary_Interface : /* must be function with two arguments */ 11200 11201 if (ATP_PGM_UNIT(curr_attr_idx) != Function) { 11202 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 492, Error, 11203 SN_COLUMN_NUM(curr_sn_idx), 11204 AT_OBJ_NAME_PTR(curr_attr_idx)); 11205 AT_DCL_ERR(interface_idx) = TRUE; 11206 AT_DCL_ERR(curr_attr_idx) = TRUE; 11207 } 11208 else if (TYP_TYPE(curr_type_idx) == Character && 11209 TYP_CHAR_CLASS(curr_type_idx) == Assumed_Size_Char) { 11210 11211 /* function result cannot have assumed char length */ 11212 11213 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 493, Error, 11214 SN_COLUMN_NUM(curr_sn_idx), 11215 AT_OBJ_NAME_PTR(curr_attr_idx)); 11216 AT_DCL_ERR(interface_idx) = TRUE; 11217 AT_DCL_ERR(curr_attr_idx) = TRUE; 11218 } 11219 11220 correct_num = (ATP_EXTRA_DARG(curr_attr_idx)) ? 3 : 2; 11221 11222 if (ATP_NUM_DARGS(curr_attr_idx) != correct_num) { 11223 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 496, Error, 11224 SN_COLUMN_NUM(curr_sn_idx), 11225 AT_OBJ_NAME_PTR(curr_attr_idx)); 11226 AT_DCL_ERR(interface_idx) = TRUE; 11227 AT_DCL_ERR(curr_attr_idx) = TRUE; 11228 } 11229 else { 11230 sn_idx = (ATP_EXTRA_DARG(curr_attr_idx)) ? 11231 (ATP_FIRST_IDX(curr_attr_idx) + 1) : 11232 ATP_FIRST_IDX(curr_attr_idx); 11233 attr_idx = SN_ATTR_IDX(sn_idx); 11234 11235 if (AT_OPTIONAL(attr_idx)) { 11236 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1071, Error, 11237 SN_COLUMN_NUM(curr_sn_idx), 11238 "OPERATOR", 11239 AT_OBJ_NAME_PTR(interface_idx), /* Interface name */ 11240 AT_OBJ_NAME_PTR(curr_attr_idx), /* Procedure name */ 11241 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11242 AT_DCL_ERR(interface_idx) = TRUE; 11243 } 11244 11245 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11246 type_idx_l = ATD_TYPE_IDX(attr_idx); 11247 rank_l = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) ? 11248 0 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11249 11250 /* first intent = IN */ 11251 11252 if (ATD_INTENT(attr_idx) != Intent_In) { 11253 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1072, Error, 11254 SN_COLUMN_NUM(curr_sn_idx), 11255 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11256 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11257 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11258 AT_DCL_ERR(interface_idx) = TRUE; 11259 } 11260 } 11261 # ifdef _DEBUG 11262 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) { 11263 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 884, Internal, 11264 SN_COLUMN_NUM(curr_sn_idx), 11265 AT_OBJ_NAME_PTR(attr_idx), 11266 AT_OBJ_NAME_PTR(curr_attr_idx)); 11267 } 11268 # endif 11269 else { 11270 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1073, Error, 11271 SN_COLUMN_NUM(curr_sn_idx), 11272 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11273 "OPERATOR", 11274 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11275 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11276 AT_DCL_ERR(interface_idx) = TRUE; 11277 } 11278 11279 sn_idx++; 11280 attr_idx = SN_ATTR_IDX(sn_idx); 11281 11282 if (AT_OPTIONAL(attr_idx)) { 11283 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1071, Error, 11284 SN_COLUMN_NUM(curr_sn_idx), 11285 "OPERATOR", 11286 AT_OBJ_NAME_PTR(interface_idx), /* Interface name */ 11287 AT_OBJ_NAME_PTR(curr_attr_idx), /* Procedure name */ 11288 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11289 AT_DCL_ERR(interface_idx) = TRUE; 11290 } 11291 11292 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11293 type_idx_r = ATD_TYPE_IDX(attr_idx); 11294 rank_r = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) ? 11295 0 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11296 11297 /* second intent = IN */ 11298 11299 if (ATD_INTENT(attr_idx) != Intent_In) { 11300 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1072, Error, 11301 SN_COLUMN_NUM(curr_sn_idx), 11302 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11303 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11304 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11305 AT_DCL_ERR(interface_idx) = TRUE; 11306 } 11307 else if (operation_is_intrinsic((operator_type) 11308 ATI_DEFINED_OPR(interface_idx), 11309 type_idx_l, 11310 rank_l, 11311 type_idx_r, 11312 rank_r)) { 11313 11314 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 495, Error, 11315 SN_COLUMN_NUM(curr_sn_idx), 11316 AT_OBJ_NAME_PTR(curr_attr_idx), 11317 AT_OBJ_NAME_PTR(interface_idx)); 11318 AT_DCL_ERR(interface_idx) = TRUE; 11319 } 11320 } 11321 # ifdef _DEBUG 11322 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) { 11323 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 884, Internal, 11324 SN_COLUMN_NUM(curr_sn_idx), 11325 AT_OBJ_NAME_PTR(attr_idx), 11326 AT_OBJ_NAME_PTR(curr_attr_idx)); 11327 } 11328 # endif 11329 else { 11330 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1073, Error, 11331 SN_COLUMN_NUM(curr_sn_idx), 11332 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11333 "OPERATOR", 11334 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11335 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11336 AT_DCL_ERR(interface_idx) = TRUE; 11337 } 11338 } 11339 break; 11340 11341 11342 case Defined_Unary_Or_Binary_Interface : 11343 11344 /* must be function with one or two arguments */ 11345 11346 if (ATP_PGM_UNIT(curr_attr_idx) != Function) { 11347 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 492, Error, 11348 SN_COLUMN_NUM(curr_sn_idx), 11349 AT_OBJ_NAME_PTR(curr_attr_idx)); 11350 AT_DCL_ERR(interface_idx) = TRUE; 11351 AT_DCL_ERR(curr_attr_idx) = TRUE; 11352 } 11353 else if (TYP_TYPE(curr_type_idx) == Character && 11354 TYP_CHAR_CLASS(curr_type_idx) == Assumed_Size_Char) { 11355 11356 /* function result cannot have assumed char length */ 11357 11358 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 493, Error, 11359 SN_COLUMN_NUM(curr_sn_idx), 11360 AT_OBJ_NAME_PTR(curr_attr_idx)); 11361 AT_DCL_ERR(interface_idx) = TRUE; 11362 AT_DCL_ERR(curr_attr_idx) = TRUE; 11363 } 11364 11365 correct_num = (ATP_EXTRA_DARG(curr_attr_idx)) ? 2 : 1; 11366 11367 if (ATP_NUM_DARGS(curr_attr_idx) != correct_num && 11368 ATP_NUM_DARGS(curr_attr_idx) != correct_num + 1) { 11369 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 497, Error, 11370 SN_COLUMN_NUM(curr_sn_idx), 11371 AT_OBJ_NAME_PTR(curr_attr_idx)); 11372 AT_DCL_ERR(interface_idx) = TRUE; 11373 AT_DCL_ERR(curr_attr_idx) = TRUE; 11374 } 11375 else { 11376 sn_idx = (ATP_EXTRA_DARG(curr_attr_idx)) ? 11377 (ATP_FIRST_IDX(curr_attr_idx) + 1) : 11378 ATP_FIRST_IDX(curr_attr_idx); 11379 attr_idx = SN_ATTR_IDX(sn_idx); 11380 11381 if (AT_OPTIONAL(attr_idx)) { 11382 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1071, Error, 11383 SN_COLUMN_NUM(curr_sn_idx), 11384 "OPERATOR", 11385 AT_OBJ_NAME_PTR(interface_idx), /* Interface name */ 11386 AT_OBJ_NAME_PTR(curr_attr_idx), /* Procedure name */ 11387 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11388 AT_DCL_ERR(interface_idx) = TRUE; 11389 } 11390 11391 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11392 type_idx_l = ATD_TYPE_IDX(attr_idx); 11393 rank_l = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) ? 11394 0 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11395 11396 /* first intent = IN */ 11397 11398 if (ATD_INTENT(attr_idx) != Intent_In) { 11399 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1072, Error, 11400 SN_COLUMN_NUM(curr_sn_idx), 11401 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11402 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11403 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11404 AT_DCL_ERR(interface_idx) = TRUE; 11405 } 11406 } 11407 # ifdef _DEBUG 11408 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) { 11409 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 884, Internal, 11410 SN_COLUMN_NUM(curr_sn_idx), 11411 AT_OBJ_NAME_PTR(attr_idx), 11412 AT_OBJ_NAME_PTR(curr_attr_idx)); 11413 } 11414 # endif 11415 else { 11416 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1073, Error, 11417 SN_COLUMN_NUM(curr_sn_idx), 11418 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11419 "OPERATOR", 11420 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11421 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11422 AT_DCL_ERR(interface_idx) = TRUE; 11423 } 11424 11425 if (ATP_NUM_DARGS(curr_attr_idx) == correct_num + 1) { 11426 sn_idx++; 11427 attr_idx = SN_ATTR_IDX(sn_idx); 11428 11429 if (AT_OPTIONAL(attr_idx)) { 11430 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1071, Error, 11431 SN_COLUMN_NUM(curr_sn_idx), 11432 "OPERATOR", 11433 AT_OBJ_NAME_PTR(interface_idx), /* Interface name */ 11434 AT_OBJ_NAME_PTR(curr_attr_idx), /* Procedure name */ 11435 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11436 AT_DCL_ERR(interface_idx) = TRUE; 11437 } 11438 11439 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 11440 type_idx_r = ATD_TYPE_IDX(attr_idx); 11441 rank_r = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) ? 11442 0 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 11443 11444 /* second intent = IN */ 11445 11446 if (ATD_INTENT(attr_idx) != Intent_In) { 11447 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1072, Error, 11448 SN_COLUMN_NUM(curr_sn_idx), 11449 AT_OBJ_NAME_PTR(interface_idx), /*interface name*/ 11450 AT_OBJ_NAME_PTR(curr_attr_idx), /*procedure name*/ 11451 AT_OBJ_NAME_PTR(attr_idx)); /*Dummy Arg name*/ 11452 AT_DCL_ERR(interface_idx) = TRUE; 11453 } 11454 } 11455 # ifdef _DEBUG 11456 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) { 11457 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 884, Internal, 11458 SN_COLUMN_NUM(curr_sn_idx), 11459 AT_OBJ_NAME_PTR(attr_idx), 11460 AT_OBJ_NAME_PTR(curr_attr_idx)); 11461 } 11462 # endif 11463 else { 11464 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 1073, Error, 11465 SN_COLUMN_NUM(curr_sn_idx), 11466 AT_OBJ_NAME_PTR(curr_attr_idx), /* procedure name */ 11467 "OPERATOR", 11468 AT_OBJ_NAME_PTR(interface_idx), /* interface name */ 11469 AT_OBJ_NAME_PTR(attr_idx)); /* Dummy Arg name */ 11470 AT_DCL_ERR(interface_idx) = TRUE; 11471 } 11472 } 11473 else { 11474 type_idx_r = TYPELESS_DEFAULT_TYPE; 11475 } 11476 11477 if (!AT_DCL_ERR(interface_idx) && 11478 operation_is_intrinsic((operator_type) 11479 ATI_DEFINED_OPR(interface_idx), 11480 type_idx_l, 11481 rank_l, 11482 type_idx_r, 11483 rank_r)) { 11484 11485 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 495, Error, 11486 SN_COLUMN_NUM(curr_sn_idx), 11487 AT_OBJ_NAME_PTR(curr_attr_idx), 11488 AT_OBJ_NAME_PTR(interface_idx)); 11489 AT_DCL_ERR(interface_idx) = TRUE; 11490 } 11491 } 11492 break; 11493 } /* End switch */ 11494 11495 /* Go through the rest of the procedures in this interface. Compare */ 11496 /* them to the present procedure. Look for ambiguities. */ 11497 /* Do not do comparisons for intrinsics. */ 11498 11499 sn_idx = (AT_IS_INTRIN(curr_attr_idx)) ? NULL_IDX : 11500 SN_SIBLING_LINK(curr_sn_idx); 11501 11502 while (sn_idx != NULL_IDX) { 11503 11504 attr_idx = SN_ATTR_IDX(sn_idx); 11505 11506 if (AT_IS_INTRIN(attr_idx)) { 11507 11508 /* Assume all intrinsics are at the end */ 11509 11510 break; 11511 } 11512 11513 if (ATP_EXTRA_DARG(curr_attr_idx)) { 11514 curr_num_dargs = ATP_NUM_DARGS(curr_attr_idx) - 1; 11515 curr_darg_sn_idx = ATP_FIRST_IDX(curr_attr_idx) + 1; 11516 } 11517 else { 11518 curr_num_dargs = ATP_NUM_DARGS(curr_attr_idx); 11519 curr_darg_sn_idx = ATP_FIRST_IDX(curr_attr_idx); 11520 } 11521 11522 if (ATP_EXTRA_DARG(attr_idx)) { 11523 num_dargs = ATP_NUM_DARGS(attr_idx) - 1; 11524 darg_sn_idx = ATP_FIRST_IDX(attr_idx) + 1; 11525 } 11526 else { 11527 num_dargs = ATP_NUM_DARGS(attr_idx); 11528 darg_sn_idx = ATP_FIRST_IDX(attr_idx); 11529 } 11530 11531 if (ATP_PGM_UNIT(curr_attr_idx) == ATP_PGM_UNIT(attr_idx) && 11532 (curr_num_dargs == num_dargs || 11533 ATI_INTERFACE_CLASS(interface_idx) < Defined_Interface)) { 11534 save_num_dargs = num_dargs; 11535 save_darg_sn_idx = darg_sn_idx; 11536 save_curr_num_dargs = curr_num_dargs; 11537 save_curr_darg_sn_idx = curr_darg_sn_idx; 11538 ambiguous = TRUE; 11539 loop_cnt = (curr_num_dargs > num_dargs) ? 11540 curr_num_dargs: num_dargs; 11541 11542 for (i = 0; i < loop_cnt; i++) { /* get the dummy arg indexes */ 11543 11544 if (curr_num_dargs != NULL_IDX) { 11545 curr_darg_idx = SN_ATTR_IDX(curr_darg_sn_idx); 11546 curr_darg_sn_idx++; 11547 curr_num_dargs--; 11548 } 11549 else { 11550 curr_darg_idx = NULL_IDX; 11551 } 11552 11553 if (num_dargs != NULL_IDX) { 11554 darg_idx = SN_ATTR_IDX(darg_sn_idx); 11555 darg_sn_idx++; 11556 num_dargs--; 11557 } 11558 else { 11559 darg_idx = NULL_IDX; 11560 } 11561 11562 /* Compare Kind, Type and Rank of the dummy arguments. */ 11563 /* For defined interfaces this is all we need to compare. */ 11564 /* For generic interfaces, we need to compare alot more. */ 11565 11566 if (curr_darg_idx == NULL_IDX || darg_idx == NULL_IDX) { 11567 same_dargs = FALSE; 11568 } 11569 else { 11570 same_dargs = compare_dummy_arguments(curr_darg_idx, darg_idx); 11571 } 11572 11573 if (ATI_INTERFACE_CLASS(interface_idx) >= Defined_Interface) { 11574 11575 if (!same_dargs) { /* Generic */ 11576 ambiguous = FALSE; 11577 break; 11578 } 11579 continue; 11580 } 11581 11582 if (curr_darg_idx != NULL_IDX && !AT_OPTIONAL(curr_darg_idx)) { 11583 11584 if (same_dargs && 11585 !AT_OPTIONAL(darg_idx) && 11586 !SN_MATCHED_DARG(darg_sn_idx - 1) && 11587 !SN_MATCHED_DARG(curr_darg_sn_idx - 1)) { 11588 11589 /* Attempt to match up all non optional dargs. */ 11590 11591 SN_MATCHED_DARG(darg_sn_idx-1) = TRUE; 11592 SN_MATCHED_DARG(curr_darg_sn_idx-1) = TRUE; 11593 } 11594 11595 /* At least one of them shall have both */ 11596 11597 /* A nonoptional dummy argument that corresponds by */ 11598 /* position in the argument list to a dummy argument */ 11599 /* not present in the other, present with a different */ 11600 /* type, present with a different kind type parameter, */ 11601 /* or present with a different rank. */ 11602 11603 /* AND */ 11604 11605 /* A nonoptional dummy argument that corresponds by */ 11606 /* argument keyword to a dummy argument not present */ 11607 /* in the other, present with a different type, */ 11608 /* present with a different kind type parameter, */ 11609 /* or present with a different rank. */ 11610 11611 if (!same_dargs) { 11612 11613 /* This differs by position. Does it differ by kwd? */ 11614 11615 kwd_darg_idx =srch_kwd_name(AT_OBJ_NAME_PTR(curr_darg_idx), 11616 AT_NAME_LEN(curr_darg_idx), 11617 attr_idx, 11618 &kwd_sn_idx); 11619 11620 if (kwd_darg_idx == NULL_IDX) { 11621 ambiguous = FALSE; 11622 break; 11623 } 11624 11625 if (!compare_dummy_arguments(curr_darg_idx, kwd_darg_idx)){ 11626 ambiguous = FALSE; 11627 break; 11628 } 11629 11630 if (!AT_OPTIONAL(kwd_darg_idx) && 11631 !SN_MATCHED_DARG(kwd_sn_idx) && 11632 !SN_MATCHED_DARG(curr_darg_sn_idx - 1)) { 11633 11634 /* Attempt to match up all non optional dargs. */ 11635 11636 SN_MATCHED_DARG(curr_darg_sn_idx - 1) = TRUE; 11637 SN_MATCHED_DARG(kwd_sn_idx) = TRUE; 11638 } 11639 } 11640 11641 /* OR */ 11642 11643 /* one of them must have more nonoptional dummy */ 11644 /* arguments of a particular data type, kind type */ 11645 /* parameter, and rank than the other has dummy */ 11646 /* arguments (including optional dummy arguments) */ 11647 /* of that data type, kind type parameter, and rank. */ 11648 11649 /* Check for a non optional match on the curr darg */ 11650 11651 if (!SN_MATCHED_DARG(curr_darg_sn_idx - 1)) { 11652 ktr_sn_idx = save_darg_sn_idx; 11653 optional_sn_idx = NULL_IDX; 11654 11655 /* Loop through the dummy args looking for a match */ 11656 11657 for (idx = 0; idx < save_num_dargs; idx++) { 11658 11659 if (SN_MATCHED_DARG(ktr_sn_idx)) { 11660 ktr_sn_idx++; 11661 continue; 11662 } 11663 11664 if (compare_dummy_arguments(curr_darg_idx, 11665 SN_ATTR_IDX(ktr_sn_idx))) { 11666 11667 /* We want to match all non optionals first, */ 11668 /* because we need to make sure they are all */ 11669 /* checked for a match. Keep track of the */ 11670 /* optional match, in case we need to use it. */ 11671 11672 11673 if (AT_OPTIONAL(SN_ATTR_IDX(ktr_sn_idx))) { 11674 optional_sn_idx = ktr_sn_idx; 11675 } 11676 else { 11677 SN_MATCHED_DARG(ktr_sn_idx) = TRUE; 11678 SN_MATCHED_DARG(curr_darg_sn_idx-1) = TRUE; 11679 break; 11680 } 11681 } 11682 ktr_sn_idx++; 11683 } 11684 11685 if (!SN_MATCHED_DARG(curr_darg_sn_idx-1) && 11686 optional_sn_idx != NULL_IDX) { 11687 11688 /* Matched to an optional - set it */ 11689 11690 SN_MATCHED_DARG(optional_sn_idx) = TRUE; 11691 SN_MATCHED_DARG(curr_darg_sn_idx-1) = TRUE; 11692 } 11693 11694 /* This non optional does not have a match. */ 11695 /* This makes this interface unambiguous. */ 11696 11697 if (!SN_MATCHED_DARG(curr_darg_sn_idx-1)) { 11698 ambiguous = FALSE; 11699 break; 11700 } 11701 } 11702 } 11703 11704 if (darg_idx != NULL_IDX && !AT_OPTIONAL(darg_idx)) { 11705 11706 /* At least one of them shall have both */ 11707 11708 /* A nonoptional dummy argument that corresponds by */ 11709 /* position in the argument list to a dummy argument */ 11710 /* not present in the other, present with a different */ 11711 /* type, present with a different kind type parameter, */ 11712 /* or present with a different rank. */ 11713 11714 /* AND */ 11715 11716 /* A nonoptional dummy argument that corresponds by */ 11717 /* argument keyword to a dummy argument not present */ 11718 /* in the other, present with a different type, */ 11719 /* present with a different kind type parameter, */ 11720 /* or present with a different rank. */ 11721 11722 if (!same_dargs) { 11723 11724 /* This differs by position. Does it differ by kwd? */ 11725 11726 kwd_darg_idx = srch_kwd_name(AT_OBJ_NAME_PTR(darg_idx), 11727 AT_NAME_LEN(darg_idx), 11728 curr_attr_idx, 11729 &kwd_sn_idx); 11730 11731 if (kwd_darg_idx == NULL_IDX) { 11732 ambiguous = FALSE; 11733 break; 11734 } 11735 11736 if (!compare_dummy_arguments(darg_idx, kwd_darg_idx)){ 11737 ambiguous = FALSE; 11738 break; 11739 } 11740 11741 if (!AT_OPTIONAL(kwd_darg_idx) && 11742 !SN_MATCHED_DARG(kwd_sn_idx) && 11743 !SN_MATCHED_DARG(darg_sn_idx - 1)) { 11744 11745 /* Attempt to match up all non optional dargs. */ 11746 11747 SN_MATCHED_DARG(darg_sn_idx - 1) = TRUE; 11748 SN_MATCHED_DARG(kwd_sn_idx) = TRUE; 11749 } 11750 } 11751 11752 /* Check for a non optional match on darg */ 11753 11754 if (!SN_MATCHED_DARG(darg_sn_idx - 1)) { 11755 ktr_sn_idx = save_curr_darg_sn_idx; 11756 optional_sn_idx = NULL_IDX; 11757 11758 /* Loop through the dummy args looking for a match */ 11759 11760 for (idx = 0; idx < save_curr_num_dargs; idx++) { 11761 11762 if (SN_MATCHED_DARG(ktr_sn_idx)) { 11763 ktr_sn_idx++; 11764 continue; 11765 } 11766 11767 if (compare_dummy_arguments(darg_idx, 11768 SN_ATTR_IDX(ktr_sn_idx))) { 11769 11770 /* We want to match all non optionals first, */ 11771 /* because we need to make sure they are all */ 11772 /* checked for a match. Keep track of the */ 11773 /* optional match, in case we need to use it. */ 11774 11775 11776 if (AT_OPTIONAL(SN_ATTR_IDX(ktr_sn_idx))) { 11777 optional_sn_idx = ktr_sn_idx; 11778 } 11779 else { 11780 SN_MATCHED_DARG(ktr_sn_idx) = TRUE; 11781 SN_MATCHED_DARG(darg_sn_idx-1) = TRUE; 11782 break; 11783 } 11784 } 11785 ktr_sn_idx++; 11786 } 11787 11788 if (!SN_MATCHED_DARG(darg_sn_idx-1) && 11789 optional_sn_idx != NULL_IDX) { 11790 11791 /* Matched to an optional - set it */ 11792 11793 SN_MATCHED_DARG(optional_sn_idx) = TRUE; 11794 SN_MATCHED_DARG(darg_sn_idx-1) = TRUE; 11795 } 11796 11797 /* This non optional does not have a match. */ 11798 /* This makes this interface unambiguous. */ 11799 11800 if (!SN_MATCHED_DARG(darg_sn_idx-1)) { 11801 ambiguous = FALSE; 11802 break; 11803 } 11804 } 11805 } 11806 } /* for loop for dummy args */ 11807 11808 /* If generic clear the SN_MATCHED_DARG flag */ 11809 11810 if (ATI_INTERFACE_CLASS(interface_idx) < Defined_Interface) { 11811 ktr_sn_idx = save_darg_sn_idx; 11812 11813 for (idx = 0; idx < save_num_dargs; idx++) { 11814 SN_MATCHED_DARG(ktr_sn_idx) = FALSE; 11815 ktr_sn_idx++; 11816 } 11817 11818 ktr_sn_idx = save_curr_darg_sn_idx; 11819 11820 for (idx = 0; idx < save_curr_num_dargs; idx++) { 11821 SN_MATCHED_DARG(ktr_sn_idx) = FALSE; 11822 ktr_sn_idx++; 11823 } 11824 } 11825 11826 if (ambiguous) { /* ambiguous interface, two specs the same */ 11827 11828 if (compare_names(AT_OBJ_NAME_LONG(curr_attr_idx), 11829 AT_NAME_LEN(curr_attr_idx), 11830 AT_OBJ_NAME_LONG(attr_idx), 11831 AT_NAME_LEN(attr_idx)) == 0) { 11832 11833 /* These have the same name. If they are from the */ 11834 /* same original module. Then do not issue a message. */ 11835 /* Otherwise issue a message. */ 11836 11837 /* KAY - It might be nice to unhook duplicates like this. */ 11838 11839 if (AT_MODULE_IDX(curr_attr_idx) == NULL_IDX || 11840 AT_MODULE_IDX(attr_idx) == NULL_IDX || 11841 ATP_MODULE_STR_IDX(AT_MODULE_IDX(curr_attr_idx)) != 11842 ATP_MODULE_STR_IDX(AT_MODULE_IDX(attr_idx))) { 11843 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 991, Error, 11844 SN_COLUMN_NUM(curr_sn_idx), 11845 AT_OBJ_NAME_PTR(curr_attr_idx), 11846 (ATI_INTERFACE_CLASS(interface_idx) ? "GENERIC" : 11847 "DEFINED"), 11848 AT_OBJ_NAME_PTR(interface_idx)); 11849 AT_DCL_ERR(interface_idx) = TRUE; 11850 } 11851 } 11852 else { 11853 PRINTMSG(SN_LINE_NUM(curr_sn_idx), 487, Error, 11854 SN_COLUMN_NUM(curr_sn_idx), 11855 AT_OBJ_NAME_PTR(curr_attr_idx), 11856 AT_OBJ_NAME_PTR(attr_idx), 11857 (ATI_INTERFACE_CLASS(interface_idx) ? "GENERIC" : 11858 "DEFINED"), 11859 AT_OBJ_NAME_PTR(interface_idx)); 11860 AT_DCL_ERR(interface_idx) = TRUE; 11861 } 11862 } 11863 } /* if .. */ 11864 11865 sn_idx = SN_SIBLING_LINK(sn_idx); 11866 } 11867 11868 curr_sn_idx = SN_SIBLING_LINK(curr_sn_idx); 11869 } 11870 11871 EXIT: 11872 11873 TRACE (Func_Exit, "verify_interface", NULL); 11874 11875 return; 11876 11877 } /* verify_interface */ 11878 11879 /******************************************************************************\ 11880 |* *| 11881 |* Description: *| 11882 |* If a procedure has multiple specific interfaces, verify that they are *| 11883 |* the same. *| 11884 |* *| 11885 |* Input parameters: *| 11886 |* attr_idx - The program unit to compare. *| 11887 |* *| 11888 |* Output parameters: *| 11889 |* NONE *| 11890 |* *| 11891 |* Returns: *| 11892 |* NOTHING *| 11893 |* *| 11894 \******************************************************************************/ 11895 static void compare_duplicate_interface_bodies(int attr_idx) 11896 11897 { 11898 int dup_attr_idx; 11899 int idx; 11900 int idx1; 11901 int idx2; 11902 int rank1; 11903 int rank2; 11904 boolean same = TRUE; 11905 11906 11907 TRACE (Func_Entry, "compare_duplicate_interface_bodies", NULL); 11908 11909 dup_attr_idx = ATP_DUPLICATE_INTERFACE_IDX(attr_idx); 11910 ATP_DUPLICATE_INTERFACE_IDX(attr_idx) = NULL_IDX; 11911 11912 if (ATP_PGM_UNIT(attr_idx) != ATP_PGM_UNIT(dup_attr_idx) || 11913 ATP_NUM_DARGS(attr_idx) != ATP_NUM_DARGS(dup_attr_idx) || 11914 ATP_RSLT_NAME(attr_idx) != ATP_RSLT_NAME(dup_attr_idx)) { 11915 11916 /* One is a function and one is a subroutine, or they have */ 11917 /* a different number of dummy arguments and/or one has */ 11918 /* a result name and the other does not. */ 11919 11920 same = FALSE; 11921 } 11922 else { /* Compare results and individual dummy arguments. */ 11923 11924 if (ATP_PGM_UNIT(attr_idx) == Function) { 11925 idx1 = ATP_RSLT_IDX(attr_idx); 11926 idx2 = ATP_RSLT_IDX(dup_attr_idx); 11927 11928 if (ATP_RSLT_NAME(attr_idx) && 11929 (compare_names(AT_OBJ_NAME_LONG(idx1), 11930 AT_NAME_LEN(idx1), 11931 AT_OBJ_NAME_LONG(idx2), 11932 AT_NAME_LEN(idx2)) != 0)) { 11933 same = FALSE; 11934 } 11935 else { /* Compare kind, type and rank of result */ 11936 11937 if (TYP_TYPE(ATD_TYPE_IDX(idx1)) != TYP_TYPE(ATD_TYPE_IDX(idx2))) { 11938 same = FALSE; 11939 } 11940 else if (TYP_TYPE(ATD_TYPE_IDX(idx1)) == Structure && 11941 !compare_derived_types(ATD_TYPE_IDX(idx1), 11942 ATD_TYPE_IDX(idx2))) { 11943 same = FALSE; 11944 } 11945 else if (TYP_TYPE(ATD_TYPE_IDX(idx1)) != Character && 11946 TYP_TYPE(ATD_TYPE_IDX(idx1)) != Structure && 11947 TYP_LINEAR(ATD_TYPE_IDX(idx1)) != 11948 TYP_LINEAR(ATD_TYPE_IDX(idx2))) { 11949 same = FALSE; 11950 } 11951 11952 if (same) { 11953 rank1 = (ATD_ARRAY_IDX(idx1) == NULL_IDX) ? 0 : 11954 BD_RANK(ATD_ARRAY_IDX(idx1)); 11955 rank2 = (ATD_ARRAY_IDX(idx2) == NULL_IDX) ? 0 : 11956 BD_RANK(ATD_ARRAY_IDX(idx2)); 11957 11958 if (rank1 != rank2) { 11959 same = FALSE; 11960 } 11961 } 11962 } 11963 } 11964 11965 if (same) { /* Check the dummy arguments. */ 11966 idx1 = ATP_FIRST_IDX(attr_idx); 11967 idx2 = ATP_FIRST_IDX(dup_attr_idx); 11968 11969 for (idx = 0; idx < ATP_NUM_DARGS(attr_idx); idx++) { 11970 11971 if (compare_names(AT_OBJ_NAME_LONG(SN_ATTR_IDX(idx1)), 11972 AT_NAME_LEN(SN_ATTR_IDX(idx1)), 11973 AT_OBJ_NAME_LONG(SN_ATTR_IDX(idx2)), 11974 AT_NAME_LEN(SN_ATTR_IDX(idx2))) != 0) { 11975 same = FALSE; /* Keyword names differ */ 11976 break; 11977 } 11978 11979 if (!compare_dummy_arguments(SN_ATTR_IDX(idx1),SN_ATTR_IDX(idx2))) { 11980 same = FALSE; 11981 break; 11982 } 11983 idx1++; idx2++; 11984 } 11985 } 11986 } 11987 11988 if (same) { /* Issue ANSI */ 11989 PRINTMSG(AT_DEF_LINE(dup_attr_idx), 1515, Ansi, 11990 AT_DEF_COLUMN(dup_attr_idx), 11991 AT_OBJ_NAME_PTR(dup_attr_idx)); 11992 } 11993 else { /* They are different. */ 11994 PRINTMSG(AT_DEF_LINE(dup_attr_idx), 1516, Error, 11995 AT_DEF_COLUMN(dup_attr_idx), 11996 AT_OBJ_NAME_PTR(dup_attr_idx)); 11997 } 11998 11999 TRACE (Func_Exit, "compare_duplicate_interface_bodies", NULL); 12000 12001 return; 12002 12003 } /* compare_duplicate_interface_bodies */ 12004 12005 /******************************************************************************\ 12006 |* *| 12007 |* Description: *| 12008 |* Check for reshape arrays and set ATD_RESHAPE_ARRAY_OPT if okay. *| 12009 |* *| 12010 |* Input parameters: *| 12011 |* NONE *| 12012 |* *| 12013 |* Output parameters: *| 12014 |* NONE *| 12015 |* *| 12016 |* Returns: *| 12017 |* NOTHING *| 12018 |* *| 12019 \******************************************************************************/ 12020 static void reshape_array_semantics(void) 12021 { 12022 int al_idx; 12023 int attr_idx; 12024 int fp_idx; 12025 int name_idx; 12026 token_type name_token; 12027 12028 12029 TRACE (Func_Entry, "reshape_array_semantics", NULL); 12030 12031 fp_idx = opt_flags.reshape_idx; 12032 12033 while (fp_idx != NULL_IDX) { 12034 CREATE_ID(TOKEN_ID(name_token),(FP_NAME_PTR(fp_idx)),FP_NAME_LEN(fp_idx)); 12035 12036 TOKEN_COLUMN(name_token) = 1; 12037 TOKEN_LEN(name_token) = FP_NAME_LEN(fp_idx); 12038 TOKEN_LINE(name_token) = stmt_start_line; 12039 12040 attr_idx = srch_sym_tbl(TOKEN_STR(name_token), 12041 TOKEN_LEN(name_token), 12042 &name_idx); 12043 12044 if (attr_idx != NULL_IDX) { /* Name exists in symbol table already */ 12045 12046 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 12047 ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 12048 12049 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Explicit_Shape && 12050 (ATD_CLASS(attr_idx) != CRI__Pointee && 12051 ATD_CLASS(attr_idx) != Constant) && 12052 BD_RANK(ATD_ARRAY_IDX(attr_idx)) > 1) { 12053 ATD_RESHAPE_ARRAY_OPT(attr_idx) = TRUE; 12054 12055 NTR_ATTR_LIST_TBL(al_idx); 12056 AL_ATTR_IDX(al_idx) = attr_idx; 12057 AL_NEXT_IDX(al_idx) = reshape_array_list; 12058 reshape_array_list = al_idx; 12059 if (ATD_DATA_INIT(attr_idx)) { 12060 PRINTMSG(AT_DEF_LINE(attr_idx), 1644, Error, 12061 AT_DEF_COLUMN(attr_idx), 12062 AT_OBJ_NAME_PTR(attr_idx)); 12063 } 12064 } 12065 else { 12066 PRINTMSG(AT_DEF_LINE(attr_idx), 1539, Error, 12067 AT_DEF_COLUMN(attr_idx), 12068 AT_OBJ_NAME_PTR(attr_idx)); 12069 } 12070 } 12071 else { /* This is already something else in this scope. */ 12072 PRINTMSG(AT_DEF_LINE(attr_idx), 1538, Warning, 12073 AT_DEF_COLUMN(attr_idx), 12074 AT_OBJ_NAME_PTR(attr_idx), 12075 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 12076 } 12077 } 12078 12079 fp_idx = FP_NEXT_FILE_IDX(fp_idx); 12080 } 12081 12082 TRACE (Func_Exit, "reshape_array_semantics", NULL); 12083 12084 return; 12085 12086 } /* reshape_array_semantics */ 12087 12088 /******************************************************************************\ 12089 |* *| 12090 |* Description: *| 12091 |* <description> *| 12092 |* *| 12093 |* Input parameters: *| 12094 |* NONE *| 12095 |* *| 12096 |* Output parameters: *| 12097 |* NONE *| 12098 |* *| 12099 |* Returns: *| 12100 |* NOTHING *| 12101 |* *| 12102 \******************************************************************************/ 12103 12104 static void gen_allocatable_ptr_ptee(int attr_idx) 12105 12106 { 12107 int col; 12108 int line; 12109 int ptr_idx; 12110 int ptee_idx; 12111 id_str_type storage_name; 12112 12113 12114 TRACE (Func_Entry, "gen_allocatable_ptr_ptee", NULL); 12115 12116 line = AT_DEF_LINE(attr_idx); 12117 col = AT_DEF_COLUMN(attr_idx); 12118 12119 ptr_idx = gen_compiler_tmp(line, col, Shared, TRUE); 12120 12121 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 12122 ATD_TYPE_IDX(ptr_idx) = CRI_Ch_Ptr_8; 12123 } 12124 else { 12125 ATD_TYPE_IDX(ptr_idx) = CRI_Ptr_8; 12126 } 12127 AT_SEMANTICS_DONE(ptr_idx) = TRUE; 12128 12129 # ifdef _DEBUG 12130 if (ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX) { 12131 PRINTMSG(line, 626, Internal, col, 12132 "valid ATD_STOR_BLK_IDX", 12133 "gen_allocatable_ptr_ptee"); 12134 } 12135 # endif 12136 ATD_STOR_BLK_IDX(ptr_idx) = ATD_STOR_BLK_IDX(attr_idx); 12137 12138 ptee_idx = gen_compiler_tmp(line, col, Shared, TRUE); 12139 ATD_CLASS(ptee_idx) = CRI__Pointee; 12140 AT_SEMANTICS_DONE(ptee_idx) = TRUE; 12141 12142 if (pointee_based_blk == NULL_IDX) { 12143 12144 /* Create a based entry for PDGCS to use for cri_pointees */ 12145 12146 CREATE_ID(storage_name, sb_name[Pointee_Blk], sb_len[Pointee_Blk]); 12147 pointee_based_blk = ntr_stor_blk_tbl(storage_name.string, 12148 sb_len[Pointee_Blk], 12149 AT_DEF_LINE(attr_idx), 12150 AT_DEF_COLUMN(attr_idx), 12151 Based); 12152 } 12153 12154 ATD_STOR_BLK_IDX(ptee_idx) = pointee_based_blk; 12155 12156 ATD_TYPE_IDX(ptee_idx) = ATD_TYPE_IDX(attr_idx); 12157 ATD_PTR_IDX(ptee_idx) = ptr_idx; 12158 12159 ATD_ARRAY_IDX(ptee_idx) = set_up_bd_tmps(BD_RANK(ATD_ARRAY_IDX(attr_idx)), 12160 line, 12161 col, 12162 ATD_STOR_BLK_IDX(attr_idx), 12163 FALSE); 12164 ATD_PE_ARRAY_IDX(ptee_idx) = 12165 set_up_bd_tmps(BD_RANK(ATD_PE_ARRAY_IDX(attr_idx)), 12166 line, 12167 col, 12168 ATD_STOR_BLK_IDX(attr_idx), 12169 TRUE); 12170 12171 ATD_FLD(attr_idx) = AT_Tbl_Idx; 12172 ATD_VARIABLE_TMP_IDX(attr_idx) = ptee_idx; 12173 12174 TRACE (Func_Exit, "gen_allocatable_ptr_ptee", NULL); 12175 12176 return; 12177 12178 } /* gen_allocatable_ptr_ptee */ 12179 12180 /******************************************************************************\ 12181 |* *| 12182 |* Description: *| 12183 |* <description> *| 12184 |* *| 12185 |* Input parameters: *| 12186 |* NONE *| 12187 |* *| 12188 |* Output parameters: *| 12189 |* NONE *| 12190 |* *| 12191 |* Returns: *| 12192 |* NOTHING *| 12193 |* *| 12194 \******************************************************************************/ 12195 12196 static int set_up_bd_tmps(int rank, 12197 int line, 12198 int col, 12199 int stor_blk_idx, 12200 boolean assumed_size) 12201 12202 { 12203 int bd_idx; 12204 int i; 12205 int tmp_idx; 12206 12207 12208 TRACE (Func_Entry, "set_up_bd_tmps", NULL); 12209 12210 bd_idx = reserve_array_ntry(rank); 12211 BD_RANK(bd_idx) = rank; 12212 BD_LINE_NUM(bd_idx) = line; 12213 BD_COLUMN_NUM(bd_idx) = col; 12214 BD_ARRAY_SIZE(bd_idx) = Var_Len_Array; 12215 BD_ARRAY_CLASS(bd_idx) = (assumed_size ? Assumed_Size : Explicit_Shape); 12216 BD_RESOLVED(bd_idx) = TRUE; 12217 12218 for (i =1; i <= rank; i++) { 12219 12220 tmp_idx = gen_compiler_tmp(line, col, Shared, TRUE); 12221 ATD_TYPE_IDX(tmp_idx) = SA_INTEGER_DEFAULT_TYPE; 12222 ATD_STOR_BLK_IDX(tmp_idx) = stor_blk_idx; 12223 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 12224 12225 BD_LB_FLD(bd_idx,i) = AT_Tbl_Idx; 12226 BD_LB_IDX(bd_idx,i) = tmp_idx; 12227 12228 12229 if (assumed_size && i == rank) { 12230 BD_XT_FLD(bd_idx,i) = CN_Tbl_Idx; 12231 BD_XT_IDX(bd_idx,i) = CN_INTEGER_ONE_IDX; 12232 12233 BD_UB_FLD(bd_idx,i) = BD_LB_FLD(bd_idx,i); 12234 BD_UB_IDX(bd_idx,i) = BD_LB_IDX(bd_idx,i); 12235 } 12236 else { 12237 tmp_idx = gen_compiler_tmp(line, col, Shared, TRUE); 12238 ATD_TYPE_IDX(tmp_idx) = SA_INTEGER_DEFAULT_TYPE; 12239 ATD_STOR_BLK_IDX(tmp_idx) = stor_blk_idx; 12240 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 12241 12242 BD_XT_FLD(bd_idx,i) = AT_Tbl_Idx; 12243 BD_XT_IDX(bd_idx,i) = tmp_idx; 12244 12245 12246 tmp_idx = gen_compiler_tmp(line, col, Shared, TRUE); 12247 ATD_TYPE_IDX(tmp_idx) = SA_INTEGER_DEFAULT_TYPE; 12248 ATD_STOR_BLK_IDX(tmp_idx) = stor_blk_idx; 12249 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 12250 12251 BD_UB_FLD(bd_idx,i) = AT_Tbl_Idx; 12252 BD_UB_IDX(bd_idx,i) = tmp_idx; 12253 } 12254 12255 tmp_idx = gen_compiler_tmp(line, col, Shared, TRUE); 12256 ATD_TYPE_IDX(tmp_idx) = SA_INTEGER_DEFAULT_TYPE; 12257 ATD_STOR_BLK_IDX(tmp_idx) = stor_blk_idx; 12258 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 12259 12260 BD_SM_FLD(bd_idx,i) = AT_Tbl_Idx; 12261 BD_SM_IDX(bd_idx,i) = tmp_idx; 12262 } 12263 12264 tmp_idx = gen_compiler_tmp(line, col, Shared, TRUE); 12265 ATD_TYPE_IDX(tmp_idx) = SA_INTEGER_DEFAULT_TYPE; 12266 ATD_STOR_BLK_IDX(tmp_idx) = stor_blk_idx; 12267 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 12268 12269 BD_LEN_FLD(bd_idx) = AT_Tbl_Idx; 12270 BD_LEN_IDX(bd_idx) = tmp_idx; 12271 12272 12273 BD_FLOW_DEPENDENT(bd_idx) = TRUE; 12274 12275 bd_idx = ntr_array_in_bd_tbl(bd_idx); 12276 12277 TRACE (Func_Exit, "set_up_bd_tmps", NULL); 12278 12279 return(bd_idx); 12280 12281 } /* set_up_bd_tmps */ 12282 12283 /******************************************************************************\ 12284 |* *| 12285 |* Description: *| 12286 |* <description> *| 12287 |* *| 12288 |* Input parameters: *| 12289 |* NONE *| 12290 |* *| 12291 |* Output parameters: *| 12292 |* NONE *| 12293 |* *| 12294 |* Returns: *| 12295 |* NOTHING *| 12296 |* *| 12297 \******************************************************************************/ 12298 12299 int gen_tmp_equal_max_zero(opnd_type *opnd, 12300 int type_idx, 12301 int entry_idx, 12302 boolean is_symbolic_constant, 12303 boolean is_interface) 12304 12305 { 12306 int column; 12307 int defining_attr; 12308 int line; 12309 int list_idx; 12310 int max_idx; 12311 int sh_idx; 12312 int tmp_idx; 12313 int zero_idx; 12314 12315 12316 TRACE (Func_Entry, "gen_tmp_equal_max_zero", NULL); 12317 12318 /* Generate tmp = max(0, extent) */ 12319 12320 line = OPND_LINE_NUM((*opnd)); 12321 column = OPND_COL_NUM((*opnd)); 12322 12323 NTR_IR_TBL(max_idx); 12324 IR_OPR(max_idx) = Max_Opr; 12325 IR_TYPE_IDX(max_idx) = type_idx; 12326 IR_LINE_NUM(max_idx) = line; 12327 IR_COL_NUM(max_idx) = column; 12328 IR_LIST_CNT_L(max_idx) = 2; 12329 12330 NTR_IR_LIST_TBL(list_idx); 12331 IR_FLD_L(max_idx) = IL_Tbl_Idx; 12332 IR_IDX_L(max_idx) = list_idx; 12333 12334 COPY_OPND(IL_OPND(list_idx), (*opnd)); 12335 12336 NTR_IR_LIST_TBL(zero_idx); 12337 IL_NEXT_LIST_IDX(list_idx) = zero_idx; 12338 IL_PREV_LIST_IDX(zero_idx) = list_idx; 12339 IL_FLD(zero_idx) = CN_Tbl_Idx; 12340 IL_IDX(zero_idx) = CN_INTEGER_ZERO_IDX; 12341 IL_LINE_NUM(zero_idx) = line; 12342 IL_COL_NUM(zero_idx) = column; 12343 12344 if (OPND_FLD((*opnd)) == AT_Tbl_Idx && 12345 AT_OBJ_CLASS(OPND_IDX((*opnd))) == Data_Obj && 12346 ATD_CLASS(OPND_IDX((*opnd))) == Compiler_Tmp) { 12347 defining_attr = ATD_DEFINING_ATTR_IDX(OPND_IDX((*opnd))); 12348 } 12349 else { 12350 defining_attr = NULL_IDX; 12351 } 12352 12353 if (is_symbolic_constant) { 12354 IR_OPR(max_idx) = Symbolic_Max_Opr; 12355 OPND_FLD((*opnd)) = AT_Tbl_Idx; 12356 OPND_IDX((*opnd)) = gen_compiler_tmp(line, 12357 column, 12358 Priv, TRUE); 12359 12360 ATD_TYPE_IDX(OPND_IDX((*opnd))) = type_idx; 12361 ATD_FLD(OPND_IDX((*opnd))) = IR_Tbl_Idx; 12362 ATD_TMP_IDX(OPND_IDX((*opnd))) = max_idx; 12363 ATD_SYMBOLIC_CONSTANT(OPND_IDX((*opnd))) = TRUE; 12364 ATD_DEFINING_ATTR_IDX(OPND_IDX((*opnd))) = defining_attr; 12365 } 12366 else { 12367 OPND_FLD((*opnd)) = IR_Tbl_Idx; 12368 OPND_IDX((*opnd)) = max_idx; 12369 12370 12371 if (!is_interface) { 12372 sh_idx = ntr_sh_tbl(); 12373 SH_STMT_TYPE(sh_idx) = Automatic_Base_Size_Stmt; 12374 SH_GLB_LINE(sh_idx) = line; 12375 SH_COL_NUM(sh_idx) = column; 12376 SH_COMPILER_GEN(sh_idx)= TRUE; 12377 SH_P2_SKIP_ME(sh_idx) = TRUE; 12378 } 12379 12380 tmp_idx = ntr_bnds_sh_tmp_list(opnd, 12381 entry_idx, 12382 (is_interface) ? NULL_IDX : sh_idx, 12383 FALSE, 12384 type_idx); 12385 OPND_FLD((*opnd)) = AT_Tbl_Idx; 12386 OPND_IDX((*opnd)) = tmp_idx; 12387 ATD_DEFINING_ATTR_IDX(tmp_idx) = defining_attr; 12388 } 12389 12390 TRACE (Func_Exit, "gen_tmp_equal_max_zero", NULL); 12391 12392 return(max_idx); 12393 12394 } /* gen_tmp_equal_max_zero */ 12395 12396 /******************************************************************************\ 12397 |* *| 12398 |* Description: *| 12399 |* <description> *| 12400 |* *| 12401 |* Input parameters: *| 12402 |* NONE *| 12403 |* *| 12404 |* Output parameters: *| 12405 |* NONE *| 12406 |* *| 12407 |* Returns: *| 12408 |* NOTHING *| 12409 |* *| 12410 \******************************************************************************/ 12411 static boolean compare_darg_or_rslt_types(int idx1, 12412 int idx2) 12413 { 12414 boolean intrin1; 12415 boolean intrin2; 12416 int linear_type1; 12417 int linear_type2; 12418 int rank1; 12419 int rank2; 12420 boolean same = TRUE; 12421 12422 12423 TRACE (Func_Entry, "compare_darg_or_rslt_types", NULL); 12424 12425 intrin1 = (ATD_CLASS(idx1) == Dummy_Argument) && ATD_INTRIN_DARG(idx1); 12426 intrin2 = (ATD_CLASS(idx2) == Dummy_Argument) && ATD_INTRIN_DARG(idx2); 12427 12428 if (intrin1 || intrin2) { 12429 rank1 = (ATD_ARRAY_IDX(idx1) == NULL_IDX) ? 12430 0 : BD_RANK(ATD_ARRAY_IDX(idx1)); 12431 rank2 = (ATD_ARRAY_IDX(idx2) == NULL_IDX) ? 12432 0 : BD_RANK(ATD_ARRAY_IDX(idx2)); 12433 12434 if (!intrin1) { 12435 12436 if (TYP_TYPE(ATD_TYPE_IDX(idx1)) == Character || 12437 TYP_TYPE(ATD_TYPE_IDX(idx1)) == Structure) { 12438 same = FALSE; 12439 goto DONE; 12440 } 12441 12442 linear_type1 = TYP_LINEAR(ATD_TYPE_IDX(idx1)); 12443 linear_type1 = 1 << linear_type1; 12444 } 12445 else { 12446 linear_type1 = ATD_INTRIN_DARG_TYPE(idx1); 12447 } 12448 12449 if (!intrin2) { 12450 12451 if (TYP_TYPE(ATD_TYPE_IDX(idx2)) == Character || 12452 TYP_TYPE(ATD_TYPE_IDX(idx2)) == Structure) { 12453 same = FALSE; 12454 goto DONE; 12455 } 12456 12457 linear_type2 = TYP_LINEAR(ATD_TYPE_IDX(idx2)); 12458 linear_type2 = 1 << linear_type2; 12459 } 12460 else { 12461 linear_type2 = ATD_INTRIN_DARG_TYPE(idx2); 12462 } 12463 12464 if ((linear_type1 & linear_type2) == 0) { 12465 same = FALSE; 12466 } 12467 12468 if (rank1 != rank2) { 12469 same = FALSE; 12470 } 12471 } 12472 else { 12473 12474 if (TYP_TYPE(ATD_TYPE_IDX(idx1)) != TYP_TYPE(ATD_TYPE_IDX(idx2))){ 12475 same = FALSE; 12476 } 12477 else if (TYP_TYPE(ATD_TYPE_IDX(idx1)) == Structure && 12478 !compare_derived_types(ATD_TYPE_IDX(idx1), ATD_TYPE_IDX(idx2))) { 12479 same = FALSE; 12480 } 12481 else if (TYP_TYPE(ATD_TYPE_IDX(idx1)) != Character && 12482 TYP_TYPE(ATD_TYPE_IDX(idx1)) != Structure && 12483 TYP_LINEAR(ATD_TYPE_IDX(idx1)) != 12484 TYP_LINEAR(ATD_TYPE_IDX(idx2))) { 12485 same = FALSE; 12486 } 12487 12488 if (same) { 12489 rank1 = (ATD_ARRAY_IDX(idx1) == NULL_IDX) ? 12490 0 : BD_RANK(ATD_ARRAY_IDX(idx1)); 12491 rank2 = (ATD_ARRAY_IDX(idx2) == NULL_IDX) ? 12492 0 : BD_RANK(ATD_ARRAY_IDX(idx2)); 12493 12494 if (rank1 != rank2) { 12495 same = FALSE; 12496 } 12497 } 12498 12499 # if defined(COARRAY_FORTRAN) 12500 if (same){ 12501 rank1 = (ATD_PE_ARRAY_IDX(idx1) == NULL_IDX)? 12502 0 : BD_RANK(ATD_PE_ARRAY_IDX(idx1)); 12503 rank2 = (ATD_PE_ARRAY_IDX(idx2) == NULL_IDX) ? 12504 0 : BD_RANK(ATD_PE_ARRAY_IDX(idx2)); 12505 if (rank1 != rank2) { 12506 same = FALSE; 12507 } 12508 } 12509 # endif 12510 12511 } 12512 12513 DONE: 12514 12515 TRACE (Func_Exit, "compare_darg_or_rslt_types", NULL); 12516 12517 return(same); 12518 12519 } /* compare_darg_or_rslt_types */
1.7.6.1 
