|
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_driver.c 5.13 10/26/99 13:48:21\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 # include "s_driver.h" 00057 00058 00059 /*****************************************************************\ 00060 |* Function prototypes of static functions declared in this file *| 00061 \*****************************************************************/ 00062 00063 static void attr_link_resolution(void); 00064 static void check_and_allocate_common_storage(int); 00065 static boolean compare_global_args(int, int, int, int, int); 00066 static boolean compare_global_array(int, int, int); 00067 static boolean compare_global_derived_type(int, int, int); 00068 static boolean compare_global_type_rank(int, int, int, int, boolean); 00069 static void decl_semantics_driver(void); 00070 static void free_stmt_tmp_tbl(void); 00071 static void final_attr_semantics(int); 00072 static void final_decl_semantics(void); 00073 static void final_equivalence_semantics(void); 00074 static void find_host_associated_attrs_in_il(int); 00075 static void find_host_associated_attrs_in_ir(int); 00076 static void init_call_structs(void); 00077 static void pgm_unit_semantics(void); 00078 static void reset_stmt_tmp_tbl(void); 00079 static void storage_blk_resolution(void); 00080 00081 # if defined(GENERATE_WHIRL) 00082 static void gen_user_code_start_opr(void); 00083 static void insert_global_sh(void); 00084 # endif 00085 00086 # ifdef _SEPARATE_FUNCTION_RETURNS 00087 static void check_multiple_entry_func(void); 00088 # endif 00089 00090 00091 /***********************************\ 00092 |* Globals used only in this file *| 00093 \***********************************/ 00094 00095 static int symbolic_constant_array_list; 00096 00097 00098 /******************************************************************************\ 00099 |* *| 00100 |* Description: *| 00101 |* This procedure is the semantics pass driver. *| 00102 |* *| 00103 |* Input parameters: *| 00104 |* NONE *| 00105 |* *| 00106 |* Output parameters: *| 00107 |* NONE *| 00108 |* *| 00109 |* Returns: *| 00110 |* NOTHING *| 00111 |* *| 00112 |* Algorithm note: *| 00113 |* The global variable curr_scp_idx is saved and restored so that it can *| 00114 |* be used by the Semantics Pass routines and other utility routines *| 00115 |* are used by both passes. *| 00116 |* *| 00117 \******************************************************************************/ 00118 00119 void semantics_pass_driver (void) 00120 00121 { 00122 int save_curr_scp_idx; 00123 00124 00125 TRACE (Func_Entry, "semantics_pass_driver", NULL); 00126 00127 /* init_semantics_pass(); */ 00128 00129 init_call_structs(); 00130 00131 reset_stmt_tmp_tbl(); 00132 00133 /* reinitialize cdir_switches */ 00134 00135 init_directive(2); 00136 00137 save_curr_scp_idx = curr_scp_idx; 00138 pgm_unit_start_line = SH_GLB_LINE(SCP_FIRST_SH_IDX(curr_scp_idx)); 00139 00140 decl_semantics_driver(); 00141 00142 curr_scp_idx = save_curr_scp_idx; 00143 00144 # if defined(GENERATE_WHIRL) 00145 if (insert_global_directives && 00146 global_stmt_sh_idx != NULL_IDX) { 00147 00148 insert_global_sh(); 00149 } 00150 # endif 00151 pgm_unit_semantics(); 00152 00153 curr_scp_idx = save_curr_scp_idx; 00154 00155 PRINT_EQV_TBL; 00156 00157 TBL_FREE(equiv_tbl); 00158 00159 /* free up the call site tables */ 00160 00161 if (arg_list != NULL) { 00162 MEM_FREE(arg_list); 00163 arg_list = NULL; 00164 arg_list_size = 0; 00165 } 00166 00167 if (arg_info_list != NULL) { 00168 MEM_FREE(arg_info_list); 00169 arg_info_list = NULL; 00170 arg_info_list_size = 0; 00171 } 00172 00173 /* free up the derived type compare table. */ 00174 00175 if (dt_cmp_tbl != NULL) { 00176 MEM_FREE(dt_cmp_tbl); 00177 dt_cmp_tbl = NULL; 00178 } 00179 00180 TRACE (Func_Exit, "semantics_pass_driver", NULL); 00181 00182 return; 00183 00184 } /* semantics_pass_driver */ 00185 00186 00187 /******************************************************************************\ 00188 |* *| 00189 |* Description: *| 00190 |* This procedure visits all SCP entries for the current scope and any *| 00191 |* contained scopes. It drives the semantic analysis of all statements *| 00192 |* by calling a semantic routine for each statement type (if the State- *| 00193 |* ment Header is not marked in error). *| 00194 |* *| 00195 |* Input parameters: *| 00196 |* NONE *| 00197 |* *| 00198 |* Output parameters: *| 00199 |* NONE *| 00200 |* *| 00201 |* Returns: *| 00202 |* NOTHING *| 00203 |* *| 00204 |* Algorithm note: *| 00205 |* If the current scope contains a child scope, this procedure is called *| 00206 |* recursively to process the child's statements. However, if the *| 00207 |* current scope has a sibling scope, the statements are processed by *| 00208 |* simply jumping to the top of this procedure. Recursion is not used *| 00209 |* for sibling scopes in order to reduce recursion on anticipated large *| 00210 |* modules that implement programming libraries with many module *| 00211 |* procedures in a single module (see for example the ISO Varying String *| 00212 |* Module). *| 00213 |* *| 00214 \******************************************************************************/ 00215 00216 static void pgm_unit_semantics (void) 00217 00218 { 00219 boolean actual_arg; 00220 boolean func_defined; 00221 boolean func_ptr_defined; 00222 int idx; 00223 boolean inline_it; 00224 boolean is_function; 00225 int pgm_attr_idx; 00226 int save_curr_scp_idx; 00227 int sh_idx; 00228 00229 00230 TRACE (Func_Entry, "pgm_unit_semantics", NULL); 00231 00232 PROCESS_SIBLING: 00233 00234 TRACE (PU_Start, NULL, "Semantics"); 00235 00236 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = TRUE; 00237 idx = SCP_ENTRY_IDX(curr_scp_idx); 00238 00239 while (idx) { 00240 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = TRUE; 00241 idx = AL_NEXT_IDX(idx); 00242 } 00243 00244 if (! SCP_IN_ERR(curr_scp_idx) ) { 00245 00246 /* clear out the stmt_tmp_tbl for reusing short lived tmps. */ 00247 00248 free_stmt_tmp_tbl(); 00249 00250 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 00251 comp_phase = Pass2_Semantics; 00252 00253 while (curr_stmt_sh_idx != NULL_IDX) { 00254 00255 if (SH_STMT_TYPE(curr_stmt_sh_idx) == Statement_Num_Stmt) { 00256 00257 /* Set statement_number from the SH_PARENT_BLK_IDX field, get the */ 00258 /* line and column for the last character of a DO loop */ 00259 /* (stmt_end_line and stmt_end_col are only used to produce the */ 00260 /* CIF Loop Definition record as of now), and delete the */ 00261 /* Statement_Number SH. */ 00262 00263 stmt_end_line = SH_GLB_LINE(curr_stmt_sh_idx); 00264 stmt_end_col = SH_COL_NUM(curr_stmt_sh_idx); 00265 statement_number = SH_PARENT_BLK_IDX(curr_stmt_sh_idx); 00266 sh_idx = curr_stmt_sh_idx; 00267 SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx); 00268 SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx); 00269 curr_stmt_sh_idx = SH_NEXT_IDX(sh_idx); 00270 FREE_SH_NODE(sh_idx); 00271 continue; 00272 } 00273 00274 TRACE_NEW_STMT ("Semantics"); 00275 00276 sh_idx = curr_stmt_sh_idx; 00277 00278 if (!SH_ERR_FLG(curr_stmt_sh_idx) && 00279 !SH_P2_SKIP_ME(curr_stmt_sh_idx)) { 00280 stmt_type = SH_STMT_TYPE(curr_stmt_sh_idx); 00281 stmt_start_line = SH_GLB_LINE(curr_stmt_sh_idx); 00282 stmt_start_col = SH_COL_NUM(curr_stmt_sh_idx); 00283 00284 (*stmt_semantics[SH_STMT_TYPE(curr_stmt_sh_idx)])(); 00285 } 00286 else if (SH_STMT_TYPE(curr_stmt_sh_idx) == End_Where_Stmt) { 00287 /* must go to the end where stmt semantics routine anyway */ 00288 /* since it does clean up for the where block (and nothing*/ 00289 /* else ). */ 00290 00291 stmt_type = SH_STMT_TYPE(curr_stmt_sh_idx); 00292 stmt_start_line = SH_GLB_LINE(curr_stmt_sh_idx); 00293 stmt_start_col = SH_COL_NUM(curr_stmt_sh_idx); 00294 00295 (*stmt_semantics[SH_STMT_TYPE(curr_stmt_sh_idx)])(); 00296 } 00297 00298 /* reset expression descriptor tables to zero */ 00299 00300 arg_info_list_base = NULL_IDX; 00301 arg_info_list_top = NULL_IDX; 00302 00303 if (SH_DOALL_LOOP_END(sh_idx)) { 00304 doall_end_semantics(); 00305 } 00306 00307 if (SH_LOOP_END(sh_idx)) { 00308 gen_loop_end_ir(); 00309 } 00310 00311 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 00312 } 00313 00314 final_decl_semantics(); 00315 00316 PRINT_DBG_SYTB; /* Print scp if SCP_DBG_PRINT_SYTB = TRUE */ 00317 PRINT_DBG_STMT; /* Print scp if SCP_DBG_PRINT_STMT = TRUE */ 00318 } 00319 else if (cif_flags & BASIC_RECS) { 00320 00321 /* CIF still wants output, even if the scope is in error. */ 00322 /* Check CIF option to see if symbol table needs to be written to CIF. */ 00323 /* Need to use BASIC_RECS to output the Entry Info and Common Block */ 00324 /* records if the user just specifies "-cf". */ 00325 00326 cif_send_sytb(); 00327 } 00328 00329 if (SCP_FIRST_CHILD_IDX(curr_scp_idx) != NULL_IDX) { 00330 save_curr_scp_idx = curr_scp_idx; 00331 curr_scp_idx = SCP_FIRST_CHILD_IDX(curr_scp_idx); 00332 pgm_unit_semantics(); 00333 curr_scp_idx = save_curr_scp_idx; 00334 } 00335 00336 /* if this scope is a function, check if the result var has been defined */ 00337 /* if the function is a pointer, check that the pointer as been assigned */ 00338 /* or allocated. Clear ATP_SCP_ALIVE. */ 00339 00340 pgm_attr_idx = SCP_ATTR_IDX(curr_scp_idx); 00341 ATP_SCP_ALIVE(pgm_attr_idx) = FALSE; 00342 is_function = FALSE; 00343 00344 if (ATP_PGM_UNIT(pgm_attr_idx) == Function && 00345 ! AT_DCL_ERR(pgm_attr_idx) && 00346 ! SCP_IN_ERR(curr_scp_idx)) { 00347 00348 is_function = TRUE; 00349 func_defined = AT_DEFINED(pgm_attr_idx); 00350 actual_arg = AT_ACTUAL_ARG(pgm_attr_idx) || 00351 AT_ACTUAL_ARG(ATP_RSLT_IDX(pgm_attr_idx)); 00352 func_ptr_defined = ATD_PTR_ASSIGNED(ATP_RSLT_IDX(pgm_attr_idx)); 00353 } 00354 00355 idx = SCP_ENTRY_IDX(curr_scp_idx); 00356 00357 inline_it = (opt_flags.inline_lvl > Inline_Lvl_0) || 00358 ATP_MAY_INLINE(pgm_attr_idx); 00359 00360 /* We keep more ir than we actually write out. In the case of */ 00361 /* internal procedures, we want to use the current compile. */ 00362 00363 /* KAY To get rid of the forward reference problem, we need */ 00364 /* to search for the internal procedures in the inline file, */ 00365 /* like we do with the module procedures. We can get the name */ 00366 /* of the internal procedure's parent from the mangled procedure */ 00367 /* name and search for it and then fill in the ATP_FIRST_SH_IDX. */ 00368 00369 while (idx) { 00370 00371 if (is_function) { 00372 func_defined |= AT_DEFINED(AL_ATTR_IDX(idx)); 00373 actual_arg |= AT_ACTUAL_ARG(AL_ATTR_IDX(idx)) || 00374 AT_ACTUAL_ARG(ATP_RSLT_IDX(AL_ATTR_IDX(idx))); 00375 func_ptr_defined |=ATD_PTR_ASSIGNED(ATP_RSLT_IDX(AL_ATTR_IDX(idx))); 00376 } 00377 00378 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE; 00379 ATP_FIRST_SH_IDX(AL_ATTR_IDX(idx)) = (inline_it) ? 00380 SCP_FIRST_SH_IDX(curr_scp_idx) : NULL_IDX; 00381 idx = AL_NEXT_IDX(idx); 00382 00383 } 00384 00385 if (is_function && !actual_arg) { 00386 00387 if (!func_defined) { 00388 PRINTMSG(AT_DEF_LINE(ATP_RSLT_IDX(pgm_attr_idx)), 287, Warning, 00389 AT_DEF_COLUMN(ATP_RSLT_IDX(pgm_attr_idx)), 00390 AT_OBJ_NAME_PTR(ATP_RSLT_IDX(pgm_attr_idx))); 00391 } 00392 else if (ATD_POINTER(ATP_RSLT_IDX(pgm_attr_idx)) && !func_ptr_defined){ 00393 PRINTMSG(AT_DEF_LINE(ATP_RSLT_IDX(pgm_attr_idx)), 918, Warning, 00394 AT_DEF_COLUMN(ATP_RSLT_IDX(pgm_attr_idx)), 00395 AT_OBJ_NAME_PTR(ATP_RSLT_IDX(pgm_attr_idx))); 00396 } 00397 } 00398 00399 if (ATP_PGM_UNIT(pgm_attr_idx) != Module) { 00400 ATP_FIRST_SH_IDX(pgm_attr_idx) = inline_it?SCP_FIRST_SH_IDX(curr_scp_idx): 00401 NULL_IDX; 00402 } 00403 00404 if (SCP_SIBLING_IDX(curr_scp_idx) != NULL_IDX) { 00405 curr_scp_idx = SCP_SIBLING_IDX(curr_scp_idx); 00406 goto PROCESS_SIBLING; 00407 } 00408 00409 TRACE (Func_Exit, "pgm_unit_semantics", NULL); 00410 00411 return; 00412 00413 } /* pgm_unit_semantics */ 00414 00415 00416 /******************************************************************************\ 00417 |* *| 00418 |* Description: *| 00419 |* This is the driver for decl_semantics. All scopes are processed. *| 00420 |* NOTE: The assumption is made that we go from outer scope to inner *| 00421 |* scope. decl_semantics, name resolution and assign storage *| 00422 |* all require this. *| 00423 |* *| 00424 |* Input parameters: *| 00425 |* NONE *| 00426 |* *| 00427 |* Output parameters: *| 00428 |* NONE *| 00429 |* *| 00430 |* Returns: *| 00431 |* NOTHING *| 00432 |* *| 00433 \******************************************************************************/ 00434 00435 static void decl_semantics_driver(void) 00436 00437 { 00438 int idx; 00439 int save_curr_scp_idx; 00440 00441 TRACE (Func_Entry, "decl_semantics_driver", NULL); 00442 00443 PROCESS_SIBLING: 00444 00445 comp_phase = Decl_Semantics; 00446 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = TRUE; 00447 idx = SCP_ENTRY_IDX(curr_scp_idx); 00448 00449 while (idx) { 00450 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = TRUE; 00451 idx = AL_NEXT_IDX(idx); 00452 } 00453 00454 # if defined(GENERATE_WHIRL) 00455 gen_user_code_start_opr(); 00456 # endif 00457 00458 if (! SCP_IN_ERR(curr_scp_idx) ) { 00459 attr_link_resolution(); 00460 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 00461 stmt_start_line = SH_GLB_LINE(curr_stmt_sh_idx); 00462 stmt_start_col = SH_COL_NUM(curr_stmt_sh_idx); 00463 need_new_sh = TRUE; 00464 00465 decl_semantics(); 00466 00467 if (cif_flags & BASIC_RECS) { 00468 cif_scope_info_rec(); 00469 } 00470 00471 # ifdef _SEPARATE_FUNCTION_RETURNS 00472 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function && 00473 SCP_ALT_ENTRY_CNT(curr_scp_idx) != 0 && 00474 !ATD_IM_A_DOPE(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx))) && 00475 ATD_ARRAY_IDX(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx))) == NULL_IDX && 00476 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx)))) 00477 != Structure && 00478 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx)))) 00479 != Character) { 00480 00481 check_multiple_entry_func(); 00482 } 00483 # endif 00484 00485 } 00486 00487 if (SCP_FIRST_CHILD_IDX(curr_scp_idx) != NULL_IDX) { 00488 save_curr_scp_idx = curr_scp_idx; 00489 curr_scp_idx = SCP_FIRST_CHILD_IDX(curr_scp_idx); 00490 decl_semantics_driver(); 00491 curr_scp_idx = save_curr_scp_idx; 00492 } 00493 00494 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 00495 00496 idx = SCP_ENTRY_IDX(curr_scp_idx); 00497 00498 while (idx) { 00499 00500 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE; 00501 idx = AL_NEXT_IDX(idx); 00502 } 00503 00504 if (SCP_SIBLING_IDX(curr_scp_idx) != NULL_IDX) { 00505 curr_scp_idx = SCP_SIBLING_IDX(curr_scp_idx); 00506 goto PROCESS_SIBLING; 00507 } 00508 00509 00510 TRACE (Func_Exit, "decl_semantics_driver", NULL); 00511 00512 return; 00513 00514 } /* decl_semantics_driver */ 00515 00516 /******************************************************************************\ 00517 |* *| 00518 |* Description: *| 00519 |* This procedure should never be called. Its only purpose is to issue *| 00520 |* an internal error message if a bad (0) value of curr_stmt_sh_idx is *| 00521 |* encountered. *| 00522 |* *| 00523 |* Input parameters: *| 00524 |* NONE *| 00525 |* *| 00526 |* Output parameters: *| 00527 |* NONE *| 00528 |* *| 00529 |* Returns: *| 00530 |* NOTHING *| 00531 |* *| 00532 \******************************************************************************/ 00533 00534 void illegal_stmt_type (void) 00535 00536 { 00537 00538 TRACE (Func_Entry, "illegal_stmt_type", NULL); 00539 00540 PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 263, Internal, 0); 00541 00542 TRACE (Func_Exit, "illegal_stmt_type", NULL); 00543 00544 return; 00545 00546 } /* illegal_stmt_type */ 00547 00548 00549 /******************************************************************************\ 00550 |* *| 00551 |* Description: *| 00552 |* This procedure should never be called. Its only purpose is to issue *| 00553 |* an internal error message if a Statement Header is encountered for *| 00554 |* which there is no semantic routine. *| 00555 |* *| 00556 |* Input parameters: *| 00557 |* NONE *| 00558 |* *| 00559 |* Output parameters: *| 00560 |* NONE *| 00561 |* *| 00562 |* Returns: *| 00563 |* NOTHING *| 00564 |* *| 00565 \******************************************************************************/ 00566 00567 void no_semantics_routine (void) 00568 00569 { 00570 00571 TRACE (Func_Entry, "no_semantics_routine", NULL); 00572 00573 PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 278, Internal, 0, 00574 stmt_type_str[stmt_type]); 00575 00576 TRACE (Func_Exit, "no_semantics_routine", NULL); 00577 00578 return; 00579 00580 } /* no_semantics_routine */ 00581 00582 /******************************************************************************\ 00583 |* *| 00584 |* Description: *| 00585 |* This routine goes through the local name table for the current scope. *| 00586 |* If the name is not locally defined(LN_DEF_LOC = FALSE), the host *| 00587 |* symbol tables are researched to make sure that AT_ATTR_LINK is *| 00588 |* pointing to the correct attribute entry. *| 00589 |* *| 00590 |* Input parameters: *| 00591 |* NONE *| 00592 |* *| 00593 |* Output parameters: *| 00594 |* NONE *| 00595 |* *| 00596 |* Returns: *| 00597 |* NONE *| 00598 |* *| 00599 \******************************************************************************/ 00600 static void attr_link_resolution(void) 00601 { 00602 int attr_idx; 00603 int host_idx; 00604 int host_name_idx; 00605 int local_attr_idx; 00606 int local_name_idx; 00607 int name_idx; 00608 int rslt_idx; 00609 int save_curr_scp_idx; 00610 boolean save_host_dcl_err; 00611 int sn_idx; 00612 int ultimate_idx; 00613 int ultimate_scp_idx; 00614 00615 00616 TRACE (Func_Entry, "attr_link_resolution", NULL); 00617 00618 /* Do not need to go thru SCP_ATTR_LIST, because everything on that list */ 00619 /* should be resolved. At the end of pass1, it should be tmps and */ 00620 /* library calls. */ 00621 00622 for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 00623 name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) { 00624 00625 # ifdef _DEBUG 00626 if (name_idx < 0 || name_idx > loc_name_tbl_idx) { 00627 PRINTMSG(stmt_start_line, 34, Internal, stmt_start_col); 00628 } 00629 # endif 00630 00631 attr_idx = LN_ATTR_IDX(name_idx); 00632 # ifdef _DEBUG 00633 if (attr_idx <= 0 || attr_idx > attr_tbl_idx) { 00634 PRINTMSG(stmt_start_line, 34, Internal, stmt_start_col); 00635 } 00636 if (LN_NAME_IDX(name_idx) != AT_NAME_IDX(attr_idx)) { 00637 PRINTMSG(AT_DEF_LINE(attr_idx), 516, Internal, 00638 AT_DEF_COLUMN(attr_idx), 00639 AT_OBJ_NAME_PTR(attr_idx), 00640 name_idx, 00641 attr_idx); 00642 } 00643 # endif 00644 00645 if (AT_REFERENCED(attr_idx) != Not_Referenced) { 00646 AT_REFERENCED(attr_idx) = Referenced; 00647 } 00648 00649 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 00650 !AT_ACCESS_SET(attr_idx)) { 00651 00652 /* Set to default access */ 00653 00654 AT_PRIVATE(attr_idx) = AT_PRIVATE(SCP_ATTR_IDX(curr_scp_idx)); 00655 } 00656 00657 if (LN_DEF_LOC(name_idx)) { 00658 continue; 00659 } 00660 00661 host_idx = srch_host_sym_tbl(&name_pool[LN_NAME_IDX(name_idx)].name_char, 00662 LN_NAME_LEN(name_idx), 00663 &host_name_idx, 00664 FALSE); 00665 00666 if (host_idx == NULL_IDX) { 00667 AT_ATTR_LINK(attr_idx) = NULL_IDX; 00668 continue; 00669 } 00670 else if (IS_STMT_ENTITY(host_idx)) { 00671 00672 /* Don't host associate a stmt entity. */ 00673 00674 AT_ATTR_LINK(attr_idx) = NULL_IDX; 00675 continue; 00676 } 00677 00678 if (AT_OBJ_CLASS(attr_idx) == Derived_Type) { 00679 00680 /* Derived type host association */ 00681 00682 if ((AT_OBJ_CLASS(host_idx) != Derived_Type && 00683 !AT_DCL_ERR(attr_idx)) || 00684 AT_NOT_VISIBLE(attr_idx)) { 00685 save_host_dcl_err = AT_DCL_ERR(host_idx); 00686 fnd_semantic_err(Obj_Use_Derived_Type, 00687 AT_DEF_LINE(attr_idx), 00688 AT_DEF_COLUMN(attr_idx), 00689 host_idx, 00690 TRUE); 00691 AT_DCL_ERR(attr_idx) = TRUE; 00692 AT_DCL_ERR(host_idx) = save_host_dcl_err; 00693 host_idx = NULL_IDX; /* Break link */ 00694 } 00695 else if (AT_OBJ_CLASS(host_idx) == Derived_Type) { 00696 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 00697 AT_HOST_ASSOCIATED(host_idx) = TRUE; 00698 ATT_SCP_IDX(attr_idx) = ATT_SCP_IDX(host_idx); 00699 } 00700 } 00701 else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) { 00702 ultimate_idx = host_idx; 00703 00704 while (AT_ATTR_LINK(ultimate_idx)) { 00705 ultimate_idx = AT_ATTR_LINK(ultimate_idx); 00706 } 00707 00708 /* Find the scope of the ultimate_idx */ 00709 00710 save_curr_scp_idx = curr_scp_idx; 00711 ultimate_scp_idx = curr_scp_idx; 00712 00713 while (1) { /* If scope is an interface block we're not here. */ 00714 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx); 00715 00716 if (curr_scp_idx == 0) { /* Intrinsic scope - exit */ 00717 ultimate_scp_idx = NULL_IDX; 00718 break; 00719 } 00720 00721 local_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(ultimate_idx), 00722 AT_NAME_LEN(ultimate_idx), 00723 &local_name_idx); 00724 00725 if (local_attr_idx == ultimate_idx) { 00726 ultimate_scp_idx = curr_scp_idx; 00727 break; 00728 } 00729 } 00730 00731 curr_scp_idx = save_curr_scp_idx; 00732 ATP_SCP_IDX(attr_idx) = ultimate_scp_idx; 00733 00734 /* if we can change the ultimate attr to a pgm unit we do */ 00735 00736 if (AT_OBJ_CLASS(ultimate_idx) == Data_Obj && 00737 ! AT_USE_ASSOCIATED(ultimate_idx)) { 00738 00739 if (!fnd_semantic_err((ATP_PGM_UNIT(attr_idx) == Subroutine ? 00740 Obj_Use_Extern_Subr : 00741 Obj_Use_Extern_Func), 00742 AT_DEF_LINE(ultimate_idx), 00743 AT_DEF_COLUMN(ultimate_idx), 00744 ultimate_idx, 00745 FALSE)) { /* Check - don't issue message */ 00746 00747 if (ATP_PGM_UNIT(attr_idx) == Function && 00748 ATD_CLASS(ultimate_idx) != Dummy_Argument && 00749 TYP_TYPE(ATD_TYPE_IDX(ultimate_idx)) == Character && 00750 TYP_CHAR_CLASS(ATD_TYPE_IDX(ultimate_idx)) == 00751 Assumed_Size_Char) { 00752 00753 /* This would be an illegal situation, so treat */ 00754 /* as if fnd_semantic_err returned TRUE. */ 00755 00756 /* Intentionally blank */ 00757 } 00758 else { 00759 chg_data_obj_to_pgm_unit(ultimate_idx, (pgm_unit_type) 00760 ATP_PGM_UNIT(attr_idx), 00761 Extern_Proc); 00762 ATP_SCP_IDX(ultimate_idx) = ultimate_scp_idx; 00763 00764 if (ATP_PGM_UNIT(ultimate_idx) == Function) { 00765 rslt_idx = ATP_RSLT_IDX(ultimate_idx); 00766 00767 if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX || 00768 ATD_IM_A_DOPE(rslt_idx) || 00769 TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Structure || 00770 TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character) { 00771 00772 ATP_EXTRA_DARG(ultimate_idx) = TRUE; 00773 00774 if (ATP_EXPL_ITRFC(ultimate_idx)) { 00775 ATD_STOR_BLK_IDX(rslt_idx) = 00776 SCP_SB_DARG_IDX(ATP_SCP_IDX(ultimate_idx)); 00777 00778 /* Insert the function result as the zero'th darg */ 00779 00780 if (ATP_FIRST_IDX(ultimate_idx) == NULL_IDX) { 00781 NTR_SN_TBL(sn_idx); 00782 } 00783 else { 00784 sn_idx = ATP_FIRST_IDX(ultimate_idx) - 1; 00785 } 00786 ATP_FIRST_IDX(ultimate_idx) = sn_idx; 00787 ATP_NUM_DARGS(ultimate_idx) += 1; 00788 SN_NAME_LEN(sn_idx) = AT_NAME_LEN(rslt_idx); 00789 SN_NAME_IDX(sn_idx) = AT_NAME_IDX(rslt_idx); 00790 SN_ATTR_IDX(sn_idx) = rslt_idx; 00791 SN_LINE_NUM(sn_idx) = AT_DEF_LINE(rslt_idx); 00792 SN_COLUMN_NUM(sn_idx) = AT_DEF_COLUMN(rslt_idx); 00793 } 00794 } 00795 } 00796 } 00797 } 00798 } 00799 } 00800 00801 if (attr_idx == host_idx) { 00802 PRINTMSG(AT_DEF_LINE(attr_idx), 72, Internal, AT_DEF_COLUMN(attr_idx), 00803 AT_OBJ_NAME_PTR(attr_idx), attr_idx); 00804 } 00805 00806 AT_ATTR_LINK(attr_idx) = host_idx; 00807 00808 host_associated_attr_semantics(attr_idx, FALSE); 00809 } 00810 00811 TRACE (Func_Exit, "attr_link_resolution", NULL); 00812 00813 return; 00814 00815 } /* attr_link_resolution */ 00816 00817 /******************************************************************************\ 00818 |* *| 00819 |* Description: *| 00820 |* This routine handles the storage blocks for host associated attrs. *| 00821 |* All static storage blocks that will be host associated are copied *| 00822 |* and linked into the current scope. There is no link in either *| 00823 |* direction. The attr still points to the original storage block. *| 00824 |* The storage block needs to be put into the current scope so that it *| 00825 |* can be resolved by storage_blk_resolution before final_decl_semantics *| 00826 |* During the PDGCS interface, when an attribute is sent across that *| 00827 |* references a storage block, not in the current scope, the current *| 00828 |* is searched for the storage block. Then this is the block sent to *| 00829 |* PDG. PDG_SB_IDX is updated for both the blocks so that the search *| 00830 |* only has to be done once per block in a program unit. *| 00831 |* See send_stor_blk in i_cvrt.c for more details. *| 00832 |* *| 00833 |* Input parameters: *| 00834 |* attr_idx => The host associated attr with the stor blk that needs *| 00835 |* resolving. *| 00836 |* *| 00837 |* Output parameters: *| 00838 |* NONE *| 00839 |* *| 00840 |* Returns: *| 00841 |* NONE *| 00842 |* *| 00843 \******************************************************************************/ 00844 void host_associated_attr_semantics(int attr_idx, 00845 boolean add_to_attr_list) 00846 00847 { 00848 int bd_idx; 00849 boolean defined; 00850 int dim; 00851 int eq_idx; 00852 int first_eq; 00853 int group_idx; 00854 int il_idx; 00855 int local_attr_idx; 00856 int local_sb_idx; 00857 id_str_type name; 00858 int name_idx; 00859 char *name_ptr; 00860 int new_attr_idx; 00861 int new_host_assoc = FALSE; 00862 int new_scp; 00863 int new_sn_idx; 00864 int referenced; 00865 int sb_idx; 00866 int sn_idx; 00867 int type_idx; 00868 00869 00870 TRACE (Func_Entry, "host_associated_attr_semantics", NULL); 00871 00872 /* Do not need to accumulate referenced and defined flags from */ 00873 /* intermediate attrs, because when each attr is processed, its */ 00874 /* flags are set into the original attr. Save the flags, so they */ 00875 /* can be set if the attr is host associated. */ 00876 00877 referenced = AT_REFERENCED(attr_idx); 00878 defined = AT_DEFINED(attr_idx); 00879 local_attr_idx = attr_idx; 00880 00881 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 00882 attr_idx = AT_ATTR_LINK(attr_idx); 00883 } 00884 00885 switch (AT_OBJ_CLASS(attr_idx)) { 00886 case Data_Obj: 00887 00888 if (ATD_CLASS(attr_idx) == Constant) { 00889 00890 /* If this is a structure or array, make sure the tmp associated */ 00891 /* with the structure constructor is host associated. At the */ 00892 /* moment stuff needs to be filled in for the temp, so just make */ 00893 /* sure that the storage block gets created in the local scope. */ 00894 00895 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) { 00896 host_associated_attr_semantics(ATD_CONST_IDX(attr_idx), TRUE); 00897 00898 if (referenced) { 00899 AT_REFERENCED(ATD_CONST_IDX(attr_idx)) = Referenced; 00900 } 00901 } 00902 break; 00903 } 00904 00905 # if defined(GENERATE_WHIRL) 00906 if (ATD_IM_A_DOPE(attr_idx) && 00907 ATD_CLASS(attr_idx) == Dummy_Argument && 00908 ATD_ARRAY_IDX(attr_idx) && 00909 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape && 00910 ATD_SF_ARG_IDX(attr_idx) != NULL_IDX) { 00911 00912 host_associated_attr_semantics(ATD_SF_ARG_IDX(attr_idx), TRUE); 00913 00914 if (referenced) { 00915 AT_REFERENCED(ATD_SF_ARG_IDX(attr_idx)) = Referenced; 00916 } 00917 } 00918 # endif 00919 00920 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 00921 00922 if (sb_idx == NULL_IDX || SB_SCP_IDX(sb_idx) == curr_scp_idx) { 00923 break; 00924 } 00925 00926 /* The only FUNCTION results that can be host associated are those */ 00927 /* that are parents of the current program unit. If this is a */ 00928 /* reference to a pgm_unit defined in an interface block or in a */ 00929 /* sibling, this is a call to the program unit. That causes new */ 00930 /* tmps to be created. */ 00931 00932 if (ATD_CLASS(attr_idx) == Function_Result && 00933 !ATP_SCP_ALIVE(ATD_FUNC_IDX(attr_idx))) { 00934 break; 00935 } 00936 00937 switch (SB_BLK_TYPE(sb_idx)) { 00938 case Common: 00939 case Task_Common: 00940 case Threadprivate: 00941 00942 /* These are NOT host associated. The storage block is copied into */ 00943 /* the scope and these are treated as if the block was declared in */ 00944 /* each program unit. Copy the attr down and break the link. */ 00945 00946 local_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 00947 SB_NAME_LEN(sb_idx), 00948 curr_scp_idx); 00949 if (local_sb_idx != NULL_IDX && 00950 SB_HOST_ASSOCIATED(local_sb_idx) && 00951 SB_ORIG_SCP_IDX(sb_idx) == SB_ORIG_SCP_IDX(local_sb_idx) && 00952 SB_ORIG_SCP_IDX(sb_idx) != NULL_IDX) { 00953 00954 /* This storage block has already been host associated into this */ 00955 /* scope. So do nothing. Intentionally blank. */ 00956 } 00957 else { 00958 TBL_REALLOC_CK(stor_blk_tbl, 1); 00959 stor_blk_tbl[stor_blk_tbl_idx] = stor_blk_tbl[sb_idx]; 00960 SB_ORIG_SCP_IDX(stor_blk_tbl_idx) = SB_SCP_IDX(sb_idx); 00961 SB_SCP_IDX(stor_blk_tbl_idx) = curr_scp_idx; 00962 SB_HOST_ASSOCIATED(stor_blk_tbl_idx) = TRUE; 00963 SB_COMMON_NEEDS_OFFSET(stor_blk_tbl_idx) = FALSE; 00964 00965 if (local_sb_idx != NULL_IDX) { 00966 SB_HIDDEN(stor_blk_tbl_idx) = TRUE; 00967 SB_MERGED_BLK_IDX(stor_blk_tbl_idx) = local_sb_idx; 00968 00969 if (!SB_USE_ASSOCIATED(local_sb_idx) || 00970 !SB_USE_ASSOCIATED(sb_idx) || 00971 SB_HAS_RENAMES(local_sb_idx) || 00972 SB_HAS_RENAMES(sb_idx) || 00973 (compare_names(AT_OBJ_NAME_LONG(SB_MODULE_IDX(local_sb_idx)), 00974 AT_NAME_LEN(SB_MODULE_IDX(local_sb_idx)), 00975 AT_OBJ_NAME_LONG(SB_MODULE_IDX(sb_idx)), 00976 AT_NAME_LEN(SB_MODULE_IDX(sb_idx))) != 0)) { 00977 SB_DEF_MULT_SCPS(stor_blk_tbl_idx) = TRUE; 00978 SB_DEF_MULT_SCPS(sb_idx) = TRUE; 00979 } 00980 } 00981 else if (SB_MODULE(stor_blk_tbl_idx)) { 00982 00983 if (SB_USE_ASSOCIATED(stor_blk_tbl_idx)) { 00984 ADD_ATTR_TO_LOCAL_LIST(SB_MODULE_IDX(stor_blk_tbl_idx)); 00985 } 00986 } 00987 local_sb_idx = stor_blk_tbl_idx; 00988 } 00989 break; 00990 00991 case Static: 00992 case Static_Local: 00993 case Static_Named: 00994 if (SB_BLK_TYPE(sb_idx) == Static) { 00995 00996 if (referenced) { 00997 AT_REFERENCED(attr_idx) = Referenced; 00998 AT_REF_IN_CHILD(attr_idx) = TRUE; 00999 } 01000 01001 if (defined) { 01002 AT_REF_IN_CHILD(attr_idx) = TRUE; 01003 } 01004 01005 } 01006 01007 /* These are NOT host associated. This item needs to be in the */ 01008 /* host associated storage block for its scope. */ 01009 01010 if (!SB_USE_ASSOCIATED(sb_idx) && 01011 (SB_BLK_TYPE(sb_idx) == Static_Local || 01012 SB_BLK_TYPE(sb_idx) == Static_Named)) { 01013 new_scp = SB_SCP_IDX(sb_idx); 01014 01015 if (SB_BLK_TYPE(sb_idx) == Static_Named) { 01016 01017 if (SCP_SB_HOSTED_DATA_IDX(new_scp) == NULL_IDX) { 01018 sb_idx = ntr_stor_blk_tbl( 01019 SB_NAME_PTR(SCP_SB_STATIC_INIT_IDX(curr_scp_idx)), 01020 SB_NAME_LEN(SCP_SB_STATIC_INIT_IDX(curr_scp_idx)), 01021 AT_DEF_LINE(attr_idx), 01022 AT_DEF_COLUMN(attr_idx), 01023 Static); 01024 01025 name_ptr = SB_NAME_PTR(sb_idx); 01026 name_ptr[1] = 'H'; 01027 name_ptr[2] = 'O'; 01028 name_ptr[3] = 'S'; 01029 name_ptr[4] = 'T'; 01030 01031 SB_SCP_IDX(sb_idx) = SB_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx)); 01032 SB_ORIG_SCP_IDX(sb_idx) = 01033 SB_ORIG_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx)); 01034 SB_HOSTED_STATIC(sb_idx) = TRUE; 01035 SCP_SB_HOSTED_DATA_IDX(new_scp) = sb_idx; 01036 local_sb_idx = NULL_IDX; 01037 } 01038 else { 01039 sb_idx = SCP_SB_HOSTED_DATA_IDX(new_scp); 01040 local_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 01041 SB_NAME_LEN(sb_idx), 01042 curr_scp_idx); 01043 } 01044 } 01045 else if (SCP_SB_HOSTED_STATIC_IDX(new_scp) == NULL_IDX) { 01046 sb_idx = ntr_stor_blk_tbl( 01047 SB_NAME_PTR(SCP_SB_STATIC_IDX(curr_scp_idx)), 01048 SB_NAME_LEN(SCP_SB_STATIC_IDX(curr_scp_idx)), 01049 AT_DEF_LINE(attr_idx), 01050 AT_DEF_COLUMN(attr_idx), 01051 Static); 01052 01053 name_ptr = SB_NAME_PTR(sb_idx); 01054 name_ptr[1] = 'H'; 01055 name_ptr[2] = 'O'; 01056 name_ptr[3] = 'S'; 01057 name_ptr[4] = 'T'; 01058 01059 SB_SCP_IDX(sb_idx) = SB_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx)); 01060 SB_ORIG_SCP_IDX(sb_idx) = 01061 SB_ORIG_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx)); 01062 SB_HOSTED_STATIC(sb_idx) = TRUE; 01063 SCP_SB_HOSTED_STATIC_IDX(new_scp)= sb_idx; 01064 local_sb_idx = NULL_IDX; 01065 } 01066 else { 01067 sb_idx = SCP_SB_HOSTED_STATIC_IDX(new_scp); 01068 local_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 01069 SB_NAME_LEN(sb_idx), 01070 curr_scp_idx); 01071 } 01072 01073 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 01074 01075 /* We've switched to a new storage block. If this object is */ 01076 /* equivalenced, we need to switch everything in this group */ 01077 /* to this new storage block. */ 01078 01079 if (ATD_EQUIV(attr_idx)) { 01080 group_idx = SCP_FIRST_EQUIV_GRP(new_scp); 01081 01082 while (group_idx != NULL_IDX) { 01083 eq_idx = group_idx; 01084 first_eq = eq_idx; 01085 group_idx = EQ_NEXT_EQUIV_GRP(group_idx); 01086 01087 while (eq_idx != NULL_IDX) { 01088 01089 if (EQ_ATTR_IDX(eq_idx) == attr_idx) { /* Found */ 01090 eq_idx = first_eq; 01091 group_idx = NULL_IDX; 01092 01093 while (eq_idx != NULL_IDX) { 01094 host_associated_attr_semantics(EQ_ATTR_IDX(eq_idx), 01095 FALSE); 01096 eq_idx = EQ_NEXT_EQUIV_OBJ(eq_idx); 01097 } 01098 } 01099 else { 01100 eq_idx = EQ_NEXT_EQUIV_OBJ(eq_idx); 01101 } 01102 } 01103 } 01104 } 01105 } 01106 else { 01107 local_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 01108 SB_NAME_LEN(sb_idx), 01109 curr_scp_idx); 01110 } 01111 01112 if (local_sb_idx != NULL_IDX && 01113 SB_HOST_ASSOCIATED(local_sb_idx) && 01114 SB_ORIG_SCP_IDX(sb_idx) == SB_ORIG_SCP_IDX(local_sb_idx) && 01115 SB_ORIG_SCP_IDX(sb_idx) != NULL_IDX) { 01116 01117 /* This storage block has already been host associated into this */ 01118 /* scope. So do nothing. Intentionally blank. */ 01119 } 01120 else { 01121 TBL_REALLOC_CK(stor_blk_tbl, 1); 01122 stor_blk_tbl[stor_blk_tbl_idx] = stor_blk_tbl[sb_idx]; 01123 SB_ORIG_SCP_IDX(stor_blk_tbl_idx) = SB_SCP_IDX(sb_idx); 01124 SB_SCP_IDX(stor_blk_tbl_idx) = curr_scp_idx; 01125 SB_HOST_ASSOCIATED(stor_blk_tbl_idx) = TRUE; 01126 SB_COMMON_NEEDS_OFFSET(stor_blk_tbl_idx) = FALSE; 01127 01128 if (local_sb_idx != NULL_IDX) { 01129 SB_HIDDEN(stor_blk_tbl_idx) = TRUE; 01130 SB_MERGED_BLK_IDX(stor_blk_tbl_idx) = local_sb_idx; 01131 01132 if (!SB_USE_ASSOCIATED(local_sb_idx) || 01133 !SB_USE_ASSOCIATED(sb_idx) || 01134 SB_HAS_RENAMES(local_sb_idx) || 01135 SB_HAS_RENAMES(sb_idx) || 01136 (compare_names(AT_OBJ_NAME_LONG(SB_MODULE_IDX(local_sb_idx)), 01137 AT_NAME_LEN(SB_MODULE_IDX(local_sb_idx)), 01138 AT_OBJ_NAME_LONG(SB_MODULE_IDX(sb_idx)), 01139 AT_NAME_LEN(SB_MODULE_IDX(sb_idx))) != 0)) { 01140 SB_DEF_MULT_SCPS(stor_blk_tbl_idx) = TRUE; 01141 SB_DEF_MULT_SCPS(sb_idx) = TRUE; 01142 } 01143 } 01144 else if (SB_MODULE(stor_blk_tbl_idx)) { 01145 01146 if (SB_USE_ASSOCIATED(stor_blk_tbl_idx)) { 01147 ADD_ATTR_TO_LOCAL_LIST(SB_MODULE_IDX(stor_blk_tbl_idx)); 01148 } 01149 if (!AT_HOST_ASSOCIATED(local_attr_idx)) { 01150 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 01151 AT_HOST_ASSOCIATED(local_attr_idx) = TRUE; 01152 } 01153 if (defined && ATD_CLASS(attr_idx) != Compiler_Tmp) { 01154 AT_DEFINED(attr_idx) = TRUE; 01155 AT_DEF_IN_CHILD(attr_idx) = TRUE; 01156 } 01157 01158 if (referenced) { 01159 AT_REFERENCED(attr_idx) = Referenced; 01160 AT_REF_IN_CHILD(attr_idx) = TRUE; 01161 } 01162 01163 } 01164 local_sb_idx = stor_blk_tbl_idx; 01165 } 01166 break; 01167 01168 case Stack: 01169 01170 if (!AT_HOST_ASSOCIATED(local_attr_idx)) { 01171 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 01172 AT_HOST_ASSOCIATED(local_attr_idx) = TRUE; 01173 new_host_assoc = TRUE; 01174 new_scp = SB_SCP_IDX(sb_idx); 01175 01176 if (SCP_SB_HOSTED_STACK_IDX(new_scp) == NULL_IDX) { 01177 CREATE_ID(name, sb_name[Stack_Host_Blk], sb_len[Stack_Host_Blk]); 01178 sb_idx = ntr_stor_blk_tbl(name.string, 01179 sb_len[Stack_Host_Blk], 01180 AT_DEF_LINE(attr_idx), 01181 AT_DEF_COLUMN(attr_idx), 01182 Stack); 01183 SB_SCP_IDX(sb_idx) = new_scp; 01184 SB_HOSTED_STACK(sb_idx) = TRUE; 01185 SCP_SB_HOSTED_STACK_IDX(new_scp) = sb_idx; 01186 } 01187 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_HOSTED_STACK_IDX(new_scp); 01188 } 01189 01190 /* If this is a compiler tmp, it should be a host associated */ 01191 /* bounds tmp. That means it is only referenced in the child. */ 01192 01193 if (defined && ATD_CLASS(attr_idx) != Compiler_Tmp) { 01194 AT_DEFINED(attr_idx) = TRUE; 01195 AT_DEF_IN_CHILD(attr_idx) = TRUE; 01196 } 01197 01198 if (referenced) { 01199 AT_REFERENCED(attr_idx) = Referenced; 01200 AT_REF_IN_CHILD(attr_idx) = TRUE; 01201 } 01202 01203 break; 01204 01205 case Equivalenced: 01206 01207 if (!AT_HOST_ASSOCIATED(local_attr_idx)) { 01208 new_host_assoc = TRUE; 01209 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 01210 AT_HOST_ASSOCIATED(local_attr_idx) = TRUE; 01211 } 01212 01213 AT_DEFINED(attr_idx) = AT_DEFINED(attr_idx) | defined; 01214 AT_DEF_IN_CHILD(attr_idx) = AT_DEF_IN_CHILD(attr_idx) | defined; 01215 SB_HOSTED_STACK(sb_idx) = TRUE; 01216 01217 if (referenced) { 01218 AT_REFERENCED(attr_idx) = Referenced; 01219 AT_REF_IN_CHILD(attr_idx) = TRUE; 01220 } 01221 01222 break; 01223 01224 case Formal: 01225 01226 if (!AT_HOST_ASSOCIATED(local_attr_idx)) { 01227 new_host_assoc = TRUE; 01228 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 01229 AT_HOST_ASSOCIATED(local_attr_idx) = TRUE; 01230 } 01231 01232 AT_DEFINED(attr_idx) = AT_DEFINED(attr_idx) | defined; 01233 AT_DEF_IN_CHILD(attr_idx) = AT_DEF_IN_CHILD(attr_idx) | defined; 01234 01235 if (referenced) { 01236 AT_REFERENCED(attr_idx) = Referenced; 01237 AT_REF_IN_CHILD(attr_idx) = TRUE; 01238 } 01239 break; 01240 01241 case Based: 01242 01243 if (ATD_AUTOMATIC(attr_idx)) { 01244 host_associated_attr_semantics(ATD_AUTO_BASE_IDX(attr_idx), TRUE); 01245 } 01246 else { /* Should be a Cray_Pointee */ 01247 host_associated_attr_semantics(ATD_PTR_IDX(attr_idx), TRUE); 01248 } 01249 01250 if (!AT_HOST_ASSOCIATED(local_attr_idx)) { 01251 new_host_assoc = TRUE; 01252 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 01253 AT_HOST_ASSOCIATED(local_attr_idx) = TRUE; 01254 } 01255 01256 AT_DEFINED(attr_idx) = AT_DEFINED(attr_idx) | defined; 01257 AT_DEF_IN_CHILD(attr_idx) = AT_DEF_IN_CHILD(attr_idx) | defined; 01258 01259 if (referenced) { 01260 AT_REFERENCED(attr_idx) = Referenced; 01261 AT_REF_IN_CHILD(attr_idx) = TRUE; 01262 } 01263 01264 /* Carry the local based storage on the local attr, so that it can */ 01265 /* be passed through the interface. We don't want to use the host */ 01266 01267 ATD_STOR_BLK_IDX(local_attr_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 01268 break; 01269 01270 default: 01271 01272 if (!AT_HOST_ASSOCIATED(local_attr_idx)) { 01273 new_host_assoc = TRUE; 01274 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 01275 AT_HOST_ASSOCIATED(local_attr_idx) = TRUE; 01276 } 01277 AT_DEFINED(attr_idx) = AT_DEFINED(attr_idx) | defined; 01278 AT_DEF_IN_CHILD(attr_idx) = AT_DEF_IN_CHILD(attr_idx) | defined; 01279 01280 if (referenced) { 01281 AT_REFERENCED(attr_idx) = Referenced; 01282 AT_REF_IN_CHILD(attr_idx) = TRUE; 01283 } 01284 break; 01285 } /* End switch */ 01286 01287 if (new_host_assoc) { /* This attr is now host associated */ 01288 01289 if (ATD_CLASS(attr_idx) == Variable && 01290 ATD_FLD(attr_idx) != NO_Tbl_Idx) { 01291 01292 /* This has data initialized tmps associated with it. These can */ 01293 /* get here if the attr is use associated and then hosted. */ 01294 01295 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) { 01296 host_associated_attr_semantics(ATD_VARIABLE_TMP_IDX(attr_idx), 01297 TRUE); 01298 } 01299 else if (ATD_FLD(attr_idx) == IL_Tbl_Idx) { 01300 01301 /* Must be structure - Have a list of tmps */ 01302 01303 il_idx = ATD_VARIABLE_TMP_IDX(attr_idx); 01304 01305 while (il_idx != NULL_IDX) { 01306 host_associated_attr_semantics(IL_IDX(il_idx), TRUE); 01307 il_idx = IL_NEXT_LIST_IDX(il_idx); 01308 } 01309 } 01310 } 01311 01312 type_idx = ATD_TYPE_IDX(attr_idx); 01313 01314 if (TYP_TYPE(type_idx) == Character && 01315 TYP_FLD(type_idx) == AT_Tbl_Idx) { 01316 host_associated_attr_semantics(TYP_IDX(type_idx), TRUE); 01317 } 01318 01319 bd_idx = ATD_ARRAY_IDX(attr_idx); 01320 01321 if (bd_idx != NULL_IDX && 01322 BD_ARRAY_SIZE(bd_idx) != Constant_Size && 01323 BD_ARRAY_SIZE(bd_idx) != Unknown_Size ) { 01324 01325 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 01326 01327 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01328 host_associated_attr_semantics(BD_LB_IDX(bd_idx, dim), TRUE); 01329 } 01330 01331 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01332 host_associated_attr_semantics(BD_UB_IDX(bd_idx, dim), TRUE); 01333 } 01334 01335 if (BD_XT_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01336 host_associated_attr_semantics(BD_XT_IDX(bd_idx, dim), TRUE); 01337 } 01338 01339 if (BD_SM_FLD(bd_idx, dim) == AT_Tbl_Idx) { 01340 host_associated_attr_semantics(BD_SM_IDX(bd_idx, dim), TRUE); 01341 } 01342 } 01343 01344 if (BD_LEN_FLD(bd_idx) == AT_Tbl_Idx) { 01345 host_associated_attr_semantics(BD_LEN_IDX(bd_idx), TRUE); 01346 } 01347 } 01348 } 01349 break; 01350 01351 case Pgm_Unit: 01352 01353 /* If ATP_SCP_ALIVE is set, then we are host associating the host's */ 01354 /* function result or we are calling the host. Since we don't know for */ 01355 /* sure what is going on, assume the function result is host associated.*/ 01356 01357 AT_DEFINED(attr_idx) = AT_DEFINED(attr_idx) | defined; 01358 AT_DEF_IN_CHILD(attr_idx) = AT_DEF_IN_CHILD(attr_idx) | defined; 01359 01360 if (referenced) { 01361 AT_REFERENCED(attr_idx) = Referenced; 01362 AT_REF_IN_CHILD(attr_idx) = TRUE; 01363 } 01364 01365 if (ATP_PGM_UNIT(attr_idx) == Function && 01366 ATP_SCP_ALIVE(attr_idx) && !ATP_RSLT_NAME(attr_idx)) { 01367 host_associated_attr_semantics(ATP_RSLT_IDX(attr_idx), FALSE); 01368 } 01369 break; 01370 01371 case Namelist_Grp: 01372 01373 COPY_ATTR_NTRY(local_attr_idx, attr_idx); 01374 01375 /* Note that AT_CIF_SYMBOL_ID remains as the symbol id of the name in */ 01376 /* the host. We need this to make all references resolve to the host */ 01377 /* so that CIF processing only sees one namelist group name (the one in */ 01378 /* the host). */ 01379 01380 AT_ATTR_LINK(local_attr_idx) = NULL_IDX; 01381 AT_REFERENCED(local_attr_idx) = referenced; 01382 AT_DEFINED(local_attr_idx) = defined; 01383 AT_HOST_ASSOCIATED(local_attr_idx) = TRUE; 01384 01385 if (ATN_NAMELIST_DESC(attr_idx) != NULL_IDX) { 01386 host_associated_attr_semantics(ATN_NAMELIST_DESC(attr_idx), TRUE); 01387 } 01388 01389 sn_idx = ATN_FIRST_NAMELIST_IDX(attr_idx); 01390 new_sn_idx = NULL_IDX; 01391 01392 while (sn_idx != NULL_IDX) { 01393 01394 if (new_sn_idx == NULL_IDX) { 01395 NTR_SN_TBL(new_sn_idx); 01396 ATN_FIRST_NAMELIST_IDX(local_attr_idx) = new_sn_idx; 01397 } 01398 else { 01399 NTR_SN_TBL(name_idx); 01400 SN_SIBLING_LINK(new_sn_idx) = name_idx; 01401 new_sn_idx = name_idx; 01402 } 01403 01404 sec_name_tbl[new_sn_idx] = sec_name_tbl[sn_idx]; 01405 01406 local_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(SN_ATTR_IDX(sn_idx)), 01407 AT_NAME_LEN(SN_ATTR_IDX(sn_idx)), 01408 &name_idx); 01409 01410 if (local_attr_idx != NULL_IDX && 01411 AT_ATTR_LINK(local_attr_idx) != NULL_IDX) { 01412 01413 new_attr_idx = AT_ATTR_LINK(local_attr_idx); 01414 01415 while (AT_ATTR_LINK(new_attr_idx) != NULL_IDX) { 01416 new_attr_idx = AT_ATTR_LINK(new_attr_idx); 01417 } 01418 01419 if (new_attr_idx != SN_ATTR_IDX(sn_idx)) { 01420 01421 /* If the attr indexes are equal, the attr_idx has already */ 01422 /* been host associated into this scope, so use that attr. */ 01423 /* Otherwise, host associate this attr into this scope. */ 01424 01425 NTR_ATTR_TBL(local_attr_idx); 01426 AT_ATTR_LINK(local_attr_idx) = SN_ATTR_IDX(sn_idx); 01427 host_associated_attr_semantics(SN_ATTR_IDX(sn_idx), FALSE); 01428 } 01429 } 01430 else { 01431 01432 /* Something by this name has not been host associated into */ 01433 /* this scope, so attr link this and host associate it in. */ 01434 01435 NTR_ATTR_TBL(local_attr_idx); 01436 AT_ATTR_LINK(local_attr_idx) = SN_ATTR_IDX(sn_idx); 01437 host_associated_attr_semantics(SN_ATTR_IDX(sn_idx), FALSE); 01438 } 01439 01440 SN_ATTR_IDX(new_sn_idx) = local_attr_idx; 01441 sn_idx = SN_SIBLING_LINK(sn_idx); 01442 } 01443 01444 break; 01445 01446 case Interface: 01447 01448 /* KAY - What does this mean. If there is a program by the same name */ 01449 /* as the interface, how do we know its been referenced? Plus */ 01450 /* interfaces are concatted together. Research this. */ 01451 /* What about referenced and defined? */ 01452 01453 break; 01454 01455 case Stmt_Func: 01456 01457 /* Need to check the statement function body for anything else that is */ 01458 /* host associated. ie: Traverse the IR. */ 01459 01460 switch (ATS_SF_FLD(attr_idx)) { 01461 case AT_Tbl_Idx: 01462 host_associated_attr_semantics(ATS_SF_IDX(attr_idx), TRUE); 01463 break; 01464 01465 case IR_Tbl_Idx: 01466 find_host_associated_attrs_in_ir(ATS_SF_IDX(attr_idx)); 01467 break; 01468 01469 case IL_Tbl_Idx: 01470 find_host_associated_attrs_in_il(ATS_SF_IDX(attr_idx)); 01471 break; 01472 } 01473 break; 01474 } 01475 01476 if (add_to_attr_list) { 01477 ADD_ATTR_TO_LOCAL_LIST(local_attr_idx); 01478 } 01479 01480 TRACE (Func_Exit, "host_associated_attr_semantics", NULL); 01481 01482 return; 01483 01484 } /* host_associated_attr_semantics */ 01485 01486 /******************************************************************************\ 01487 |* *| 01488 |* Description: *| 01489 |* *| 01490 |* Input parameters: *| 01491 |* NONE *| 01492 |* *| 01493 |* Output parameters: *| 01494 |* NONE *| 01495 |* *| 01496 |* Returns: *| 01497 |* NOTHING *| 01498 |* *| 01499 \******************************************************************************/ 01500 01501 static void find_host_associated_attrs_in_ir(int ir_idx) 01502 01503 { 01504 01505 TRACE (Func_Entry, "find_host_associated_attrs_in_ir", NULL); 01506 01507 switch (IR_FLD_L(ir_idx)) { 01508 case AT_Tbl_Idx: 01509 host_associated_attr_semantics(IR_IDX_L(ir_idx), TRUE); 01510 break; 01511 01512 case IR_Tbl_Idx: 01513 find_host_associated_attrs_in_ir(IR_IDX_L(ir_idx)); 01514 break; 01515 01516 case IL_Tbl_Idx: 01517 find_host_associated_attrs_in_il(IR_IDX_L(ir_idx)); 01518 break; 01519 01520 case CN_Tbl_Idx: 01521 case NO_Tbl_Idx: 01522 case SH_Tbl_Idx: 01523 break; 01524 } 01525 01526 switch (IR_FLD_R(ir_idx)) { 01527 case AT_Tbl_Idx: 01528 host_associated_attr_semantics(IR_IDX_R(ir_idx), TRUE); 01529 break; 01530 01531 case IR_Tbl_Idx: 01532 find_host_associated_attrs_in_ir(IR_IDX_R(ir_idx)); 01533 break; 01534 01535 case IL_Tbl_Idx: 01536 find_host_associated_attrs_in_il(IR_IDX_R(ir_idx)); 01537 break; 01538 01539 case CN_Tbl_Idx: 01540 case NO_Tbl_Idx: 01541 case SH_Tbl_Idx: 01542 break; 01543 } 01544 01545 TRACE (Func_Exit, "find_host_associated_attrs_in_ir", NULL); 01546 01547 return; 01548 01549 } /* find_host_associated_attrs_in_ir */ 01550 01551 /******************************************************************************\ 01552 |* *| 01553 |* Description: *| 01554 |* *| 01555 |* Input parameters: *| 01556 |* NONE *| 01557 |* *| 01558 |* Output parameters: *| 01559 |* NONE *| 01560 |* *| 01561 |* Returns: *| 01562 |* NOTHING *| 01563 |* *| 01564 \******************************************************************************/ 01565 01566 static void find_host_associated_attrs_in_il(int list_idx) 01567 01568 { 01569 TRACE (Func_Entry, "find_host_associated_attrs_in_il", NULL); 01570 01571 while (list_idx != NULL_IDX) { 01572 01573 switch (IL_FLD(list_idx)) { 01574 case AT_Tbl_Idx: 01575 host_associated_attr_semantics(IL_IDX(list_idx), TRUE); 01576 break; 01577 01578 case IR_Tbl_Idx: 01579 find_host_associated_attrs_in_ir(IL_IDX(list_idx)); 01580 break; 01581 01582 case IL_Tbl_Idx: 01583 find_host_associated_attrs_in_il(IL_IDX(list_idx)); 01584 break; 01585 01586 case NO_Tbl_Idx: 01587 case SH_Tbl_Idx: 01588 case CN_Tbl_Idx: 01589 break; 01590 } 01591 list_idx = IL_NEXT_LIST_IDX(list_idx); 01592 } 01593 01594 TRACE (Func_Exit, "find_host_associated_attrs_in_il", NULL); 01595 01596 return; 01597 01598 } /* find_host_associated_attrs_in_il */ 01599 01600 /******************************************************************************\ 01601 |* *| 01602 |* Description: *| 01603 |* initialize the zero'd arg_info struct and the exp_desc struct for *| 01604 |* call list processing and expr_semantics. *| 01605 |* *| 01606 |* Input parameters: *| 01607 |* NONE *| 01608 |* *| 01609 |* Output parameters: *| 01610 |* NONE *| 01611 |* *| 01612 |* Returns: *| 01613 |* NOTHING *| 01614 |* *| 01615 \******************************************************************************/ 01616 01617 static void init_call_structs(void) 01618 01619 { 01620 int i; 01621 01622 TRACE (Func_Entry, "init_call_structs", NULL); 01623 01624 init_exp_desc.type_idx = TYPELESS_DEFAULT_TYPE; 01625 init_exp_desc.rank = 0; 01626 init_exp_desc.cif_id = 0; 01627 init_exp_desc.type = Typeless; 01628 init_exp_desc.linear_type = Err_Res; 01629 init_exp_desc.kind0seen = FALSE; 01630 init_exp_desc.kind0D0seen = FALSE; 01631 init_exp_desc.percent_val_arg = FALSE; 01632 init_exp_desc.constant = FALSE; 01633 init_exp_desc.foldable = FALSE; 01634 init_exp_desc.will_fold_later = FALSE; 01635 init_exp_desc.pointer = FALSE; 01636 init_exp_desc.target = FALSE; 01637 init_exp_desc.vector_subscript = FALSE; 01638 init_exp_desc.reference = FALSE; 01639 init_exp_desc.constructor = FALSE; 01640 init_exp_desc.component = FALSE; 01641 init_exp_desc.section = FALSE; 01642 init_exp_desc.label = FALSE; 01643 init_exp_desc.array_elt = FALSE; 01644 init_exp_desc.assumed_shape = FALSE; 01645 init_exp_desc.assumed_size = FALSE; 01646 init_exp_desc.allocatable = FALSE; 01647 init_exp_desc.dope_vector = FALSE; 01648 init_exp_desc.tmp_reference = FALSE; 01649 init_exp_desc.has_constructor = FALSE; 01650 init_exp_desc.optional_darg = FALSE; 01651 init_exp_desc.pe_dim_ref = FALSE; 01652 init_exp_desc.contig_array = FALSE; 01653 init_exp_desc.shape_known = FALSE; 01654 init_exp_desc.tree_has_ranf = FALSE; 01655 init_exp_desc.has_symbolic = FALSE; 01656 init_exp_desc.dist_reshape_ref = FALSE; 01657 init_exp_desc.constructor_size_level = Unknown_Expr_Size; 01658 01659 init_exp_desc.char_len = null_opnd; 01660 01661 for (i = 0; i < 7; i++) { 01662 init_exp_desc.shape[i] = null_opnd; 01663 } 01664 01665 init_arg_info.ed = init_exp_desc; 01666 01667 init_arg_info.kwd = NULL_IDX; 01668 init_arg_info.line = 0; 01669 init_arg_info.col = 0; 01670 init_arg_info.association = 0; 01671 init_arg_info.arg_opnd = null_opnd; 01672 init_arg_info.pgm_unit = FALSE; 01673 init_arg_info.maybe_modified = TRUE; 01674 01675 TRACE (Func_Exit, "init_call_structs", NULL); 01676 01677 return; 01678 01679 } /* init_call_structs */ 01680 01681 /******************************************************************************\ 01682 |* *| 01683 |* Description: *| 01684 |* Check for a pending align cdir for a referenced user label. *| 01685 |* *| 01686 |* Input parameters: *| 01687 |* NONE *| 01688 |* *| 01689 |* Output parameters: *| 01690 |* NONE *| 01691 |* *| 01692 |* Returns: *| 01693 |* NOTHING *| 01694 |* *| 01695 \******************************************************************************/ 01696 01697 void label_def_stmt_semantics(void) 01698 01699 { 01700 int label_idx; 01701 01702 TRACE (Func_Entry, "label_def_stmt_semantics", NULL); 01703 01704 label_idx = IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx)); 01705 01706 if (ATL_CLASS(label_idx) == Lbl_User && 01707 AT_REFERENCED(label_idx) == Referenced && cdir_switches.align) { 01708 01709 ATL_ALIGN(label_idx) = TRUE; 01710 cdir_switches.align = FALSE; 01711 } 01712 01713 if (! cdir_switches.vector) { 01714 ATL_NOVECTOR(label_idx) = TRUE; 01715 } 01716 01717 # if defined(GENERATE_WHIRL) 01718 if (cdir_switches.notask_region) { 01719 ATL_NOTASK(label_idx) = TRUE; 01720 } 01721 # else 01722 if (! cdir_switches.task) { 01723 ATL_NOTASK(label_idx) = TRUE; 01724 } 01725 # endif 01726 01727 if (! cdir_switches.vsearch) { 01728 ATL_NOVSEARCH(label_idx) = TRUE; 01729 } 01730 01731 if (cdir_switches.bl) { 01732 ATL_BL(label_idx) = TRUE; 01733 } 01734 01735 if (! cdir_switches.recurrence) { 01736 ATL_NORECURRENCE(label_idx) = TRUE; 01737 } 01738 01739 if (cdir_switches.pattern) { 01740 ATL_PATTERN(label_idx) = TRUE; 01741 } 01742 01743 TRACE (Func_Exit, "label_def_stmt_semantics", NULL); 01744 01745 return; 01746 01747 } /* label_def_stmt_semantics */ 01748 01749 /******************************************************************************\ 01750 |* *| 01751 |* Description: *| 01752 |* This assigns storage offsets at the end of the semantics pass. *| 01753 |* This assumes parents are processed before children. This also *| 01754 |* assumes that tmps are assigned after all declared variables. This is *| 01755 |* needed for the data initialization array optimization. ATD_TMP_IDX *| 01756 |* on the compiler tmps with ATD_DATA_INIT set is a pointer to the *| 01757 |* variable that is being data initialized. *| 01758 |* If CIF records are being generated, it generates OBJECT records for *| 01759 |* everything in the local name table that CIF wants. *| 01760 |* *| 01761 |* Input parameters: *| 01762 |* NONE *| 01763 |* *| 01764 |* Output parameters: *| 01765 |* NONE *| 01766 |* *| 01767 |* Returns: *| 01768 |* NONE *| 01769 |* *| 01770 \******************************************************************************/ 01771 static void final_decl_semantics(void) 01772 01773 { 01774 int al_idx; 01775 int attr_idx; 01776 int name_idx; 01777 int symbolic_constant = NULL_IDX; 01778 01779 01780 # if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK) 01781 size_offset_type length; 01782 int list_idx; 01783 size_offset_type result; 01784 int sb_idx; 01785 # endif 01786 01787 01788 TRACE (Func_Entry, "final_decl_semantics", NULL); 01789 01790 /* This holds a list of all arrays whose bounds are based on symbolic */ 01791 /* constants that need to have offsets assigned. (Except for common */ 01792 /* blocks.) This ensures that in static and module blocks, all the */ 01793 /* symbolic constant based arrays are at the end of the block. Then */ 01794 /* anything in the block that is not a symbolic constant based array */ 01795 /* can be equivalenced or data initialized. */ 01796 01797 symbolic_constant_array_list = NULL_IDX; 01798 01799 /* Mark the start of the assign label chain, in case this procedure */ 01800 /* ends up going out for USE processing and coming back in for inlining. */ 01801 /* We can then find the start of the chain without having a scope table. */ 01802 01803 if (SCP_ASSIGN_LBL_CHAIN(curr_scp_idx) != NULL_IDX) { 01804 ATL_ASG_LBL_CHAIN_START(SCP_ASSIGN_LBL_CHAIN(curr_scp_idx)) = TRUE; 01805 } 01806 01807 /* Do final processing of equivalence groups, it there are no errors. */ 01808 01809 if (num_prog_unit_errors == 0) { 01810 final_equivalence_semantics(); 01811 } 01812 01813 storage_blk_resolution(); 01814 01815 for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 01816 name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) { 01817 01818 attr_idx = LN_ATTR_IDX(name_idx); 01819 01820 if (!AT_DCL_ERR(attr_idx)) { 01821 01822 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 01823 ATD_SYMBOLIC_CONSTANT(attr_idx) && 01824 (ATD_CLASS(attr_idx) == Constant || 01825 ATD_CLASS(attr_idx) == Variable)) { 01826 symbolic_constant = attr_idx; 01827 } 01828 else { 01829 final_attr_semantics(attr_idx); 01830 } 01831 } 01832 } 01833 01834 01835 if (symbolic_constant != NULL_IDX && 01836 (ATD_CLASS(symbolic_constant) == Constant || 01837 AT_REFERENCED(symbolic_constant) == Not_Referenced)) { 01838 01839 /* Remove N$PES from the name table here. This is needed so N$PES */ 01840 /* doesn't cause problems in MODULE processing. */ 01841 01842 srch_sym_tbl(AT_OBJ_NAME_PTR(symbolic_constant), 01843 AT_NAME_LEN(symbolic_constant), 01844 &name_idx); 01845 01846 remove_ln_ntry(name_idx); 01847 } 01848 01849 al_idx = SCP_ATTR_LIST(curr_scp_idx); 01850 01851 while (al_idx != NULL_IDX) { 01852 01853 if (!AT_DCL_ERR(AL_ATTR_IDX(al_idx))) { 01854 final_attr_semantics(AL_ATTR_IDX(al_idx)); 01855 } 01856 01857 al_idx = AL_NEXT_IDX(al_idx); 01858 } 01859 01860 al_idx = symbolic_constant_array_list; 01861 01862 while (al_idx != NULL_IDX) { 01863 assign_offset(AL_ATTR_IDX(al_idx)); /* symbolic constants */ 01864 al_idx = AL_NEXT_IDX(al_idx); 01865 } 01866 01867 # if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK) 01868 01869 if (SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) != NULL_IDX) { 01870 01871 /* Have stack items that are hosted. Need to add a tmp for the */ 01872 /* block length. Any time this hosted stack is used, the tmp */ 01873 /* must be host associated as well. Special case is the zero */ 01874 /* block length. We do not need a tmp, because if nothing is */ 01875 /* hosted, the block doesn't get in. If one or more things are */ 01876 /* hosted, then the length will still be correct at zero. */ 01877 01878 sb_idx = SCP_SB_HOSTED_STACK_IDX(curr_scp_idx); 01879 01880 /* KAY - If this is set to AT_Tbl_Idx, it should not be 0. */ 01881 01882 if (SB_LEN_FLD(sb_idx) == AT_Tbl_Idx || 01883 fold_relationals(SB_LEN_IDX(sb_idx), CN_INTEGER_ZERO_IDX, Ne_Opr)) { 01884 01885 result.idx = SB_LEN_IDX(sb_idx); 01886 result.fld = SB_LEN_FLD(sb_idx); 01887 01888 align_bit_length(&result, TARGET_BITS_PER_WORD); 01889 01890 if (result.fld == NO_Tbl_Idx) { 01891 result.fld = CN_Tbl_Idx; 01892 result.idx = ntr_const_tbl(result.type_idx, 01893 FALSE, 01894 result.constant); 01895 } 01896 01897 SB_LEN_FLD(sb_idx) = result.fld; 01898 SB_LEN_IDX(sb_idx) = result.idx; 01899 attr_idx = gen_compiler_tmp(SB_DEF_LINE(sb_idx), 01900 SB_DEF_COLUMN(sb_idx), 01901 Priv, TRUE); 01902 01903 ATD_TYPE_IDX(attr_idx) = TYPELESS_DEFAULT_TYPE; 01904 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 01905 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 01906 AT_REFERENCED(attr_idx) = Referenced; /* Force thru PDGCS */ 01907 AT_REF_IN_CHILD(attr_idx) = TRUE; /* Force thru PDGCS */ 01908 NTR_ATTR_LIST_TBL(list_idx); 01909 AL_ATTR_IDX(list_idx) = attr_idx; 01910 SB_LAST_ATTR_LIST(sb_idx) = list_idx; 01911 01912 /* This must be at least one word length, because */ 01913 /* the bit length has been word aligned. */ 01914 01915 length.fld = CN_Tbl_Idx; 01916 length.idx = CN_INTEGER_BITS_PER_WORD_IDX; 01917 01918 if (!size_offset_binary_calc(&result, &length, Minus_Opr, &result)) { 01919 AT_DCL_ERR(attr_idx) = TRUE; 01920 } 01921 01922 if (result.fld == NO_Tbl_Idx) { 01923 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 01924 ATD_OFFSET_IDX(attr_idx) = ntr_const_tbl(result.type_idx, 01925 FALSE, 01926 result.constant); 01927 } 01928 else { 01929 ATD_OFFSET_FLD(attr_idx) = result.fld; 01930 ATD_OFFSET_IDX(attr_idx) = result.idx; 01931 } 01932 } 01933 } 01934 # endif 01935 01936 /* Check CIF option to see if symbol table needs to be written to CIF. */ 01937 /* Need to use BASIC_RECS to output the Entry Info and Common Block */ 01938 /* records if the user just specifies "-cf". */ 01939 01940 if (cif_flags & BASIC_RECS) { 01941 cif_send_sytb(); 01942 } 01943 01944 TRACE (Func_Exit, "final_decl_semantics", NULL); 01945 01946 return; 01947 01948 } /* final_decl_semantics */ 01949 01950 /******************************************************************************\ 01951 |* *| 01952 |* Description: *| 01953 |* Allocates storage and offsets for all COMMON blocks. *| 01954 |* *| 01955 |* Input parameters: *| 01956 |* NONE *| 01957 |* *| 01958 |* Output parameters: *| 01959 |* NONE *| 01960 |* *| 01961 |* Returns: *| 01962 |* NONE *| 01963 |* *| 01964 \******************************************************************************/ 01965 static void final_attr_semantics(int attr_idx) 01966 01967 { 01968 int al_idx; 01969 int darg_idx; 01970 int i; 01971 int il_idx; 01972 int local_attr_idx; 01973 int rslt_idx; 01974 int sb_idx; 01975 int sn_idx; 01976 01977 int type_idx; 01978 01979 # if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK) 01980 static int tmp_scp_idx = NULL_IDX; 01981 # endif 01982 01983 # if defined(_TMP_GIVES_COMMON_LENGTH) 01984 size_offset_type length; 01985 size_offset_type result; 01986 size_offset_type size; 01987 size_offset_type zero; 01988 # endif 01989 01990 TRACE (Func_Entry, "final_attr_semantics", NULL); 01991 01992 if (AT_ATTR_LINK(attr_idx) == NULL_IDX || AT_IGNORE_ATTR_LINK(attr_idx)) { 01993 01994 switch (AT_OBJ_CLASS(attr_idx)) { 01995 case Data_Obj: 01996 01997 if (ATD_EQUIV_LIST(attr_idx) != NULL_IDX) { 01998 free_attr_list(ATD_EQUIV_LIST(attr_idx)); 01999 ATD_EQUIV_LIST(attr_idx) = NULL_IDX; 02000 } 02001 02002 if (ATD_NO_ENTRY_LIST(attr_idx) != NULL_IDX) { 02003 free_attr_list(ATD_NO_ENTRY_LIST(attr_idx)); 02004 ATD_NO_ENTRY_LIST(attr_idx) = NULL_IDX; 02005 } 02006 02007 switch (ATD_CLASS(attr_idx)) { 02008 case Constant: 02009 02010 # ifdef _DEBUG 02011 if (ATD_FLD(attr_idx) == NO_Tbl_Idx) { 02012 PRINTMSG(AT_DEF_LINE(attr_idx), 893, Internal, 02013 AT_DEF_COLUMN(attr_idx), 02014 "ATD_CONST_IDX", 02015 "ATD_FLD", 02016 "attr_tbl", 02017 attr_idx); 02018 } 02019 # endif 02020 02021 /* Mark the overlay tmp as Referenced. Have to delay until this */ 02022 /* point, because the tmp is not created yet. Can't do it when */ 02023 /* the tmp is created, because this also must be done for */ 02024 /* use associated constants. */ 02025 02026 if (ATD_FLD(attr_idx) == AT_Tbl_Idx && 02027 AT_REFERENCED(attr_idx) != Not_Referenced) { 02028 AT_REFERENCED(ATD_CONST_IDX(attr_idx)) = Referenced; 02029 } 02030 02031 attr_idx = NULL_IDX; 02032 break; 02033 02034 case Struct_Component: 02035 attr_idx = NULL_IDX; 02036 break; 02037 02038 case Function_Result: /* These are done, when the Function is */ 02039 attr_idx = NULL_IDX; 02040 break; 02041 02042 case Compiler_Tmp: 02043 # ifdef _DEBUG 02044 if (ATD_FLD(attr_idx) == NO_Tbl_Idx && 02045 ATD_TMP_IDX(attr_idx) != NULL_IDX) { 02046 PRINTMSG(AT_DEF_LINE(attr_idx), 893, Internal, 02047 AT_DEF_COLUMN(attr_idx), 02048 "ATD_TMP_IDX", 02049 "ATD_FLD", 02050 "attr_tbl", 02051 attr_idx); 02052 } 02053 02054 # endif 02055 if (ATD_TMP_INIT_NOT_DONE(attr_idx) && 02056 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 02057 02058 /* Have a default init temp. Generate the init */ 02059 /* in the module, so it is ready to be used */ 02060 /* wherever the module is used. */ 02061 02062 insert_init_stmt_for_tmp(attr_idx); 02063 } 02064 02065 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 02066 02067 # if defined(_TMP_GIVES_COMMON_LENGTH) 02068 02069 if (AT_REFERENCED(attr_idx) == Not_Referenced && 02070 !ATD_OFFSET_ASSIGNED(attr_idx) && 02071 sb_idx != NULL_IDX && 02072 (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) ) { 02073 02074 /* If block length is zero, we do not need the tmp, so do */ 02075 /* not set AT_REFERENCED and it will not get sent across. */ 02076 02077 if (SB_LEN_FLD(sb_idx) == CN_Tbl_Idx && 02078 fold_relationals(SB_LEN_IDX(sb_idx), 02079 CN_INTEGER_ZERO_IDX, Ne_Opr)) { 02080 size.fld = CN_Tbl_Idx; 02081 size.idx = CN_INTEGER_BITS_PER_WORD_IDX; 02082 length.fld = SB_LEN_FLD(sb_idx); 02083 length.idx = SB_LEN_IDX(sb_idx); 02084 02085 size_offset_binary_calc(&length, &size, Mod_Opr, &size); 02086 02087 /* Size should always be less than TARGET_BITS_PER_WORD */ 02088 02089 zero.fld = CN_Tbl_Idx; 02090 zero.idx = CN_INTEGER_ZERO_IDX; 02091 02092 size_offset_logical_calc(&size, &zero, Eq_Opr, &result); 02093 02094 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 02095 size.idx = CN_INTEGER_BITS_PER_WORD_IDX; 02096 size.fld = CN_Tbl_Idx; 02097 } 02098 02099 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 02100 TYP_TYPE(TYP_WORK_IDX) = Typeless; 02101 TYP_BIT_LEN(TYP_WORK_IDX) = (size.fld == CN_Tbl_Idx) ? 02102 CN_INT_TO_C(size.idx) : F_INT_TO_C(size.constant, 02103 TYP_LINEAR(size.type_idx)); 02104 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 02105 02106 if (!size_offset_binary_calc(&length, 02107 &size, 02108 Minus_Opr, 02109 &result)) { 02110 AT_DCL_ERR(attr_idx) = TRUE; 02111 } 02112 02113 if (result.fld == NO_Tbl_Idx) { 02114 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 02115 ATD_OFFSET_IDX(attr_idx) = ntr_const_tbl(result.type_idx, 02116 FALSE, 02117 result.constant); 02118 } 02119 else { 02120 ATD_OFFSET_FLD(attr_idx) = result.fld; 02121 ATD_OFFSET_IDX(attr_idx) = result.idx; 02122 } 02123 02124 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 02125 AT_REFERENCED(attr_idx) = Referenced; 02126 } 02127 02128 # ifdef _DEBUG 02129 if (ATD_OFFSET_ASSIGNED(attr_idx) && 02130 ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx && 02131 fold_relationals(ATD_OFFSET_IDX(attr_idx), 02132 CN_INTEGER_ZERO_IDX, 02133 Lt_Opr)) { 02134 PRINTMSG(AT_DEF_LINE(attr_idx), 1004, Internal, 02135 AT_DEF_COLUMN(attr_idx), 02136 AT_OBJ_NAME_PTR(attr_idx), 02137 attr_idx); 02138 } 02139 # endif 02140 02141 /* KAY - Is this in the correct spot * */ 02142 02143 if (ATD_DEFINING_ATTR_IDX(attr_idx) == NULL_IDX && 02144 ATD_FLD(attr_idx) == IR_Tbl_Idx && 02145 IR_FLD_R(ATD_TMP_IDX(attr_idx)) == AT_Tbl_Idx && 02146 AT_OBJ_CLASS(IR_IDX_R(ATD_TMP_IDX(attr_idx))) == Data_Obj && 02147 ATD_CLASS(IR_IDX_R(ATD_TMP_IDX(attr_idx))) == Compiler_Tmp) { 02148 ATD_DEFINING_ATTR_IDX(attr_idx) = 02149 ATD_DEFINING_ATTR_IDX(IR_IDX_R(ATD_TMP_IDX(attr_idx))); 02150 } 02151 02152 attr_idx = NULL_IDX; 02153 } 02154 # endif 02155 break; 02156 02157 case Variable: 02158 02159 if (ATD_SYMBOLIC_CONSTANT(attr_idx) && 02160 AT_REFERENCED(attr_idx) == Referenced) { 02161 PRINTMSG(AT_DEF_LINE(attr_idx), 1229, Ansi, 02162 AT_DEF_COLUMN(attr_idx), 02163 AT_OBJ_NAME_PTR(attr_idx)); 02164 } 02165 02166 if (ATD_FLD(attr_idx) != NO_Tbl_Idx) { 02167 02168 /* This has data initialized tmps associated with it */ 02169 02170 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) { 02171 final_attr_semantics(ATD_VARIABLE_TMP_IDX(attr_idx)); 02172 } 02173 else if (ATD_FLD(attr_idx) == IL_Tbl_Idx) { 02174 02175 /* Must be structure - Have a list of tmps */ 02176 02177 il_idx = ATD_VARIABLE_TMP_IDX(attr_idx); 02178 02179 while (il_idx != NULL_IDX) { 02180 final_attr_semantics(IL_IDX(il_idx)); 02181 il_idx = IL_NEXT_LIST_IDX(il_idx); 02182 } 02183 } 02184 } 02185 02186 /* Intentional fall through */ 02187 02188 default: 02189 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 02190 02191 if (sb_idx != NULL_IDX) { 02192 type_idx = ATD_TYPE_IDX(attr_idx); 02193 02194 if (SB_VOLATILE(sb_idx)) { 02195 ATD_VOLATILE(attr_idx) = TRUE; 02196 } 02197 02198 if (ATD_EQUIV_IN_BNDS_EXPR(attr_idx) && 02199 !AT_HOST_ASSOCIATED(attr_idx) && 02200 !AT_USE_ASSOCIATED(attr_idx) && 02201 !SB_IS_COMMON(sb_idx) && 02202 !ATD_SYMBOLIC_CONSTANT(attr_idx)) { 02203 02204 /* If final_equivalence_semantics isn't called, then */ 02205 /* we may issue this message in bogus situations. */ 02206 02207 if (SCP_FIRST_EQUIV_GRP(curr_scp_idx) == NULL_IDX || 02208 num_prog_unit_errors == 0) { 02209 PRINTMSG(AT_DEF_LINE(attr_idx), 521, Error, 02210 AT_DEF_COLUMN(attr_idx), 02211 AT_OBJ_NAME_PTR(attr_idx)); 02212 } 02213 } 02214 02215 if (SB_AUXILIARY(sb_idx)) { 02216 02217 if (AT_NAMELIST_OBJ(attr_idx) && SB_IS_COMMON(sb_idx)) { 02218 PRINTMSG(AT_DEF_LINE(attr_idx), 663, Error, 02219 AT_DEF_COLUMN(attr_idx), 02220 AT_OBJ_NAME_PTR(attr_idx), 02221 SB_NAME_PTR(sb_idx)); 02222 } 02223 02224 if (!ATD_AUXILIARY(attr_idx) && 02225 SB_BLK_TYPE(sb_idx) != Formal) { 02226 02227 /* Formal dargs do not cause all the dargs to become aux */ 02228 02229 if (TYP_TYPE(type_idx) == Character) { 02230 PRINTMSG(AT_DEF_LINE(attr_idx), 535, Error, 02231 AT_DEF_COLUMN(attr_idx), 02232 AT_OBJ_NAME_PTR(attr_idx)); 02233 AT_DCL_ERR(attr_idx) = TRUE; 02234 } 02235 else if (TYP_TYPE(type_idx) == Structure && 02236 (ATT_POINTER_CPNT(TYP_IDX(type_idx)) || 02237 ATT_CHAR_CPNT(TYP_IDX(type_idx)))) { 02238 PRINTMSG(AT_DEF_LINE(attr_idx), 536, Error, 02239 AT_DEF_COLUMN(attr_idx), 02240 AT_OBJ_NAME_PTR(attr_idx), 02241 AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 02242 AT_DCL_ERR(attr_idx) = TRUE; 02243 } 02244 else if (ATD_TARGET(attr_idx) || 02245 ATD_DATA_INIT(attr_idx) || 02246 ATD_POINTER(attr_idx) || 02247 TYP_TYPE(type_idx) == CRI_Ptr) { 02248 fnd_semantic_err(Obj_Auxiliary, 02249 AT_DEF_LINE(attr_idx), 02250 AT_DEF_COLUMN(attr_idx), 02251 attr_idx, 02252 TRUE); 02253 } 02254 else { 02255 ATD_AUXILIARY(attr_idx) = TRUE; 02256 } 02257 } 02258 } 02259 } 02260 break; 02261 } 02262 02263 break; 02264 02265 case Pgm_Unit: 02266 02267 if (attr_idx != SCP_ATTR_IDX(curr_scp_idx) && 02268 ATP_IN_INTERFACE_BLK(attr_idx) && 02269 !AT_HOST_ASSOCIATED(attr_idx) && 02270 !AT_USE_ASSOCIATED(attr_idx)) { 02271 02272 attr_idx = NULL_IDX; 02273 break; 02274 } 02275 02276 switch (ATP_PGM_UNIT(attr_idx)) { 02277 case Function: 02278 case Pgm_Unknown: 02279 case Subroutine: 02280 02281 if (ATP_GLOBAL_ATTR_IDX(attr_idx) == NULL_IDX && 02282 ATP_EXPL_ITRFC(attr_idx) && 02283 !AT_COMPILER_GEND(attr_idx) && 02284 !ATP_NAME_IN_STONE(attr_idx) && 02285 (ATP_PROC(attr_idx) == Unknown_Proc || 02286 ATP_PROC(attr_idx) == Extern_Proc || 02287 ATP_PROC(attr_idx) == Imported_Proc) && 02288 !AT_IS_INTRIN(attr_idx) && 02289 (attr_idx != glb_tbl_idx[Main_Attr_Idx])) { 02290 02291 /* This has not been entered or resolved globally yet. */ 02292 /* This routine checks for this name in the global name */ 02293 /* table. It enters it, if it doesn't exist or checks */ 02294 /* for semantics errors if it does exist. */ 02295 02296 check_global_pgm_unit(attr_idx); 02297 } 02298 02299 if (ATP_NO_ENTRY_LIST(attr_idx) != NULL_IDX) { 02300 free_attr_list(ATP_NO_ENTRY_LIST(attr_idx)); 02301 ATP_NO_ENTRY_LIST(attr_idx) = NULL_IDX; 02302 } 02303 02304 if (ATP_PROC(attr_idx) == Module_Proc) { 02305 02306 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 02307 !AT_PRIVATE(attr_idx) && !AT_DCL_ERR(attr_idx)) { 02308 02309 /* The function result type and all dummy argument types */ 02310 /* must be public types, if the procedure is public. */ 02311 02312 if (ATP_PGM_UNIT(attr_idx) == Function) { 02313 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 02314 02315 if (TYP_TYPE(type_idx) == Structure && 02316 AT_PRIVATE(TYP_IDX(type_idx)) && 02317 !AT_USE_ASSOCIATED(TYP_IDX(type_idx)) ) { 02318 02319 /* Issue error if the Module procedure is PUBLIC, */ 02320 /* but its function result is a PRIVATE type. */ 02321 /* Unless interp 161 applies. */ 02322 02323 PRINTMSG(AT_DEF_LINE(attr_idx), 684, Error, 02324 AT_DEF_COLUMN(attr_idx), 02325 AT_OBJ_NAME_PTR(attr_idx)); 02326 AT_DCL_ERR(attr_idx) = TRUE; 02327 } 02328 } 02329 02330 for (i = (ATP_EXTRA_DARG(attr_idx) ? 1 : 0); 02331 i < ATP_NUM_DARGS(attr_idx); i++) { 02332 02333 darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(attr_idx) + i); 02334 02335 if (AT_DCL_ERR(darg_idx)) { 02336 continue; 02337 } 02338 02339 02340 /* Issue error if the Module procedure is PUBLIC, but */ 02341 /* one of its dummy arguments is a PRIVATE type. */ 02342 02343 if (AT_OBJ_CLASS(darg_idx) == Interface) { 02344 darg_idx = ATI_PROC_IDX(darg_idx); 02345 } 02346 02347 if (darg_idx != NULL_IDX && 02348 AT_OBJ_CLASS(darg_idx) == Pgm_Unit) { 02349 02350 if (ATP_PGM_UNIT(darg_idx) == Function) { 02351 darg_idx = ATP_RSLT_IDX(darg_idx); 02352 } 02353 else { 02354 darg_idx = NULL_IDX; 02355 } 02356 } 02357 02358 if (darg_idx != NULL_IDX && 02359 TYP_TYPE(ATD_TYPE_IDX(darg_idx)) == Structure && 02360 AT_PRIVATE(TYP_IDX(ATD_TYPE_IDX(darg_idx))) && 02361 !AT_USE_ASSOCIATED(TYP_IDX(ATD_TYPE_IDX(darg_idx))) ) { 02362 PRINTMSG(AT_DEF_LINE(darg_idx), 685, Error, 02363 AT_DEF_COLUMN(darg_idx), 02364 AT_OBJ_NAME_PTR(attr_idx), 02365 AT_OBJ_NAME_PTR(darg_idx)); 02366 AT_DCL_ERR(attr_idx) = TRUE; 02367 } 02368 } 02369 } 02370 } 02371 02372 if (!AT_USE_ASSOCIATED(attr_idx)) { 02373 02374 if (ATP_PROC(attr_idx) == Unknown_Proc) { 02375 ATP_PROC(attr_idx) = Extern_Proc; 02376 } 02377 02378 if (ATP_EXT_NAME_IDX(attr_idx) == NULL_IDX) { 02379 # ifdef _DEBUG 02380 PRINTMSG(AT_DEF_LINE(attr_idx), 193, Internal, 02381 AT_DEF_COLUMN(attr_idx), 02382 0, "ATP_EXT_NAME_IDX", attr_idx); 02383 # endif 02384 MAKE_EXTERNAL_NAME(attr_idx, 02385 AT_NAME_IDX(attr_idx), 02386 AT_NAME_LEN(attr_idx)); 02387 } 02388 02389 ATP_ALL_INTENT_IN(attr_idx) = TRUE; 02390 02391 sn_idx = (ATP_EXTRA_DARG(attr_idx) && ATP_EXPL_ITRFC(attr_idx)) ? 02392 ATP_FIRST_IDX(attr_idx)+1: ATP_FIRST_IDX(attr_idx); 02393 02394 for (;sn_idx < (ATP_FIRST_IDX(attr_idx)+ATP_NUM_DARGS(attr_idx)); 02395 sn_idx++) { 02396 02397 if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) != Data_Obj || 02398 ATD_CLASS(SN_ATTR_IDX(sn_idx)) != Dummy_Argument || 02399 ATD_INTENT(SN_ATTR_IDX(sn_idx)) != Intent_In) { 02400 ATP_ALL_INTENT_IN(attr_idx) = FALSE; 02401 break; 02402 } 02403 } 02404 } 02405 02406 if (ATP_HAS_ALT_RETURN(attr_idx)) { 02407 02408 if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) { 02409 02410 /* Create a function result as required */ 02411 /* by the PDGCS interface. */ 02412 02413 NTR_ATTR_TBL(rslt_idx); 02414 COPY_ATTR_NTRY(rslt_idx, attr_idx); 02415 CLEAR_VARIANT_ATTR_INFO(rslt_idx, Data_Obj); 02416 ATD_CLASS(rslt_idx) = Function_Result; 02417 ATD_TYPE_IDX(rslt_idx) = CG_INTEGER_DEFAULT_TYPE; 02418 ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 02419 ATP_RSLT_IDX(attr_idx) = rslt_idx; 02420 } 02421 attr_idx = NULL_IDX; 02422 } 02423 else { 02424 attr_idx = ATP_RSLT_IDX(attr_idx); 02425 } 02426 break; 02427 02428 case Blockdata: 02429 case Program: 02430 02431 if (ATP_NO_ENTRY_LIST(attr_idx) != NULL_IDX) { 02432 free_attr_list(ATP_NO_ENTRY_LIST(attr_idx)); 02433 ATP_NO_ENTRY_LIST(attr_idx) = NULL_IDX; 02434 } 02435 02436 /* Intentional fall through to next case */ 02437 02438 case Module: 02439 02440 if (ATP_GLOBAL_ATTR_IDX(attr_idx) == NULL_IDX && 02441 !AT_COMPILER_GEND(attr_idx) && 02442 (attr_idx != glb_tbl_idx[Main_Attr_Idx]) && 02443 (ATP_PGM_UNIT(attr_idx) != Module || 02444 ATP_MODULE_STR_IDX(attr_idx) == NULL_IDX)) { 02445 02446 /* This has not been entered or resolved globally yet. */ 02447 /* This routine checks for this name in the global name */ 02448 /* table. It enters it, if it doesn't exist or checks */ 02449 /* for semantics errors if it does exist. */ 02450 02451 check_global_pgm_unit(attr_idx); 02452 } 02453 02454 if (ATP_EXT_NAME_IDX(attr_idx) == NULL_IDX) { 02455 MAKE_EXTERNAL_NAME(attr_idx, 02456 AT_NAME_IDX(attr_idx), 02457 AT_NAME_LEN(attr_idx)); 02458 } 02459 attr_idx = NULL_IDX; 02460 break; 02461 02462 } /* End switch */ 02463 break; 02464 02465 case Interface: 02466 02467 attr_idx = ATI_PROC_IDX(attr_idx); 02468 02469 if (attr_idx != NULL_IDX) { 02470 02471 /* If we're in the module and processing a module procedure */ 02472 /* and this procedure is declared inside this module, then */ 02473 /* skip processing until we see it in its own declaration. */ 02474 02475 if (ATP_PROC(attr_idx) == Module_Proc && 02476 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module && 02477 !AT_USE_ASSOCIATED(attr_idx)) { 02478 attr_idx = NULL_IDX; 02479 } 02480 else { 02481 attr_idx = ATP_RSLT_IDX(attr_idx); 02482 } 02483 } 02484 break; 02485 02486 case Stmt_Func: 02487 02488 if (!ATS_SF_SEMANTICS_DONE(attr_idx)) { 02489 stmt_func_semantics(attr_idx); 02490 } 02491 attr_idx = NULL_IDX; 02492 break; 02493 02494 default: 02495 attr_idx = NULL_IDX; 02496 break; 02497 } 02498 02499 if (attr_idx == NULL_IDX) { 02500 goto EXIT; 02501 } 02502 02503 if (!ATD_OFFSET_ASSIGNED(attr_idx)) { 02504 02505 # ifdef _DEBUG 02506 if (ATD_CLASS(attr_idx) == Compiler_Tmp && 02507 ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX && 02508 !ATD_SYMBOLIC_CONSTANT(attr_idx)) { 02509 PRINTMSG(AT_DEF_LINE(attr_idx), 836, Internal, 02510 AT_DEF_COLUMN(attr_idx), 02511 AT_OBJ_NAME_PTR(attr_idx)); 02512 } 02513 # endif 02514 02515 if (ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX) { 02516 assign_storage_blk(attr_idx); 02517 } 02518 02519 switch (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx))) { 02520 02521 case Static: 02522 case Static_Local: 02523 case Static_Named: 02524 02525 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX && 02526 BD_ARRAY_SIZE(ATD_ARRAY_IDX(attr_idx))==Symbolic_Constant_Size){ 02527 NTR_ATTR_LIST_TBL(al_idx); 02528 AL_ATTR_IDX(al_idx) = attr_idx; 02529 AL_NEXT_IDX(al_idx) = symbolic_constant_array_list; 02530 symbolic_constant_array_list = al_idx; 02531 } 02532 else { 02533 assign_offset(attr_idx); /* assign offsets to static storage */ 02534 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 02535 } 02536 break; 02537 02538 case Stack: 02539 02540 if (SB_HOSTED_STACK(ATD_STOR_BLK_IDX(attr_idx))) { 02541 02542 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX && 02543 BD_ARRAY_SIZE(ATD_ARRAY_IDX(attr_idx)) == 02544 Symbolic_Constant_Size) { 02545 NTR_ATTR_LIST_TBL(al_idx); 02546 AL_ATTR_IDX(al_idx) = attr_idx; 02547 AL_NEXT_IDX(al_idx) = symbolic_constant_array_list; 02548 symbolic_constant_array_list = al_idx; 02549 } 02550 else { 02551 02552 # if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK) 02553 assign_offset(attr_idx); /* Assign to hosted stack */ 02554 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 02555 # else 02556 /* Check so the item does not exceed max storage size */ 02557 02558 stor_bit_size_of(attr_idx, TRUE, FALSE); 02559 # endif 02560 } 02561 } 02562 else if (!AT_DCL_ERR(attr_idx)) { 02563 02564 /* Check so the item does not exceed max storage size */ 02565 02566 stor_bit_size_of(attr_idx, TRUE, FALSE); 02567 } 02568 break; 02569 02570 case Equivalenced: 02571 break; 02572 02573 case Task_Common: 02574 case Threadprivate: 02575 02576 if (ATD_CLASS(attr_idx) == Compiler_Tmp && 02577 ATD_DATA_INIT(attr_idx) && 02578 ATD_FLD(attr_idx) == AT_Tbl_Idx) { 02579 ATD_OFFSET_FLD(attr_idx) = ATD_OFFSET_FLD(ATD_TMP_IDX(attr_idx)); 02580 ATD_OFFSET_IDX(attr_idx) = ATD_OFFSET_IDX(ATD_TMP_IDX(attr_idx)); 02581 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 02582 } 02583 else { 02584 if (! ATD_OFFSET_ASSIGNED(attr_idx)) { 02585 assign_offset(attr_idx); /* Assign to task common */ 02586 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 02587 } 02588 } 02589 02590 break; 02591 02592 case Based: 02593 case Formal: 02594 case Common: 02595 02596 if (ATD_CLASS(attr_idx) == Compiler_Tmp && 02597 ATD_DATA_INIT(attr_idx) && 02598 ATD_FLD(attr_idx) == AT_Tbl_Idx) { 02599 ATD_OFFSET_FLD(attr_idx) = ATD_OFFSET_FLD(ATD_TMP_IDX(attr_idx)); 02600 ATD_OFFSET_IDX(attr_idx) = ATD_OFFSET_IDX(ATD_TMP_IDX(attr_idx)); 02601 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 02602 } 02603 break; 02604 02605 default: 02606 break; 02607 } 02608 } 02609 02610 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 02611 02612 if (SB_MERGED_BLK_IDX(sb_idx) != NULL_IDX) { 02613 sb_idx = SB_MERGED_BLK_IDX(sb_idx); 02614 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 02615 } 02616 02617 if (SB_DEF_MULT_SCPS(sb_idx) || SB_HAS_RENAMES(sb_idx)) { 02618 ATD_EQUIV(attr_idx) = TRUE; 02619 } 02620 02621 # if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK) 02622 02623 if (SB_HOSTED_STACK(sb_idx) && 02624 SB_SCP_IDX(sb_idx) != curr_scp_idx && 02625 tmp_scp_idx != curr_scp_idx) { 02626 02627 /* This is the host associated stack and it is host */ 02628 /* associated into this scope. This is the first time */ 02629 /* this storage block has been seen in this scope */ 02630 /* because tmp_scp_idx != curr_scp_idx. Add the storage */ 02631 /* blocks tmp to this scope and set tmp_scp_idx to this */ 02632 /* scope. When the scope change, tmp_scp_idx will not */ 02633 /* change until the tmp has been added to the new scope. */ 02634 /* The storage block's tmp is a tmp whose offset is one */ 02635 /* storage word size less than the total length of the */ 02636 /* block, with a length of one storage word size. This */ 02637 /* way, the ccg/rcg will get the length of the storage */ 02638 /* block correct. (We do not pass them length, they */ 02639 /* calculate it themselves.) */ 02640 02641 if (SB_LAST_ATTR_LIST(sb_idx) != NULL_IDX) { 02642 ADD_ATTR_TO_LOCAL_LIST(AL_ATTR_IDX(SB_LAST_ATTR_LIST(sb_idx))); 02643 tmp_scp_idx = curr_scp_idx; 02644 } 02645 } 02646 # endif 02647 02648 # ifdef _DEBUG 02649 if ((ATD_CLASS(attr_idx) == Variable || 02650 ATD_CLASS(attr_idx) == Function_Result || 02651 ATD_CLASS(attr_idx) == Compiler_Tmp) && 02652 ATD_OFFSET_ASSIGNED(attr_idx) && 02653 ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx && 02654 fold_relationals(ATD_OFFSET_IDX(attr_idx), 02655 CN_INTEGER_ZERO_IDX, 02656 Lt_Opr)) { 02657 PRINTMSG(AT_DEF_LINE(attr_idx), 1004, Internal, 02658 AT_DEF_COLUMN(attr_idx), 02659 AT_OBJ_NAME_PTR(attr_idx), 02660 attr_idx); 02661 } 02662 # endif 02663 } 02664 else { 02665 local_attr_idx = attr_idx; 02666 02667 while (AT_ATTR_LINK(attr_idx) != NULL_IDX && 02668 ! AT_IGNORE_ATTR_LINK(attr_idx)) { 02669 attr_idx = AT_ATTR_LINK(attr_idx); 02670 } 02671 02672 # if defined(COARRAY_FORTRAN) 02673 02674 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 02675 ATD_PE_ARRAY_IDX(attr_idx) && 02676 (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 02677 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) { 02678 PRINTMSG(AT_DEF_LINE(local_attr_idx), 1580, Error, 02679 AT_DEF_COLUMN(local_attr_idx), 02680 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)), 02681 AT_OBJ_NAME_PTR(attr_idx)); 02682 } 02683 # endif 02684 02685 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 02686 ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX) { 02687 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 02688 02689 # if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK) 02690 02691 if (SB_HOSTED_STACK(sb_idx) && 02692 SB_SCP_IDX(sb_idx) != curr_scp_idx && 02693 tmp_scp_idx != curr_scp_idx) { 02694 02695 /* This is the host associated stack and it is host */ 02696 /* associated into this scope. This is the first time */ 02697 /* this storage block has been seen in this scope */ 02698 /* because tmp_scp_idx != curr_scp_idx. Add the storage */ 02699 /* blocks tmp to this scope and set tmp_scp_idx to this */ 02700 /* scope. When the scope change, tmp_scp_idx will not */ 02701 /* change until the tmp has been added to the new scope. */ 02702 /* The storage block's tmp is a tmp whose offset is one */ 02703 /* storage word size less than the total length of the */ 02704 /* block, with a length of one storage word size. This */ 02705 /* way, the ccg/rcg will get the length of the storage */ 02706 /* block correct. (We do not pass them length, they */ 02707 /* calculate it themselves.) */ 02708 02709 /* WARNING - This tmp_scp scheme will only work if there */ 02710 /* is 1 hosted stack block. */ 02711 02712 if (SB_LAST_ATTR_LIST(sb_idx) != NULL_IDX) { 02713 ADD_ATTR_TO_LOCAL_LIST(AL_ATTR_IDX(SB_LAST_ATTR_LIST(sb_idx))); 02714 tmp_scp_idx = curr_scp_idx; 02715 } 02716 } 02717 # endif 02718 02719 if (ATD_AUXILIARY(attr_idx) || SB_AUXILIARY(sb_idx)) { 02720 PRINTMSG(AT_DEF_LINE(attr_idx), 607, Error, 02721 AT_DEF_COLUMN(attr_idx), 02722 AT_OBJ_NAME_PTR(attr_idx)); 02723 AT_DCL_ERR(attr_idx) = TRUE; 02724 AT_DCL_ERR(local_attr_idx) = TRUE; 02725 } 02726 02727 # ifdef _DEBUG 02728 02729 /* Make sure if this is on the stack that it has been moved */ 02730 /* to a host associated storage block. */ 02731 02732 if (SB_BLK_TYPE(sb_idx) == Stack && 02733 SCP_SB_HOSTED_STACK_IDX(SB_SCP_IDX(sb_idx)) != sb_idx) { 02734 PRINTMSG(AT_DEF_LINE(attr_idx), 850, Internal, 02735 AT_DEF_COLUMN(attr_idx), 02736 AT_OBJ_NAME_PTR(attr_idx)); 02737 } 02738 # endif 02739 } 02740 } 02741 02742 EXIT: 02743 02744 TRACE (Func_Exit, "final_attr_semantics", NULL); 02745 02746 return; 02747 02748 } /* final_attr_semantics */ 02749 02750 /******************************************************************************\ 02751 |* *| 02752 |* Description: *| 02753 |* Allocates storage and offsets for all COMMON blocks. *| 02754 |* *| 02755 |* Input parameters: *| 02756 |* NONE *| 02757 |* *| 02758 |* Output parameters: *| 02759 |* NONE *| 02760 |* *| 02761 |* Returns: *| 02762 |* NONE *| 02763 |* *| 02764 \******************************************************************************/ 02765 static void check_and_allocate_common_storage(int sb_idx) 02766 02767 { 02768 size_offset_type adjust_by; 02769 int attr_idx; 02770 boolean equived; 02771 int group; 02772 int item; 02773 size_offset_type largest_len; 02774 size_offset_type left; 02775 size_offset_type logical_result; 02776 int name_idx; 02777 size_offset_type new_len; 02778 int next_attr_idx; 02779 size_offset_type result; 02780 size_offset_type save_offset; 02781 02782 # if !defined(_TARGET_DOUBLE_ALIGN) 02783 size_offset_type right; 02784 # else 02785 boolean equal_zero; 02786 boolean save_dalign_opt; 02787 # endif 02788 02789 # if !defined(_ERROR_DUPLICATE_GLOBALS) 02790 boolean issue_message; 02791 # endif 02792 02793 02794 TRACE (Func_Entry, "check_and_allocate_common_storage", NULL); 02795 02796 # if defined(_ERROR_DUPLICATE_GLOBALS) 02797 02798 attr_idx = srch_sym_tbl(SB_NAME_PTR(sb_idx), 02799 SB_NAME_LEN(sb_idx), 02800 &name_idx); 02801 02802 if (attr_idx == NULL_IDX) { 02803 attr_idx = srch_host_sym_tbl(SB_NAME_PTR(sb_idx), 02804 SB_NAME_LEN(sb_idx), 02805 &name_idx, 02806 FALSE); 02807 } 02808 02809 if (attr_idx != NULL_IDX) { 02810 02811 switch (AT_OBJ_CLASS(attr_idx)) { 02812 case Data_Obj: 02813 02814 if (ATD_CLASS(attr_idx) == Constant) { 02815 02816 if (SB_USE_ASSOCIATED(sb_idx)) { 02817 PRINTMSG(AT_DEF_LINE(attr_idx), 1033, Ansi, 02818 AT_DEF_COLUMN(attr_idx), 02819 SB_NAME_PTR(sb_idx)); 02820 } 02821 else if (SB_HOST_ASSOCIATED(sb_idx)) { 02822 PRINTMSG(AT_DEF_LINE(attr_idx), 1032, Ansi, 02823 AT_DEF_COLUMN(attr_idx), 02824 SB_NAME_PTR(sb_idx)); 02825 } 02826 else { 02827 PRINTMSG(AT_DEF_LINE(attr_idx), 547, Ansi, 02828 AT_DEF_COLUMN(attr_idx), 02829 SB_NAME_PTR(sb_idx)); 02830 } 02831 } 02832 break; 02833 02834 case Pgm_Unit: 02835 02836 if (ATP_PROC(attr_idx) == Intrin_Proc && 02837 AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) { 02838 02839 if (SB_USE_ASSOCIATED(sb_idx)) { 02840 PRINTMSG(AT_DEF_LINE(attr_idx), 1031, Error, 02841 AT_DEF_COLUMN(attr_idx), 02842 SB_NAME_PTR(sb_idx)); 02843 } 02844 else if (SB_HOST_ASSOCIATED(sb_idx)) { 02845 PRINTMSG(AT_DEF_LINE(attr_idx), 1030, Error, 02846 AT_DEF_COLUMN(attr_idx), 02847 SB_NAME_PTR(sb_idx)); 02848 } 02849 else { 02850 PRINTMSG(AT_DEF_LINE(attr_idx), 1005, Error, 02851 AT_DEF_COLUMN(attr_idx), 02852 SB_NAME_PTR(sb_idx)); 02853 } 02854 } 02855 break; 02856 02857 case Interface: 02858 02859 if (AT_IS_INTRIN(attr_idx) && 02860 AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) { 02861 02862 if (SB_USE_ASSOCIATED(sb_idx)) { 02863 PRINTMSG(AT_DEF_LINE(attr_idx), 1031, Error, 02864 AT_DEF_COLUMN(attr_idx), 02865 SB_NAME_PTR(sb_idx)); 02866 } 02867 else if (SB_HOST_ASSOCIATED(sb_idx)) { 02868 PRINTMSG(AT_DEF_LINE(attr_idx), 1030, Error, 02869 AT_DEF_COLUMN(attr_idx), 02870 SB_NAME_PTR(sb_idx)); 02871 } 02872 else { 02873 PRINTMSG(AT_DEF_LINE(attr_idx), 1005, Error, 02874 AT_DEF_COLUMN(attr_idx), 02875 SB_NAME_PTR(sb_idx)); 02876 } 02877 } 02878 break; 02879 } 02880 } 02881 02882 # else 02883 02884 issue_message = GET_MESSAGE_TBL(message_warning_tbl, 1033) || 02885 GET_MESSAGE_TBL(message_error_tbl, 1033) || 02886 GET_MESSAGE_TBL(message_warning_tbl, 1032) || 02887 GET_MESSAGE_TBL(message_error_tbl, 1032) || 02888 GET_MESSAGE_TBL(message_warning_tbl, 547) || 02889 GET_MESSAGE_TBL(message_error_tbl, 547) || 02890 GET_MESSAGE_TBL(message_warning_tbl, 1029) || 02891 GET_MESSAGE_TBL(message_error_tbl, 1029) || 02892 GET_MESSAGE_TBL(message_warning_tbl, 1028) || 02893 GET_MESSAGE_TBL(message_error_tbl, 1028) || 02894 GET_MESSAGE_TBL(message_warning_tbl, 714) || 02895 GET_MESSAGE_TBL(message_error_tbl, 714); 02896 02897 02898 if (issue_message || on_off_flags.issue_ansi_messages) { 02899 attr_idx = srch_sym_tbl(SB_NAME_PTR(sb_idx), 02900 SB_NAME_LEN(sb_idx), 02901 &name_idx); 02902 02903 if (attr_idx == NULL_IDX) { 02904 attr_idx = srch_host_sym_tbl(SB_NAME_PTR(sb_idx), 02905 SB_NAME_LEN(sb_idx), 02906 &name_idx, 02907 FALSE); 02908 } 02909 02910 if (attr_idx != NULL_IDX) { 02911 02912 switch (AT_OBJ_CLASS(attr_idx)) { 02913 case Data_Obj: 02914 02915 if (ATD_CLASS(attr_idx) == Constant) { 02916 02917 if (SB_USE_ASSOCIATED(sb_idx)) { 02918 PRINTMSG(AT_DEF_LINE(attr_idx), 1033, Ansi, 02919 AT_DEF_COLUMN(attr_idx), 02920 SB_NAME_PTR(sb_idx)); 02921 } 02922 else if (SB_HOST_ASSOCIATED(sb_idx)) { 02923 PRINTMSG(AT_DEF_LINE(attr_idx), 1032, Ansi, 02924 AT_DEF_COLUMN(attr_idx), 02925 SB_NAME_PTR(sb_idx)); 02926 } 02927 else { 02928 PRINTMSG(AT_DEF_LINE(attr_idx), 547, Ansi, 02929 AT_DEF_COLUMN(attr_idx), 02930 SB_NAME_PTR(sb_idx)); 02931 } 02932 } 02933 break; 02934 02935 case Pgm_Unit: 02936 02937 if (ATP_PROC(attr_idx) == Intrin_Proc && 02938 AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) { 02939 02940 if (SB_USE_ASSOCIATED(sb_idx)) { 02941 PRINTMSG(AT_DEF_LINE(attr_idx), 1029, Ansi, 02942 AT_DEF_COLUMN(attr_idx), 02943 SB_NAME_PTR(sb_idx)); 02944 } 02945 else if (SB_HOST_ASSOCIATED(sb_idx)) { 02946 PRINTMSG(AT_DEF_LINE(attr_idx), 1028, Ansi, 02947 AT_DEF_COLUMN(attr_idx), 02948 SB_NAME_PTR(sb_idx)); 02949 } 02950 else { 02951 PRINTMSG(AT_DEF_LINE(attr_idx), 714, Ansi, 02952 AT_DEF_COLUMN(attr_idx), 02953 SB_NAME_PTR(sb_idx)); 02954 } 02955 } 02956 break; 02957 02958 case Interface: 02959 02960 if (AT_IS_INTRIN(attr_idx) && 02961 AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) { 02962 02963 if (SB_USE_ASSOCIATED(sb_idx)) { 02964 PRINTMSG(AT_DEF_LINE(attr_idx), 1029, Ansi, 02965 AT_DEF_COLUMN(attr_idx), 02966 SB_NAME_PTR(sb_idx)); 02967 } 02968 else if (SB_HOST_ASSOCIATED(sb_idx)) { 02969 PRINTMSG(AT_DEF_LINE(attr_idx), 1028, Ansi, 02970 AT_DEF_COLUMN(attr_idx), 02971 SB_NAME_PTR(sb_idx)); 02972 } 02973 else { 02974 PRINTMSG(AT_DEF_LINE(attr_idx), 714, Ansi, 02975 AT_DEF_COLUMN(attr_idx), 02976 SB_NAME_PTR(sb_idx)); 02977 } 02978 } 02979 break; 02980 } 02981 } 02982 } 02983 # endif 02984 02985 if (SB_USE_ASSOCIATED(sb_idx) || !SB_COMMON_NEEDS_OFFSET(sb_idx)) { 02986 goto EXIT; 02987 } 02988 02989 if (SB_FIRST_ATTR_IDX(sb_idx) == NULL_IDX && !SB_DCL_ERR(sb_idx)) { 02990 02991 if (SB_SAVED(sb_idx)) { 02992 02993 /* The common block was declared in a save statement, but */ 02994 /* not as an actual common block. */ 02995 02996 PRINTMSG(SB_DEF_LINE(sb_idx), 688, Error, 02997 SB_DEF_COLUMN(sb_idx), 02998 SB_NAME_PTR(sb_idx)); 02999 SB_DCL_ERR(sb_idx) = TRUE; 03000 } 03001 else if (SB_BLK_TYPE(sb_idx) == Threadprivate) { 03002 PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error, 03003 SB_DEF_COLUMN(sb_idx), 03004 SB_NAME_PTR(sb_idx), 03005 "THREAD_PRIVATE"); 03006 SB_DCL_ERR(sb_idx) = TRUE; 03007 } 03008 else if (SB_CACHE_ALIGN(sb_idx)) { 03009 PRINTMSG(SB_DEF_LINE(sb_idx), 1168, Error, 03010 SB_DEF_COLUMN(sb_idx), 03011 SB_NAME_PTR(sb_idx)); 03012 SB_DCL_ERR(sb_idx) = TRUE; 03013 } 03014 else if (SB_SECTION_GP(sb_idx)) { 03015 PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error, 03016 SB_DEF_COLUMN(sb_idx), 03017 SB_NAME_PTR(sb_idx), 03018 "SECTION_GP"); 03019 SB_DCL_ERR(sb_idx) = TRUE; 03020 } 03021 else if (SB_SECTION_NON_GP(sb_idx)) { 03022 PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error, 03023 SB_DEF_COLUMN(sb_idx), 03024 SB_NAME_PTR(sb_idx), 03025 "SECTION_NON_GP"); 03026 SB_DCL_ERR(sb_idx) = TRUE; 03027 } 03028 # if 0 03029 else if (SB_ALIGN_SYMBOL(sb_idx)) { 03030 PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error, 03031 SB_DEF_COLUMN(sb_idx), 03032 SB_NAME_PTR(sb_idx), 03033 "ALIGN_SYMBOL"); 03034 SB_DCL_ERR(sb_idx) = TRUE; 03035 } 03036 else if (SB_FILL_SYMBOL(sb_idx)) { 03037 PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error, 03038 SB_DEF_COLUMN(sb_idx), 03039 SB_NAME_PTR(sb_idx), 03040 "FILL_SYMBOL"); 03041 SB_DCL_ERR(sb_idx) = TRUE; 03042 } 03043 # endif 03044 else if (SB_DCL_COMMON_DIR(sb_idx)) { 03045 SB_DCL_ERR(sb_idx) = TRUE; 03046 PRINTMSG(SB_DEF_LINE(sb_idx), 1128, Error, 03047 SB_DEF_COLUMN(sb_idx), 03048 SB_NAME_PTR(sb_idx)); 03049 } 03050 else if (SB_BLK_TYPE(sb_idx) == Task_Common) { 03051 SB_DCL_ERR(sb_idx) = TRUE; 03052 PRINTMSG(SB_DEF_LINE(sb_idx), 690, Error, 03053 SB_DEF_COLUMN(sb_idx), 03054 SB_NAME_PTR(sb_idx)); 03055 } 03056 } 03057 03058 if (SB_DCL_COMMON_DIR(sb_idx) && SB_BLK_TYPE(sb_idx) == Task_Common) { 03059 SB_DCL_ERR(sb_idx) = TRUE; 03060 PRINTMSG(SB_DEF_LINE(sb_idx), 1129, Error, 03061 SB_DEF_COLUMN(sb_idx), 03062 SB_NAME_PTR(sb_idx)); 03063 } 03064 03065 attr_idx = SB_FIRST_ATTR_IDX(sb_idx); 03066 equived = FALSE; 03067 03068 while (attr_idx != NULL_IDX && !equived) { 03069 equived = equived || ATD_EQUIV(attr_idx); 03070 attr_idx = ATD_NEXT_MEMBER_IDX(attr_idx); 03071 } 03072 03073 if (SB_PAD_BLK(sb_idx) && equived) { /* -a pad and equiv don't go together */ 03074 PRINTMSG(SB_DEF_LINE(sb_idx), 1351, Warning, 03075 SB_DEF_COLUMN(sb_idx), 03076 SB_BLANK_COMMON(sb_idx) ? 03077 "" : SB_NAME_PTR(sb_idx)); 03078 SB_PAD_BLK(sb_idx)= FALSE; 03079 } 03080 03081 next_attr_idx = SB_FIRST_ATTR_IDX(sb_idx); 03082 largest_len.fld = SB_LEN_FLD(sb_idx); 03083 largest_len.idx = SB_LEN_IDX(sb_idx); 03084 03085 while (next_attr_idx != NULL_IDX) { 03086 attr_idx = next_attr_idx; 03087 next_attr_idx = ATD_NEXT_MEMBER_IDX(attr_idx); 03088 03089 if (AT_DCL_ERR(attr_idx)) { 03090 03091 /* Error - Do not attempt to assign offset. */ 03092 03093 } 03094 else if (!ATD_EQUIV(attr_idx) || num_prog_unit_errors != 0) { 03095 03096 /* We do not do equivalence processing if we found any errors in */ 03097 /* this program unit. Error recovery doesn't work too well. */ 03098 03099 assign_offset(attr_idx); /* Equivalence */ 03100 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 03101 ATD_EQUIV(attr_idx) = equived; 03102 } 03103 else { 03104 03105 if (ATD_OFFSET_IDX(attr_idx) == NULL_IDX) { 03106 ATD_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX; 03107 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 03108 } 03109 03110 save_offset.fld = ATD_OFFSET_FLD(attr_idx); 03111 save_offset.idx = ATD_OFFSET_IDX(attr_idx); 03112 03113 # if defined(_TARGET_DOUBLE_ALIGN) 03114 save_dalign_opt = cmd_line_flags.dalign; 03115 cmd_line_flags.dalign = FALSE; 03116 03117 /* Offset will not get daligned, because dalign flag = FALSE */ 03118 /* If daligning is necessary, it will be done by hand here. */ 03119 03120 assign_offset(attr_idx); /* Equivalence */ 03121 03122 cmd_line_flags.dalign = save_dalign_opt; 03123 left.fld = ATD_OFFSET_FLD(attr_idx); 03124 left.idx = ATD_OFFSET_IDX(attr_idx); 03125 03126 if (!size_offset_binary_calc(&left, 03127 &save_offset, 03128 Minus_Opr, 03129 &adjust_by)) { 03130 AT_DCL_ERR(attr_idx) = TRUE; 03131 } 03132 03133 # else 03134 assign_offset(attr_idx); /* Equivalence */ 03135 03136 left.fld = ATD_OFFSET_FLD(attr_idx); 03137 left.idx = ATD_OFFSET_IDX(attr_idx); 03138 03139 if (!size_offset_binary_calc(&left, 03140 &save_offset, 03141 Minus_Opr, 03142 &adjust_by)) { 03143 AT_DCL_ERR(attr_idx) = TRUE; 03144 } 03145 03146 if (ATD_OFFSET_ASSIGNED(attr_idx)) { 03147 right.fld = CN_Tbl_Idx; 03148 right.idx = CN_INTEGER_ZERO_IDX; 03149 03150 size_offset_logical_calc(&adjust_by, &right, Eq_Opr, &result); 03151 03152 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 03153 03154 /* Offset for this attr is assigned already, because it is in */ 03155 /* a previous equivalence group. This offset should agree */ 03156 /* with the new offset just assigned. If it doesn't continue */ 03157 /* and issue an error later, when we can give a better line */ 03158 /* and column number. If it is zero, continue to next attr. */ 03159 03160 continue; 03161 } 03162 } 03163 # endif 03164 03165 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 03166 03167 while (group != NULL_IDX) { 03168 item = group; 03169 03170 while (item != NULL_IDX) { 03171 03172 # if _DEBUG 03173 if (!ATD_EQUIV(EQ_ATTR_IDX(item)) && 03174 !AT_DCL_ERR(EQ_ATTR_IDX(item)) && 03175 ATD_CLASS(EQ_ATTR_IDX(item)) == Variable) { 03176 PRINTMSG(AT_DEF_LINE(EQ_ATTR_IDX(item)), 03177 1019, 03178 Internal, 03179 AT_DEF_COLUMN(EQ_ATTR_IDX(item)), 03180 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 03181 } 03182 # endif 03183 03184 if (EQ_ATTR_IDX(item) == attr_idx) { 03185 goto FOUND; 03186 } 03187 item = EQ_NEXT_EQUIV_OBJ(item); 03188 } 03189 group = EQ_NEXT_EQUIV_GRP(group); 03190 } 03191 03192 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 03193 03194 /* This is a data initialized item. It is equivalenced to a tmp. */ 03195 /* The tmps offset gets set in final_attr_semantics. */ 03196 03197 continue; 03198 03199 FOUND: 03200 03201 if (ATD_OFFSET_ASSIGNED(attr_idx)) { 03202 03203 if (fold_relationals(ATD_OFFSET_IDX(attr_idx), 03204 save_offset.idx, 03205 Ne_Opr)) { 03206 PRINTMSG(EQ_LINE_NUM(item), 862, Error, 03207 EQ_COLUMN_NUM(item), 03208 AT_OBJ_NAME_PTR(attr_idx)); 03209 } 03210 continue; 03211 } 03212 03213 # if defined(_TARGET_DOUBLE_ALIGN) 03214 03215 else { 03216 if (EQ_DALIGN_ME(item)) { 03217 C_TO_F_INT(result.constant, TARGET_BITS_PER_WORD * 2, 03218 CG_INTEGER_DEFAULT_TYPE); 03219 result.fld = NO_Tbl_Idx; 03220 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 03221 03222 if (!size_offset_binary_calc(&adjust_by, 03223 &result, 03224 Mod_Opr, 03225 &result)) { 03226 AT_DCL_ERR(attr_idx) = TRUE; 03227 } 03228 03229 left.fld = CN_Tbl_Idx; 03230 left.idx = CN_INTEGER_ZERO_IDX; 03231 03232 size_offset_logical_calc(&left, &result, Eq_Opr, &result); 03233 03234 equal_zero = THIS_IS_TRUE(result.constant, result.type_idx); 03235 03236 if ((equal_zero && EQ_DALIGN_SHIFT(item)) || 03237 (!equal_zero && !EQ_DALIGN_SHIFT(item))) { 03238 03239 if (cmd_line_flags.dalign) { 03240 03241 /* If offset % TARGET_BITS == 0, the new offset is on a */ 03242 /* double word boundary. If !EQ_DALIGN_SHIFT then the */ 03243 /* equivalence group is on a double word boundary. What */ 03244 /* the above if statement says is that if both the new */ 03245 /* offset and the equivalence group are on a double word */ 03246 /* boundary - do nothing. If neither one is on a double */ 03247 /* word boundary, do nothing. But if one is on a double */ 03248 /* word boundary and the other is not, adjust new offset.*/ 03249 03250 result.fld = CN_Tbl_Idx; 03251 result.idx = CN_INTEGER_BITS_PER_WORD_IDX; 03252 03253 if (!size_offset_binary_calc(&adjust_by, 03254 &result, 03255 Plus_Opr, 03256 &adjust_by)) { 03257 AT_DCL_ERR(attr_idx) = TRUE; 03258 } 03259 03260 left.fld = ATD_OFFSET_FLD(attr_idx); 03261 left.idx = ATD_OFFSET_IDX(attr_idx); 03262 03263 if (!size_offset_binary_calc(&left, 03264 &result, 03265 Plus_Opr, 03266 &result)) { 03267 AT_DCL_ERR(attr_idx) = TRUE; 03268 } 03269 03270 if (result.fld == NO_Tbl_Idx) { 03271 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 03272 ATD_OFFSET_IDX(attr_idx) = ntr_const_tbl( 03273 result.type_idx, 03274 FALSE, 03275 result.constant); 03276 } 03277 else { 03278 ATD_OFFSET_FLD(attr_idx) = result.fld; 03279 ATD_OFFSET_IDX(attr_idx) = result.idx; 03280 } 03281 03282 result.fld = CN_Tbl_Idx; 03283 result.idx = CN_INTEGER_BITS_PER_WORD_IDX; 03284 left.fld = SB_LEN_FLD(sb_idx); 03285 left.idx = SB_LEN_IDX(sb_idx); 03286 03287 if (!size_offset_binary_calc(&left, 03288 &result, 03289 Plus_Opr, 03290 &result)) { 03291 AT_DCL_ERR(attr_idx) = TRUE; 03292 } 03293 03294 if (result.fld == NO_Tbl_Idx) { 03295 SB_LEN_FLD(sb_idx) = CN_Tbl_Idx; 03296 SB_LEN_IDX(sb_idx) = ntr_const_tbl(result.type_idx, 03297 FALSE, 03298 result.constant); 03299 } 03300 else { 03301 SB_LEN_FLD(sb_idx) = result.fld; 03302 SB_LEN_IDX(sb_idx) = result.idx; 03303 } 03304 03305 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 03306 03307 /* -a dalign is always on for IRIX and there is no */ 03308 /* way to shut it off, so we do not need to issue */ 03309 /* this warning for IRIX. */ 03310 03311 PRINTMSG(AT_DEF_LINE(attr_idx), 1013, Warning, 03312 AT_DEF_COLUMN(attr_idx), 03313 AT_OBJ_NAME_PTR(attr_idx), 03314 SB_BLANK_COMMON(sb_idx) ? 03315 "" : SB_NAME_PTR(sb_idx)); 03316 # endif 03317 } 03318 else { /* Cannot double align */ 03319 PRINTMSG(AT_DEF_LINE(attr_idx), 1161, Caution, 03320 AT_DEF_COLUMN(attr_idx), 03321 AT_OBJ_NAME_PTR(attr_idx), 03322 SB_BLANK_COMMON(sb_idx) ? 03323 "" : SB_NAME_PTR(sb_idx)); 03324 } 03325 } 03326 } 03327 } 03328 # endif 03329 03330 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 03331 item = group; 03332 03333 while (item != NULL_IDX) { 03334 03335 if (!ATD_OFFSET_ASSIGNED(EQ_ATTR_IDX(item))) { 03336 03337 if (ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) == NULL_IDX) { 03338 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx; 03339 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = ntr_const_tbl( 03340 adjust_by.type_idx, 03341 FALSE, 03342 adjust_by.constant); 03343 } 03344 else { 03345 left.fld = ATD_OFFSET_FLD(EQ_ATTR_IDX(item)); 03346 left.idx = ATD_OFFSET_IDX(EQ_ATTR_IDX(item)); 03347 03348 if (!size_offset_binary_calc(&left, 03349 &adjust_by, 03350 Plus_Opr, 03351 &result)) { 03352 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 03353 } 03354 03355 if (result.fld == NO_Tbl_Idx) { 03356 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx; 03357 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = ntr_const_tbl( 03358 result.type_idx, 03359 FALSE, 03360 result.constant); 03361 } 03362 else { 03363 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = result.fld; 03364 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = result.idx; 03365 } 03366 } 03367 03368 ATD_OFFSET_ASSIGNED(EQ_ATTR_IDX(item)) = TRUE; 03369 03370 if (fold_relationals(ATD_OFFSET_IDX(EQ_ATTR_IDX(item)), 03371 CN_INTEGER_ZERO_IDX, 03372 Lt_Opr)) { 03373 PRINTMSG(SB_DEF_LINE(sb_idx), 526, Error, 03374 SB_DEF_COLUMN(sb_idx), 03375 SB_BLANK_COMMON(sb_idx) ? 03376 "" : SB_NAME_PTR(sb_idx), 03377 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 03378 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = CN_INTEGER_ZERO_IDX; 03379 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx; 03380 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 03381 } 03382 03383 new_len = stor_bit_size_of(EQ_ATTR_IDX(item), TRUE, FALSE); 03384 left.fld = ATD_OFFSET_FLD(EQ_ATTR_IDX(item)); 03385 left.idx = ATD_OFFSET_IDX(EQ_ATTR_IDX(item)); 03386 03387 if (!size_offset_binary_calc(&left, &new_len, Plus_Opr,&result)){ 03388 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 03389 } 03390 03391 size_offset_logical_calc(&result, 03392 &largest_len, 03393 Gt_Opr, 03394 &logical_result); 03395 03396 if (THIS_IS_TRUE(logical_result.constant, 03397 logical_result.type_idx)) { 03398 largest_len = result; 03399 } 03400 } 03401 else if (!ATD_IN_COMMON(EQ_ATTR_IDX(item))) { 03402 left.fld = EQ_OFFSET_FLD(item); 03403 left.idx = EQ_OFFSET_IDX(item); 03404 03405 if (!size_offset_binary_calc(&left,&adjust_by,Plus_Opr,&result)){ 03406 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 03407 } 03408 03409 left.fld = ATD_OFFSET_FLD(EQ_ATTR_IDX(item)); 03410 left.idx = ATD_OFFSET_IDX(EQ_ATTR_IDX(item)); 03411 03412 size_offset_logical_calc(&left, &result, Ne_Opr,&logical_result); 03413 03414 if (THIS_IS_TRUE(logical_result.constant, 03415 logical_result.type_idx)) { 03416 PRINTMSG(EQ_LINE_NUM(item), 862, Error, 03417 EQ_COLUMN_NUM(item), 03418 AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item))); 03419 } 03420 } 03421 item = EQ_NEXT_EQUIV_OBJ(item); 03422 } 03423 } 03424 } 03425 left.fld = SB_LEN_FLD(sb_idx); 03426 left.idx = SB_LEN_IDX(sb_idx); 03427 03428 size_offset_logical_calc(&largest_len, &left, Gt_Opr, &logical_result); 03429 03430 if (!THIS_IS_TRUE(logical_result.constant, 03431 logical_result.type_idx)) { 03432 largest_len.idx = SB_LEN_IDX(sb_idx); 03433 largest_len.fld = SB_LEN_FLD(sb_idx); 03434 } 03435 03436 align_bit_length(&largest_len, TARGET_BITS_PER_WORD); 03437 03438 if (largest_len.fld == NO_Tbl_Idx) { 03439 largest_len.fld = CN_Tbl_Idx; 03440 largest_len.idx = ntr_const_tbl(largest_len.type_idx, 03441 FALSE, 03442 largest_len.constant); 03443 } 03444 03445 SB_LEN_FLD(sb_idx) = largest_len.fld; 03446 SB_LEN_IDX(sb_idx) = largest_len.idx; 03447 03448 SB_COMMON_NEEDS_OFFSET(sb_idx) = FALSE; 03449 03450 if (cmd_line_flags.taskcommon && !SB_DCL_COMMON_DIR(sb_idx)) { 03451 03452 /* Switch all common blocks to task common */ 03453 03454 SB_BLK_TYPE(sb_idx) = Task_Common; 03455 SB_RUNTIME_INIT(sb_idx) = FALSE; 03456 } 03457 03458 EXIT: 03459 03460 TRACE (Func_Exit, "check_and_allocate_common_storage", NULL); 03461 03462 return; 03463 03464 } /* check_and_allocate_common_storage */ 03465 03466 /******************************************************************************\ 03467 |* *| 03468 |* Description: *| 03469 |* Resolves multiple storage blocks in the current scope to one block. *| 03470 |* *| 03471 |* Input parameters: *| 03472 |* NONE *| 03473 |* *| 03474 |* Output parameters: *| 03475 |* NONE *| 03476 |* *| 03477 |* Returns: *| 03478 |* NONE *| 03479 |* *| 03480 \******************************************************************************/ 03481 static void storage_blk_resolution() 03482 { 03483 int attr_idx; 03484 int ga_idx; 03485 int gac_idx; 03486 int ga_pgm_idx; 03487 int host_sb_idx; 03488 msg_severities_type msg_level; 03489 int name_idx; 03490 size_offset_type result; 03491 boolean same_common_block; 03492 int same_sb_idx; 03493 int sb_idx; 03494 03495 # if !defined(_SEPARATE_NONCOMMON_EQUIV_GROUPS) 03496 int group; 03497 int item; 03498 id_str_type name; 03499 int new_sb_idx; 03500 int np_idx; 03501 size_offset_type offset; 03502 # endif 03503 03504 # if defined(_TARGET_DOUBLE_ALIGN) 03505 size_offset_type left; 03506 # endif 03507 03508 03509 TRACE (Func_Entry, "storage_blk_resolution", NULL); 03510 03511 /* Set the data initialized flag for the static initialization stor blk */ 03512 03513 for (sb_idx = 1; sb_idx <= stor_blk_tbl_idx; sb_idx++) { 03514 03515 if (SB_SCP_IDX(sb_idx) != curr_scp_idx) { 03516 continue; 03517 } 03518 03519 if (SB_IS_COMMON(sb_idx)) { 03520 SB_PAD_BLK(sb_idx) = cmd_line_flags.pad; 03521 03522 if (cmd_line_flags.pad_amount != 0) { 03523 SB_PAD_AMOUNT(sb_idx) = cmd_line_flags.pad_amount; 03524 SB_PAD_AMOUNT_SET(sb_idx) = TRUE; 03525 } 03526 03527 check_and_allocate_common_storage(sb_idx); 03528 03529 if (!SB_HIDDEN(sb_idx) && !SB_HOST_ASSOCIATED(sb_idx)) { 03530 03531 if (srch_global_name_tbl(SB_NAME_PTR(sb_idx), 03532 SB_NAME_LEN(sb_idx), 03533 &name_idx)) { 03534 03535 gac_idx = GN_ATTR_IDX(name_idx); 03536 03537 if (GA_OBJ_CLASS(gac_idx) != Common_Block) { 03538 03539 /* Have a common and program unit with same name. The */ 03540 /* common entry is always first and then points to the */ 03541 /* program unit. Add a global attr for the common block. */ 03542 03543 ga_pgm_idx = gac_idx; 03544 gac_idx = ntr_common_in_global_attr_tbl(sb_idx, 03545 name_idx); 03546 03547 GAC_PGM_UNIT_IDX(gac_idx) = ga_pgm_idx; 03548 GN_ATTR_IDX(name_idx) = gac_idx; 03549 03550 # if defined(_ERROR_DUPLICATE_GLOBALS) 03551 msg_level = Error; 03552 # else 03553 msg_level = (GAP_PGM_UNIT(ga_pgm_idx) == Module) ? 03554 Error : Ansi; 03555 # endif 03556 PRINTMSG(SB_DEF_LINE(sb_idx), 1006, msg_level, 03557 SB_DEF_COLUMN(sb_idx), 03558 SB_NAME_PTR(sb_idx), 03559 pgm_unit_str[GAP_PGM_UNIT(ga_pgm_idx)]); 03560 } 03561 else { 03562 same_common_block = !SB_EQUIVALENCED(sb_idx) && 03563 !GAC_EQUIVALENCED(gac_idx); 03564 03565 /* Common block used in another program unit. */ 03566 03567 if (SB_AUXILIARY(sb_idx) ^ GAC_AUXILIARY(gac_idx)) { 03568 same_common_block = FALSE; 03569 PRINTMSG(SB_DEF_LINE(sb_idx), 1276, Warning, 03570 SB_DEF_COLUMN(sb_idx), 03571 SB_NAME_PTR(sb_idx), 03572 "AUXILIARY"); 03573 } 03574 03575 if ((SB_BLK_TYPE(sb_idx) == Task_Common && 03576 !GAC_TASK_COMMON(gac_idx)) || 03577 (SB_BLK_TYPE(sb_idx) != Task_Common && 03578 GAC_TASK_COMMON(gac_idx))) { 03579 same_common_block = FALSE; 03580 03581 PRINTMSG(SB_DEF_LINE(sb_idx), 1276, Warning, 03582 SB_DEF_COLUMN(sb_idx), 03583 SB_NAME_PTR(sb_idx), 03584 "TASK_COMMON"); 03585 } 03586 03587 if (SB_ALIGN_SYMBOL(sb_idx) ^ GAC_ALIGN_SYMBOL(gac_idx)) { 03588 same_common_block = FALSE; 03589 PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning, 03590 SB_DEF_COLUMN(sb_idx), 03591 SB_NAME_PTR(sb_idx), 03592 "ALIGN_SYMBOL"); 03593 } 03594 03595 if (SB_FILL_SYMBOL(sb_idx) ^ GAC_FILL_SYMBOL(gac_idx)) { 03596 same_common_block = FALSE; 03597 PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning, 03598 SB_DEF_COLUMN(sb_idx), 03599 SB_NAME_PTR(sb_idx), 03600 "FILL_SYMBOL"); 03601 } 03602 03603 if (SB_SECTION_GP(sb_idx) ^ GAC_SECTION_GP(gac_idx)) { 03604 same_common_block = FALSE; 03605 PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning, 03606 SB_DEF_COLUMN(sb_idx), 03607 SB_NAME_PTR(sb_idx), 03608 "SECTION_GP"); 03609 } 03610 03611 if (SB_SECTION_NON_GP(sb_idx) ^ GAC_SECTION_NON_GP(gac_idx)) { 03612 same_common_block = FALSE; 03613 PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning, 03614 SB_DEF_COLUMN(sb_idx), 03615 SB_NAME_PTR(sb_idx), 03616 "SECTION_NON_GP"); 03617 } 03618 03619 if (SB_CACHE_ALIGN(sb_idx) ^ GAC_CACHE_ALIGN(gac_idx)) { 03620 same_common_block = FALSE; 03621 PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning, 03622 SB_DEF_COLUMN(sb_idx), 03623 SB_NAME_PTR(sb_idx), 03624 "CACHE_ALIGN"); 03625 } 03626 03627 /* Check to make sure all the members have the same type */ 03628 /* kind and rank. We'll check for same name too. */ 03629 03630 attr_idx = SB_FIRST_ATTR_IDX(sb_idx); 03631 ga_idx = GAC_FIRST_MEMBER_IDX(gac_idx); 03632 03633 while (attr_idx != NULL_IDX && ga_idx != NULL_IDX) { 03634 03635 /* We are looking at all Common block objects, so */ 03636 /* we can assume that these are all Variables. */ 03637 03638 if (!compare_global_type_rank(ga_idx, 03639 NULL_IDX, 03640 attr_idx, 03641 NULL_IDX, 03642 TRUE)) { 03643 same_common_block = FALSE; 03644 # if 0 03645 PRINTMSG(AT_DEF_LINE(attr_idx), 1603, Caution, 03646 AT_DEF_COLUMN(attr_idx), 03647 SB_NAME_PTR(sb_idx)); 03648 # endif 03649 break; 03650 } 03651 attr_idx = ATD_NEXT_MEMBER_IDX(attr_idx); 03652 ga_idx = GAD_NEXT_IDX(ga_idx); 03653 } 03654 03655 if (attr_idx != NULL_IDX || ga_idx != NULL_IDX) { 03656 same_common_block = FALSE; 03657 } 03658 03659 if (!same_common_block) { 03660 GAC_FOUND_DIFFS(gac_idx) = TRUE; 03661 SB_DUPLICATE_COMMON(sb_idx) = FALSE; 03662 } 03663 else if (!GAC_FOUND_DIFFS(gac_idx)) { 03664 SB_DUPLICATE_COMMON(sb_idx) = TRUE; 03665 } 03666 } 03667 } 03668 else { 03669 ntr_global_name_tbl(NULL_IDX, sb_idx, name_idx); 03670 } 03671 } 03672 } 03673 else if (cmd_line_flags.taskcommon) { 03674 03675 /* All module blocks and all static blocks must be switched to */ 03676 /* taskcommon if the -a taskcommon commandline option is specified. */ 03677 03678 if (SB_MODULE(sb_idx) || 03679 SB_BLK_TYPE(sb_idx) == Static || 03680 SB_BLK_TYPE(sb_idx) == Static_Named || 03681 SB_BLK_TYPE(sb_idx) == Static_Local) { 03682 SB_BLK_TYPE(sb_idx) = Task_Common; 03683 } 03684 } 03685 else if (cmd_line_flags.static_threadprivate) { 03686 03687 /* All module blocks and all static blocks must be switched */ 03688 /* to taskcommon if the -a static_threadprivate commandline */ 03689 /* option is specified. */ 03690 03691 if (SB_MODULE(sb_idx) || 03692 SB_BLK_TYPE(sb_idx) == Static || 03693 SB_BLK_TYPE(sb_idx) == Static_Named || 03694 SB_BLK_TYPE(sb_idx) == Static_Local) { 03695 SB_BLK_TYPE(sb_idx) = Threadprivate; 03696 } 03697 } 03698 03699 03700 if (SB_BLK_TYPE(sb_idx) == Equivalenced && SB_HOSTED_STACK(sb_idx)) { 03701 03702 # if defined(_DEBUG) 03703 03704 if (SB_LEN_FLD(sb_idx) != CN_Tbl_Idx) { 03705 PRINTMSG(SB_DEF_LINE(sb_idx), 1201, Internal, SB_DEF_COLUMN(sb_idx), 03706 SB_NAME_PTR(sb_idx)); 03707 } 03708 # endif 03709 03710 result.fld = SB_LEN_FLD(sb_idx); 03711 result.idx = SB_LEN_IDX(sb_idx); 03712 03713 align_bit_length(&result, TARGET_BITS_PER_WORD); 03714 03715 if (result.fld == NO_Tbl_Idx) { 03716 SB_LEN_FLD(sb_idx) = CN_Tbl_Idx; 03717 SB_LEN_IDX(sb_idx) = ntr_const_tbl(result.type_idx, 03718 FALSE, 03719 result.constant); 03720 } 03721 else { 03722 SB_LEN_FLD(sb_idx) = result.fld; 03723 SB_LEN_IDX(sb_idx) = result.idx; 03724 } 03725 03726 # if !defined(_SEPARATE_NONCOMMON_EQUIV_GROUPS) 03727 03728 /* Host associated stack equivalence group. Merge this group with */ 03729 /* the host associated stack. If there is no hosted group, just */ 03730 /* make this one the hosted stack group. */ 03731 03732 if (SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) == NULL_IDX) { 03733 CREATE_ID(name, sb_name[Stack_Host_Blk], sb_len[Stack_Host_Blk]); 03734 NTR_NAME_POOL(&(name.words[0]), sb_len[Stack_Host_Blk], np_idx); 03735 SB_NAME_IDX(sb_idx) = np_idx; 03736 SB_NAME_LEN(sb_idx) = sb_len[Stack_Host_Blk]; 03737 SB_BLK_TYPE(sb_idx) = Stack; 03738 SB_RUNTIME_INIT(sb_idx) = TRUE; 03739 SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) = sb_idx; 03740 } 03741 else { /* Merge this group with the already existing @STACK_HOST */ 03742 /* group. Adjust all offsets and ATD_STOR_BLK_IDX's. */ 03743 03744 new_sb_idx = SCP_SB_HOSTED_STACK_IDX(curr_scp_idx); 03745 03746 offset.fld = SB_LEN_FLD(new_sb_idx); 03747 offset.idx = SB_LEN_IDX(new_sb_idx); 03748 03749 align_bit_length(&offset, TARGET_BITS_PER_WORD); 03750 03751 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 03752 03753 while (ATD_STOR_BLK_IDX(EQ_ATTR_IDX(group)) != sb_idx) { 03754 group = EQ_NEXT_EQUIV_GRP(group); 03755 } 03756 item = group; 03757 03758 # if defined(_TARGET_DOUBLE_ALIGN) 03759 03760 if (EQ_DALIGN_ME(item)) { 03761 C_TO_F_INT(result.constant, 03762 TARGET_BITS_PER_WORD * 2, 03763 CG_INTEGER_DEFAULT_TYPE); 03764 result.fld = NO_Tbl_Idx; 03765 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 03766 left.fld = CN_Tbl_Idx; 03767 left.idx = CN_INTEGER_ZERO_IDX; 03768 03769 size_offset_binary_calc(&offset, &result, Mod_Opr, &result); 03770 03771 size_offset_logical_calc(&result, &left, Ne_Opr, &result); 03772 03773 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 03774 03775 /* This is not on a double word boundary */ 03776 03777 result.idx = CN_INTEGER_BITS_PER_WORD_IDX; 03778 result.fld = CN_Tbl_Idx; 03779 03780 /* Rather than padding, remove the 32-bit pad */ 03781 /* added to the front of this equivalence group. */ 03782 03783 size_offset_binary_calc(&offset, 03784 &result, 03785 EQ_DALIGN_SHIFT(item) ? Minus_Opr : 03786 Plus_Opr, 03787 &offset); 03788 } 03789 } 03790 # endif 03791 03792 while (item != NULL_IDX) { 03793 03794 if (ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item)) == sb_idx) { 03795 ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item)) = new_sb_idx; 03796 03797 result.fld = ATD_OFFSET_FLD(EQ_ATTR_IDX(item)); 03798 result.idx = ATD_OFFSET_IDX(EQ_ATTR_IDX(item)); 03799 03800 size_offset_binary_calc(&result, &offset, Plus_Opr, &result); 03801 03802 if (result.fld == NO_Tbl_Idx) { 03803 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx; 03804 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = ntr_const_tbl( 03805 result.type_idx, 03806 FALSE, 03807 result.constant); 03808 } 03809 else { 03810 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = result.fld; 03811 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = result.idx; 03812 } 03813 } 03814 item = EQ_NEXT_EQUIV_OBJ(item); 03815 } 03816 03817 result.fld = SB_LEN_FLD(sb_idx); 03818 result.idx = SB_LEN_IDX(sb_idx); 03819 03820 size_offset_binary_calc(&result, &offset, Plus_Opr, &result); 03821 03822 if (result.fld == NO_Tbl_Idx) { 03823 SB_LEN_FLD(new_sb_idx) = CN_Tbl_Idx; 03824 SB_LEN_IDX(new_sb_idx) = ntr_const_tbl(result.type_idx, 03825 FALSE, 03826 result.constant); 03827 } 03828 else { 03829 SB_LEN_FLD(new_sb_idx) = result.fld; 03830 SB_LEN_IDX(new_sb_idx) = result.idx; 03831 } 03832 } 03833 # endif 03834 03835 continue; 03836 } 03837 03838 if (SB_HIDDEN(sb_idx)) { 03839 03840 /* If two blocks are USE associated from different modules, the */ 03841 /* second one is marked hidden and SB_MERGED_BLK_IDX indexes to */ 03842 /* the first storage block. This resolves SB_MERGED_BLK_IDX, */ 03843 /* SB_DEF_MULT_SCPS and SB_LEN_IDX. */ 03844 03845 same_sb_idx = SB_MERGED_BLK_IDX(sb_idx); 03846 03847 while (SB_MERGED_BLK_IDX(same_sb_idx) != NULL_IDX) { 03848 same_sb_idx = SB_MERGED_BLK_IDX(same_sb_idx); 03849 } 03850 03851 SB_MERGED_BLK_IDX(sb_idx) = same_sb_idx; 03852 03853 if (SB_IS_COMMON(sb_idx)) { 03854 03855 if (SB_COMMON_NEEDS_OFFSET(same_sb_idx)) { 03856 check_and_allocate_common_storage(same_sb_idx); 03857 } 03858 03859 if (SB_HOST_ASSOCIATED(sb_idx)) { 03860 03861 /* Find the common block for the original scope. It should */ 03862 /* have all its offsets assigned and the block length should */ 03863 /* be correct. Copy down the block length so it can be */ 03864 /* compared to this blocks length. It can then be updated */ 03865 /* if necessary. */ 03866 03867 host_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 03868 SB_NAME_LEN(sb_idx), 03869 SB_ORIG_SCP_IDX(sb_idx)); 03870 03871 SB_LEN_FLD(sb_idx) = SB_LEN_FLD(host_sb_idx); 03872 SB_LEN_IDX(sb_idx) = SB_LEN_IDX(host_sb_idx); 03873 } 03874 } 03875 03876 if (SB_AUXILIARY(sb_idx) != SB_AUXILIARY(same_sb_idx)) { 03877 03878 if (!SB_DCL_ERR(same_sb_idx)) { 03879 PRINTMSG(SB_DEF_LINE(same_sb_idx), 942, Error, 03880 SB_DEF_COLUMN(same_sb_idx), 03881 SB_NAME_PTR(same_sb_idx)); 03882 } 03883 SB_DCL_ERR(same_sb_idx) = TRUE; 03884 } 03885 else if (SB_BLK_TYPE(sb_idx) != SB_BLK_TYPE(same_sb_idx)) { 03886 03887 if (!SB_DCL_ERR(same_sb_idx)) { 03888 PRINTMSG(SB_DEF_LINE(same_sb_idx), 941, Error, 03889 SB_DEF_COLUMN(same_sb_idx), 03890 SB_NAME_PTR(same_sb_idx)); 03891 } 03892 SB_DCL_ERR(same_sb_idx) = TRUE; 03893 } 03894 03895 if (SB_DEF_MULT_SCPS(sb_idx)) { 03896 SB_DEF_MULT_SCPS(same_sb_idx) = TRUE; 03897 } 03898 03899 if (SB_HAS_RENAMES(sb_idx)) { 03900 SB_HAS_RENAMES(same_sb_idx) = TRUE; 03901 } 03902 03903 if (fold_relationals(SB_LEN_IDX(sb_idx), 03904 SB_LEN_IDX(same_sb_idx), 03905 Gt_Opr)) { 03906 SB_LEN_FLD(same_sb_idx) = SB_LEN_FLD(sb_idx); 03907 SB_LEN_IDX(same_sb_idx) = SB_LEN_IDX(sb_idx); 03908 } 03909 } 03910 else if (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) { 03911 03912 # if defined(_TMP_GIVES_COMMON_LENGTH) 03913 if (SB_BLK_TYPE(sb_idx) == Static || SB_IS_COMMON(sb_idx)) 03914 # else 03915 if (SB_PAD_BLK(sb_idx)) 03916 # endif 03917 { 03918 if (SB_LEN_FLD(sb_idx) == AT_Tbl_Idx || 03919 fold_relationals(CN_INTEGER_ZERO_IDX, 03920 SB_LEN_IDX(sb_idx), 03921 Ne_Opr)) { 03922 03923 /* Create a tmp that resides at the last word of this block. */ 03924 /* This is created so that ccg gets the block length correct. */ 03925 /* When a static block (static, common or module) is USE */ 03926 /* associated or HOST associated, not everything in the storage */ 03927 /* block is associated (brought into the current scope), so ccg */ 03928 /* has no way of knowing what the block length is. This way */ 03929 /* ccg can figure it out correctly. The tmp is marked as */ 03930 /* unreferenced, but is sent across the interface. This tmp is */ 03931 /* NOT sent out to the module information tables. If a tmp is */ 03932 /* needed for this storage block, when the module information */ 03933 /* table is included, another one will be made. The offset is */ 03934 /* assigned in final_attr_semantics, because all the blocks */ 03935 /* have not merged yet. The type is TYPELESS_DEFAULT_TYPE */ 03936 /* because we need a type that is the length of one word on */ 03937 /* whatever machine this is. */ 03938 03939 attr_idx = gen_compiler_tmp(SB_DEF_LINE(sb_idx), 03940 SB_DEF_COLUMN(sb_idx), 03941 Priv, TRUE); 03942 03943 ATD_TYPE_IDX(attr_idx) = TYPELESS_DEFAULT_TYPE; 03944 AT_REFERENCED(attr_idx) = Not_Referenced; 03945 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 03946 ADD_ATTR_TO_LOCAL_LIST(attr_idx); 03947 } 03948 } 03949 03950 if (SB_HOST_ASSOCIATED(sb_idx)) { 03951 03952 /* BLK_LEN needs to be updated - so get the original sb_idx from */ 03953 /* the parent and change BLK_LEN if the original is bigger. It */ 03954 /* would be possible for the block length of the original to be */ 03955 /* greater than that of the host, but we want to allow that. */ 03956 /* The only way this can happen is if a common block is declared */ 03957 /* in the original and the child with different lengths and */ 03958 /* different variable names. Then if the child host associates */ 03959 /* a variable from the original procedures common block, both */ 03960 /* versions of the common block get into this procedure with */ 03961 /* different lengths. About this time, it is time to issue a */ 03962 /* warning. Actually that case will not get here, because the */ 03963 /* host associated version will be hidden. So there probably is */ 03964 /* no way to have the original block length be smaller than the */ 03965 /* child block length. */ 03966 03967 host_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 03968 SB_NAME_LEN(sb_idx), 03969 SB_ORIG_SCP_IDX(sb_idx)); 03970 03971 if (fold_relationals(SB_LEN_IDX(host_sb_idx), 03972 SB_LEN_IDX(sb_idx), 03973 Gt_Opr)) { 03974 SB_LEN_FLD(sb_idx) = SB_LEN_FLD(host_sb_idx); 03975 SB_LEN_IDX(sb_idx) = SB_LEN_IDX(host_sb_idx); 03976 } 03977 } 03978 } 03979 else if (SB_PAD_BLK(sb_idx)) { 03980 03981 /* Need to add a tmp to the end of a padded block so that we can */ 03982 /* have padding at the end of a block. */ 03983 03984 if (SB_LEN_FLD(sb_idx) == AT_Tbl_Idx || 03985 fold_relationals(CN_INTEGER_ZERO_IDX, 03986 SB_LEN_IDX(sb_idx), 03987 Ne_Opr)) { 03988 03989 /* Create a tmp that resides at the last word of this block. */ 03990 /* This is created so that ccg gets the block length correct. */ 03991 /* If padding is added, ccg has no way of knowing what the */ 03992 /* block length is. This way ccg can figure it out correctly. */ 03993 /* The tmp is marked as unreferenced, but is sent across the */ 03994 /* interface. This tmp is NOT sent out to the module */ 03995 /* information tables. If a tmp is needed for this storage */ 03996 /* block, when the module information table is included, */ 03997 /* another one will be made. The offset is assigned in */ 03998 /* final_attr_semantics, because all the blocks have not merged */ 03999 /* yet. The type is TYPELESS_DEFAULT_TYPE because we need a */ 04000 /* type that is the length of one word on the specific hardware.*/ 04001 04002 attr_idx = gen_compiler_tmp(SB_DEF_LINE(sb_idx), 04003 SB_DEF_COLUMN(sb_idx), 04004 Priv, TRUE); 04005 04006 ATD_TYPE_IDX(attr_idx) = TYPELESS_DEFAULT_TYPE; 04007 AT_REFERENCED(attr_idx) = Not_Referenced; 04008 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 04009 ADD_ATTR_TO_LOCAL_LIST(attr_idx); 04010 } 04011 } 04012 } 04013 04014 TRACE (Func_Exit, "storage_blk_resolution", NULL); 04015 04016 return; 04017 04018 } /* storage_blk_resolution */ 04019 04020 /******************************************************************************\ 04021 |* *| 04022 |* Description: *| 04023 |* This procedure does semantics stuff for interface blocks. *| 04024 |* *| 04025 |* Input parameters: *| 04026 |* NONE *| 04027 |* *| 04028 |* Output parameters: *| 04029 |* NONE *| 04030 |* *| 04031 |* Returns: *| 04032 |* NOTHING *| 04033 |* *| 04034 \******************************************************************************/ 04035 void interface_semantics_pass_driver (void) 04036 04037 { 04038 int sb_idx; 04039 04040 TRACE (Func_Entry, "interface_semantics_pass_driver", NULL); 04041 04042 /* The interface is pulled back into the parent's scope to be used for */ 04043 /* semantic checking and to allow the caller to allocate the function */ 04044 /* result for a non-scalar, character, structure, or dope vector rslt. */ 04045 /* This allows several assumptions. First, if this is a SUBROUTINE */ 04046 /* there is no result, so the parent routine will not need to allocate */ 04047 /* a function result, because of this NO IR will be generated using */ 04048 /* any of the dummy arguments. The only information need by the */ 04049 /* parent is for semantic checking. That information is in the */ 04050 /* parent's scope already, because the interface subroutine is in the */ 04051 /* parent's scope. Since this SUBROUTINE interface block causes no IR */ 04052 /* to be generated, nothing goes on the ATP_PGM_SPEC_LIST so the list */ 04053 /* creation can be skipped. assign_storage_offsets must be called */ 04054 /* because it does semantic checking. The storage block table must */ 04055 /* be gone through and all storage blocks assigned to this scope are */ 04056 /* switched to scope 0, because this scope is going to be removed. */ 04057 /* This effectively removes them from the storage block tbl. */ 04058 04059 /* If this is a FUNCTION that is non-scalar, character, structure or a */ 04060 /* dope vector, the parent will generate code using things declared in */ 04061 /* this interface block, when it generates code to allocate space for */ 04062 /* the function result at the call site. ATP_PGM_SPEC_LIST is a list */ 04063 /* of all common variables, module variables, dummy procedures and */ 04064 /* tmps needed to determine the length of the function result. Any */ 04065 /* storage blocks accessed are moved to the parent's scope. Storage */ 04066 /* block resolution in the parent's scope is done in assign_storage_ */ 04067 /* offsets when it is called for the parent. (Any tmps generated */ 04068 /* defaulted to the parent's stack when they were created.) Since */ 04069 /* none of the dummy args are on the ATP_PGM_SPEC_LIST the darg block */ 04070 /* can be removed. (The dargs are used as stmt function dargs if they */ 04071 /* are needed to calculate the result's length. See bounds resolution */ 04072 /* for more details.) After ATP_PGM_SPEC_LIST is created, the storage */ 04073 /* table is gone thru and any blocks still left are moved to scope 0, */ 04074 /* so they don't cause problems later after this scope is removed. */ 04075 04076 decl_semantics(); 04077 final_decl_semantics(); 04078 04079 PRINT_DBG_SYTB; /* Print scp if SCP_DBG_PRINT_SYTB = TRUE */ 04080 04081 for (sb_idx = 1; sb_idx <= stor_blk_tbl_idx; sb_idx++) { 04082 04083 if (SB_SCP_IDX(sb_idx) == curr_scp_idx) { 04084 SB_SCP_IDX(sb_idx) = NULL_IDX; 04085 SB_ORIG_SCP_IDX(sb_idx) = NULL_IDX; 04086 } 04087 } 04088 04089 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 04090 04091 TRACE (Func_Exit, "interface_semantics_pass_driver", NULL); 04092 04093 return; 04094 04095 } /* interface_semantics_pass_driver */ 04096 04097 /******************************************************************************\ 04098 |* *| 04099 |* Description: *| 04100 |* Clear the stmt_tmp_tbl, freeing any list nodes. *| 04101 |* *| 04102 |* Input parameters: *| 04103 |* NONE *| 04104 |* *| 04105 |* Output parameters: *| 04106 |* NONE *| 04107 |* *| 04108 |* Returns: *| 04109 |* NOTHING *| 04110 |* *| 04111 \******************************************************************************/ 04112 04113 static void free_stmt_tmp_tbl(void) 04114 04115 { 04116 04117 int i; 04118 int k; 04119 int list_idx; 04120 int list2_idx; 04121 04122 TRACE (Func_Entry, "free_stmt_tmp_tbl", NULL); 04123 04124 for (i = 0; i < Num_Linear_Types; i++) { 04125 04126 if (stmt_tmp_tbl[i].scalar_tmps_head < 0) { 04127 continue; 04128 } 04129 04130 if (stmt_tmp_tbl[i].scalar_tmps_head > 0) { 04131 list_idx = stmt_tmp_tbl[i].scalar_tmps_head; 04132 04133 while (list_idx) { 04134 list2_idx = list_idx; 04135 list_idx = IL_NEXT_LIST_IDX(list_idx); 04136 FREE_IR_LIST_NODE(list2_idx); 04137 } 04138 } 04139 04140 stmt_tmp_tbl[i].scalar_tmps_head = NULL_IDX; 04141 stmt_tmp_tbl[i].scalar_tmps_tail = NULL_IDX; 04142 04143 for (k = 0; k < 8; k++) { 04144 04145 if (stmt_tmp_tbl[i].dope_vector_tmps_head[k] > 0) { 04146 list_idx = stmt_tmp_tbl[i].dope_vector_tmps_head[k]; 04147 04148 while (list_idx) { 04149 list2_idx = list_idx; 04150 list_idx = IL_NEXT_LIST_IDX(list_idx); 04151 FREE_IR_LIST_NODE(list2_idx); 04152 } 04153 } 04154 04155 stmt_tmp_tbl[i].dope_vector_tmps_head[k] = NULL_IDX; 04156 stmt_tmp_tbl[i].dope_vector_tmps_tail[k] = NULL_IDX; 04157 } 04158 } 04159 04160 TRACE (Func_Exit, "free_stmt_tmp_tbl", NULL); 04161 04162 return; 04163 04164 } /* free_stmt_tmp_tbl */ 04165 04166 /******************************************************************************\ 04167 |* *| 04168 |* Description: *| 04169 |* Reset the stmt_tmp_tbl to it's original values. *| 04170 |* *| 04171 |* Input parameters: *| 04172 |* NONE *| 04173 |* *| 04174 |* Output parameters: *| 04175 |* NONE *| 04176 |* *| 04177 |* Returns: *| 04178 |* NOTHING *| 04179 |* *| 04180 \******************************************************************************/ 04181 04182 static void reset_stmt_tmp_tbl(void) 04183 04184 { 04185 int i; 04186 int k; 04187 04188 04189 TRACE (Func_Entry, "reset_stmt_tmp_tbl", NULL); 04190 04191 for (i = 0; i < Num_Linear_Types; i++) { 04192 stmt_tmp_tbl[i].scalar_tmps_head = init_stmt_tmp_tbl[i].scalar_tmps_head; 04193 stmt_tmp_tbl[i].scalar_tmps_tail = init_stmt_tmp_tbl[i].scalar_tmps_tail; 04194 04195 for (k = 0; k < 8; k++) { 04196 stmt_tmp_tbl[i].dope_vector_tmps_head[k] = 04197 init_stmt_tmp_tbl[i].dope_vector_tmps_head[k]; 04198 stmt_tmp_tbl[i].dope_vector_tmps_tail[k] = 04199 init_stmt_tmp_tbl[i].dope_vector_tmps_tail[k]; 04200 04201 } 04202 } 04203 04204 TRACE (Func_Exit, "reset_stmt_tmp_tbl", NULL); 04205 04206 return; 04207 04208 } /* reset_stmt_tmp_tbl */ 04209 04210 /******************************************************************************\ 04211 |* *| 04212 |* Description: *| 04213 |* Check for global name definitions. This routine searches the name *| 04214 |* table and then compares or enters the global name table. This *| 04215 |* routine should only be called for definition or partial definition *| 04216 |* situations. References are handled in check_call_for_global_def *| 04217 |* This routine does check for common block/global name conflicts. *| 04218 |* *| 04219 |* Input parameters: *| 04220 |* attr_idx -> Attribute table entry of global to check. *| 04221 |* *| 04222 |* Output parameters: *| 04223 |* NONE *| 04224 |* *| 04225 |* Returns: *| 04226 |* NOTHING *| 04227 |* *| 04228 \******************************************************************************/ 04229 04230 int check_global_pgm_unit(int attr_idx) 04231 04232 { 04233 int ga_common_idx; 04234 int ga_pgm_idx; 04235 msg_severities_type msg_level; 04236 int name_idx; 04237 int new_ga_idx; 04238 int ref_ga_idx; 04239 04240 04241 TRACE (Func_Entry, "check_global_pgm_unit", NULL); 04242 04243 if (srch_global_name_tbl(AT_OBJ_NAME_PTR(attr_idx), 04244 AT_NAME_LEN(attr_idx), 04245 &name_idx)) { 04246 04247 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 04248 ga_common_idx = GN_ATTR_IDX(name_idx); 04249 ga_pgm_idx = GAC_PGM_UNIT_IDX(ga_common_idx); 04250 } 04251 else { 04252 ga_common_idx = NULL_IDX; 04253 ga_pgm_idx = GN_ATTR_IDX(name_idx); 04254 } 04255 04256 if (ga_common_idx != NULL_IDX && ga_pgm_idx == NULL_IDX) { 04257 04258 /* This is a common block name - issue a message */ 04259 04260 # if defined(_ERROR_DUPLICATE_GLOBALS) 04261 msg_level = Error; 04262 # else 04263 msg_level = (ATP_PGM_UNIT(attr_idx) == Module) ? Error : Ansi; 04264 # endif 04265 PRINTMSG(AT_DEF_LINE(attr_idx), 1006, msg_level, 04266 AT_DEF_COLUMN(attr_idx), 04267 AT_OBJ_NAME_PTR(attr_idx), 04268 pgm_unit_str[ATP_PGM_UNIT(attr_idx)]); 04269 } 04270 04271 if (ga_pgm_idx == NULL_IDX) { /* No previous global entry as pgm. */ 04272 ga_pgm_idx = ntr_global_attr_tbl(attr_idx, name_idx); 04273 04274 /* Must be a common block or we wouldn't be here. */ 04275 04276 GAC_PGM_UNIT_IDX(ga_common_idx) = ga_pgm_idx; 04277 04278 fill_in_global_attr_ntry(ga_pgm_idx, attr_idx, NULL_IDX); 04279 } 04280 else if (GAP_PGM_UNIT_DEFINED(ga_pgm_idx) && 04281 GAP_NEXT_PGM_UNIT_IDX(ga_pgm_idx) == NULL_IDX) { 04282 04283 /* Found a definition. Not the interface but the actual definition */ 04284 /* If we actually have the definition, it will be the only entry. */ 04285 04286 global_name_semantics(ga_pgm_idx, 04287 NULL_IDX, 04288 NULL_IDX, 04289 NULL_IDX, 04290 attr_idx); /* Know this is a definition, */ 04291 /* because we are passing only */ 04292 /* an attr_idx. */ 04293 } 04294 else if (GA_DEFINED(ga_pgm_idx) && 04295 !GAP_PGM_UNIT_DEFINED(ga_pgm_idx) && 04296 GAP_IN_INTERFACE_BLK(ga_pgm_idx)) { 04297 04298 /* This is an interface definition. */ 04299 /* Compare - Replace if this is the true definition. */ 04300 04301 global_name_semantics(ga_pgm_idx, 04302 NULL_IDX, 04303 NULL_IDX, 04304 NULL_IDX, 04305 attr_idx); /* Know this is a definition, */ 04306 04307 if (ATP_EXPL_ITRFC(attr_idx) && 04308 !SCP_IS_INTERFACE(curr_scp_idx) && 04309 (attr_idx == SCP_ATTR_IDX(curr_scp_idx) || 04310 (ATP_SCP_ALIVE(attr_idx) && ATP_ALT_ENTRY(attr_idx)))) { 04311 04312 /* This is a definition. Replace the interface block */ 04313 04314 new_ga_idx = ntr_global_attr_tbl(attr_idx, name_idx); 04315 04316 fill_in_global_attr_ntry(new_ga_idx, attr_idx, NULL_IDX); 04317 04318 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 04319 GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)) = new_ga_idx; 04320 } 04321 else { 04322 GN_ATTR_IDX(name_idx) = new_ga_idx; 04323 } 04324 } 04325 } 04326 else if (GA_DEFINED(ga_pgm_idx) && 04327 !GAP_PGM_UNIT_DEFINED(ga_pgm_idx)) { 04328 04329 /* A partial definition. Just enter it. KAY */ 04330 04331 new_ga_idx = ntr_global_attr_tbl(attr_idx, name_idx); 04332 fill_in_global_attr_ntry(new_ga_idx, attr_idx, NULL_IDX); 04333 04334 GAP_NEXT_PGM_UNIT_IDX(new_ga_idx) = ga_pgm_idx; 04335 04336 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 04337 GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)) = new_ga_idx; 04338 } 04339 else { 04340 GN_ATTR_IDX(name_idx) = new_ga_idx; 04341 } 04342 } 04343 else { 04344 04345 /* Have one or more references or interface block definitions. */ 04346 /* If this is a true definition, then compare all previous */ 04347 /* references and interface definitions. Then remove them and */ 04348 /* add the definition. No free list, so let the memory go. */ 04349 04350 ref_ga_idx = ga_pgm_idx; 04351 04352 while (ref_ga_idx != NULL_IDX) { 04353 global_name_semantics(ref_ga_idx, /* Reference */ 04354 NULL_IDX, 04355 NULL_IDX, 04356 NULL_IDX, 04357 attr_idx); /* Know this is a definition, */ 04358 /* because we are passing only */ 04359 /* an attr_idx. */ 04360 ref_ga_idx = GAP_NEXT_PGM_UNIT_IDX(ref_ga_idx); 04361 } 04362 04363 new_ga_idx = ntr_global_attr_tbl(attr_idx, name_idx); 04364 fill_in_global_attr_ntry(new_ga_idx, attr_idx, NULL_IDX); 04365 04366 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 04367 GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)) = new_ga_idx; 04368 } 04369 else { 04370 GN_ATTR_IDX(name_idx) = new_ga_idx; 04371 } 04372 } 04373 } 04374 else { /* Enter a definition */ 04375 ntr_global_name_tbl(attr_idx, NULL_IDX, name_idx); 04376 } 04377 04378 TRACE (Func_Exit, "check_global_pgm_unit", NULL); 04379 04380 return(name_idx); 04381 04382 } /* check_global_pgm_unit */ 04383 04384 /******************************************************************************\ 04385 |* *| 04386 |* Description: *| 04387 |* Check for mutiple entries in functions that are to be returned in *| 04388 |* registers on solaris. Then generate the multiple return stmts that *| 04389 |* are to replace all the original returns. *| 04390 |* *| 04391 |* Input parameters: *| 04392 |* NONE *| 04393 |* *| 04394 |* Output parameters: *| 04395 |* NONE *| 04396 |* *| 04397 |* Returns: *| 04398 |* NOTHING *| 04399 |* *| 04400 \******************************************************************************/ 04401 04402 # ifdef _SEPARATE_FUNCTION_RETURNS 04403 static void check_multiple_entry_func(void) 04404 04405 { 04406 int al_idx; 04407 int attr_idx; 04408 int branch_idx; 04409 int col; 04410 boolean has_conflict = FALSE; 04411 int i; 04412 int ir_idx; 04413 int label_idx; 04414 int line; 04415 int list_idx; 04416 int prev_type_idx; 04417 int save_curr_stmt_sh_idx; 04418 int tmp_idx; 04419 int type_idx; 04420 04421 04422 TRACE (Func_Entry, "check_multiple_entry_func", NULL); 04423 04424 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04425 attr_idx = SCP_ATTR_IDX(curr_scp_idx); 04426 prev_type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 04427 04428 al_idx = SCP_ENTRY_IDX(curr_scp_idx); 04429 04430 for (i = 0; i < SCP_ALT_ENTRY_CNT(curr_scp_idx); i++) { 04431 04432 attr_idx = AL_ATTR_IDX(al_idx); 04433 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 04434 04435 if (TYP_TYPE(type_idx) != TYP_TYPE(prev_type_idx)) { 04436 has_conflict = TRUE; 04437 break; 04438 } 04439 else if ((TYP_TYPE(type_idx) == Real || 04440 TYP_TYPE(type_idx) == Complex) && 04441 TYP_LINEAR(type_idx) != TYP_LINEAR(prev_type_idx)) { 04442 04443 has_conflict = TRUE; 04444 break; 04445 } 04446 04447 al_idx = AL_NEXT_IDX(al_idx); 04448 } 04449 04450 if (has_conflict) { 04451 04452 /* get main pgm unit attr */ 04453 04454 attr_idx = SCP_ATTR_IDX(curr_scp_idx); 04455 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 04456 line = SH_GLB_LINE(SCP_LAST_SH_IDX(curr_scp_idx)); 04457 col = SH_COL_NUM(SCP_LAST_SH_IDX(curr_scp_idx)); 04458 04459 set_up_which_entry_tmp(); 04460 04461 tmp_idx = SCP_WHICH_ENTRY_TMP(curr_scp_idx); 04462 04463 /* gen the final branch to label for returns */ 04464 04465 label_idx = gen_internal_lbl(line); 04466 curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx); 04467 gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 04468 04469 NTR_IR_TBL(ir_idx); 04470 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 04471 IR_OPR(ir_idx) = Label_Opr; 04472 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 04473 IR_LINE_NUM(ir_idx) = line; 04474 IR_COL_NUM(ir_idx) = col; 04475 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 04476 IR_IDX_L(ir_idx) = label_idx; 04477 IR_COL_NUM_L(ir_idx) = col; 04478 IR_LINE_NUM_L(ir_idx) = line; 04479 04480 AT_DEFINED(label_idx) = TRUE; 04481 ATL_DEF_STMT_IDX(label_idx) = curr_stmt_sh_idx; 04482 04483 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04484 04485 SCP_RETURN_LABEL(curr_scp_idx) = label_idx; 04486 04487 /* set up index branch stmt */ 04488 04489 NTR_IR_TBL(branch_idx); 04490 IR_OPR(branch_idx) = Br_Index_Opr; 04491 IR_TYPE_IDX(branch_idx) = CG_INTEGER_DEFAULT_TYPE; 04492 IR_LINE_NUM(branch_idx) = line; 04493 IR_COL_NUM(branch_idx) = col; 04494 IR_FLD_L(branch_idx) = AT_Tbl_Idx; 04495 IR_IDX_L(branch_idx) = tmp_idx; 04496 IR_LINE_NUM_L(branch_idx) = line; 04497 IR_COL_NUM_L(branch_idx) = col; 04498 04499 gen_sh(After, Goto_Stmt, line, col, FALSE, FALSE, TRUE); 04500 SH_IR_IDX(curr_stmt_sh_idx) = branch_idx; 04501 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04502 04503 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 04504 04505 /* add the return and label to return code */ 04506 04507 NTR_IR_LIST_TBL(list_idx); 04508 IR_FLD_R(branch_idx) = IL_Tbl_Idx; 04509 IR_IDX_R(branch_idx) = list_idx; 04510 IR_LIST_CNT_R(branch_idx) = 1; 04511 04512 label_idx = gen_internal_lbl(line); 04513 curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx); 04514 gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 04515 04516 NTR_IR_TBL(ir_idx); 04517 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 04518 IR_OPR(ir_idx) = Label_Opr; 04519 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 04520 IR_LINE_NUM(ir_idx) = line; 04521 IR_COL_NUM(ir_idx) = col; 04522 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 04523 IR_IDX_L(ir_idx) = label_idx; 04524 IR_COL_NUM_L(ir_idx) = col; 04525 IR_LINE_NUM_L(ir_idx) = line; 04526 04527 AT_DEFINED(label_idx) = TRUE; 04528 ATL_DEF_STMT_IDX(label_idx) = curr_stmt_sh_idx; 04529 04530 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04531 04532 IL_FLD(list_idx) = AT_Tbl_Idx; 04533 IL_IDX(list_idx) = label_idx; 04534 IL_LINE_NUM(list_idx) = line; 04535 IL_COL_NUM(list_idx) = col; 04536 04537 NTR_IR_TBL(ir_idx); 04538 IR_OPR(ir_idx) = Return_Opr; 04539 IR_TYPE_IDX(ir_idx) = type_idx; 04540 IR_LINE_NUM(ir_idx) = line; 04541 IR_COL_NUM(ir_idx) = col; 04542 04543 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 04544 IR_IDX_R(ir_idx) = ATP_RSLT_IDX(attr_idx); 04545 IR_LINE_NUM_R(ir_idx) = line; 04546 IR_COL_NUM_R(ir_idx) = col; 04547 04548 gen_sh(After, Return_Stmt, line, col, FALSE, FALSE, TRUE); 04549 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 04550 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04551 04552 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 04553 04554 al_idx = SCP_ENTRY_IDX(curr_scp_idx); 04555 04556 for (i = 0; i < SCP_ALT_ENTRY_CNT(curr_scp_idx); i++) { 04557 04558 attr_idx = AL_ATTR_IDX(al_idx); 04559 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)); 04560 04561 04562 /* add the return and label to return code */ 04563 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 04564 list_idx = IL_NEXT_LIST_IDX(list_idx); 04565 IR_LIST_CNT_R(branch_idx) += 1; 04566 04567 label_idx = gen_internal_lbl(line); 04568 curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx); 04569 gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 04570 04571 NTR_IR_TBL(ir_idx); 04572 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 04573 IR_OPR(ir_idx) = Label_Opr; 04574 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 04575 IR_LINE_NUM(ir_idx) = line; 04576 IR_COL_NUM(ir_idx) = col; 04577 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 04578 IR_IDX_L(ir_idx) = label_idx; 04579 IR_COL_NUM_L(ir_idx) = col; 04580 IR_LINE_NUM_L(ir_idx) = line; 04581 04582 AT_DEFINED(label_idx) = TRUE; 04583 ATL_DEF_STMT_IDX(label_idx) = curr_stmt_sh_idx; 04584 04585 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04586 04587 IL_FLD(list_idx) = AT_Tbl_Idx; 04588 IL_IDX(list_idx) = label_idx; 04589 IL_LINE_NUM(list_idx) = line; 04590 IL_COL_NUM(list_idx) = col; 04591 04592 NTR_IR_TBL(ir_idx); 04593 IR_OPR(ir_idx) = Return_Opr; 04594 IR_TYPE_IDX(ir_idx) = type_idx;; 04595 IR_LINE_NUM(ir_idx) = line; 04596 IR_COL_NUM(ir_idx) = col; 04597 04598 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 04599 IR_IDX_R(ir_idx) = ATP_RSLT_IDX(attr_idx); 04600 IR_LINE_NUM_R(ir_idx) = line; 04601 IR_COL_NUM_R(ir_idx) = col; 04602 04603 gen_sh(After, Return_Stmt, line, col, FALSE, FALSE, TRUE); 04604 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 04605 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04606 04607 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 04608 04609 al_idx = AL_NEXT_IDX(al_idx); 04610 } 04611 } 04612 04613 04614 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 04615 04616 TRACE (Func_Exit, "check_multiple_entry_func", NULL); 04617 04618 return; 04619 04620 } /* check_multiple_entry_func */ 04621 # endif 04622 04623 /******************************************************************************\ 04624 |* *| 04625 |* Description: *| 04626 |* Make all offsets in the group zero based. *| 04627 |* *| 04628 |* Input parameters: *| 04629 |* eq_idx -> equiv table index for this group. *| 04630 |* *| 04631 |* Output parameters: *| 04632 |* NONE *| 04633 |* *| 04634 |* Returns: *| 04635 |* NONE *| 04636 |* *| 04637 \******************************************************************************/ 04638 static void final_equivalence_semantics(void) 04639 { 04640 int attr_idx; 04641 size_offset_type base; 04642 boolean base_is_zero; 04643 int eq_idx; 04644 int group; 04645 int item; 04646 size_offset_type left; 04647 size_offset_type length; 04648 size_offset_type new_len; 04649 size_offset_type new_offset; 04650 boolean new_offset_ne_zero; 04651 size_offset_type result; 04652 int sb_idx; 04653 int type_idx; 04654 size_offset_type zero; 04655 boolean dalign_offset_ok; 04656 boolean dalign_shift_offset; 04657 int t_idx; 04658 04659 04660 TRACE (Func_Entry, "final_equivalence_semantics", NULL); 04661 04662 group = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 04663 04664 while (group != NULL_IDX) { 04665 04666 if (EQ_SEMANTICS_DONE(group)) { 04667 group = EQ_NEXT_EQUIV_GRP(group); 04668 continue; 04669 } 04670 base.fld = CN_Tbl_Idx; 04671 base.idx = CN_INTEGER_ZERO_IDX; 04672 base_is_zero = TRUE; 04673 eq_idx = group; 04674 item = eq_idx; 04675 04676 /* Find the smallest offset for the entire group. */ 04677 04678 while (item != NULL_IDX) { 04679 04680 if (EQ_OFFSET_IDX(item) != CN_INTEGER_ZERO_IDX && 04681 fold_relationals(EQ_OFFSET_IDX(item), base.idx, Lt_Opr)) { 04682 base.idx = EQ_OFFSET_IDX(item); 04683 base.fld = EQ_OFFSET_FLD(item); 04684 base_is_zero = FALSE; 04685 } 04686 04687 item = EQ_NEXT_EQUIV_OBJ(item); 04688 } 04689 04690 type_idx = INTEGER_DEFAULT_TYPE; 04691 04692 if (!base_is_zero) { 04693 result.idx = CN_INTEGER_NEG_ONE_IDX; 04694 result.fld = CN_Tbl_Idx; 04695 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04696 04697 size_offset_binary_calc(&base, &result, Mult_Opr, &base); 04698 } 04699 04700 /* Only need to word align Static, because this is the only storage */ 04701 /* group that equivalenced items get added to. For stack, each one */ 04702 /* is a different group. For Common, offsets are assigned later. */ 04703 04704 sb_idx = ATD_STOR_BLK_IDX(EQ_ATTR_IDX(group)); 04705 04706 if (SB_BLK_TYPE(sb_idx) == Static_Local || 04707 SB_BLK_TYPE(sb_idx) == Static_Named || 04708 SB_BLK_TYPE(sb_idx) == Static) { /* word align prev @DATA boundary */ 04709 04710 if (SB_LEN_FLD(sb_idx) == AT_Tbl_Idx || 04711 SB_LEN_IDX(sb_idx) != CN_INTEGER_ZERO_IDX) { 04712 04713 result.idx = SB_LEN_IDX(sb_idx); 04714 result.fld = SB_LEN_FLD(sb_idx); 04715 04716 align_bit_length(&result, TARGET_BITS_PER_WORD); 04717 04718 if (result.fld == NO_Tbl_Idx) { 04719 SB_LEN_FLD(sb_idx) = CN_Tbl_Idx; 04720 SB_LEN_IDX(sb_idx) = ntr_const_tbl(result.type_idx, 04721 FALSE, 04722 result.constant); 04723 } 04724 else { 04725 SB_LEN_FLD(sb_idx) = result.fld; 04726 SB_LEN_IDX(sb_idx) = result.idx; 04727 } 04728 04729 base_is_zero = FALSE; 04730 04731 size_offset_binary_calc(&result, &base, Plus_Opr, &base); 04732 } 04733 } 04734 04735 item = eq_idx; 04736 04737 # if defined(_TARGET_DOUBLE_ALIGN) 04738 dalign_offset_ok = FALSE; 04739 dalign_shift_offset = FALSE; 04740 # endif 04741 04742 while (item != NULL_IDX) { 04743 attr_idx = EQ_ATTR_IDX(item); 04744 04745 if (!base_is_zero) { 04746 result.fld = EQ_OFFSET_FLD(item); 04747 result.idx = EQ_OFFSET_IDX(item); 04748 04749 size_offset_binary_calc(&result, &base, Plus_Opr, &new_offset); 04750 04751 if (new_offset.fld == NO_Tbl_Idx) { 04752 EQ_OFFSET_FLD(item) = CN_Tbl_Idx; 04753 EQ_OFFSET_IDX(item) = ntr_const_tbl(new_offset.type_idx, 04754 FALSE, 04755 new_offset.constant); 04756 } 04757 else { 04758 EQ_OFFSET_FLD(item) = new_offset.fld; 04759 EQ_OFFSET_IDX(item) = new_offset.idx; 04760 } 04761 } 04762 04763 type_idx = ATD_TYPE_IDX(attr_idx); 04764 04765 if (SB_HOSTED_STACK(sb_idx)) { 04766 AT_HOST_ASSOCIATED(attr_idx) = TRUE; 04767 } 04768 04769 /* KAY - This needs fixing. */ 04770 04771 if (TYP_TYPE(type_idx) != Character) { 04772 04773 result.fld = CN_Tbl_Idx; 04774 result.idx = CN_INTEGER_BITS_PER_WORD_IDX; 04775 left.fld = EQ_OFFSET_FLD(item); 04776 left.idx = EQ_OFFSET_IDX(item); 04777 zero.fld = CN_Tbl_Idx; 04778 zero.idx = CN_INTEGER_ZERO_IDX; 04779 04780 size_offset_binary_calc(&left, &result, Mod_Opr, &result); 04781 04782 size_offset_logical_calc(&zero, &result, Ne_Opr, &result); 04783 04784 new_offset_ne_zero = THIS_IS_TRUE(result.constant, result.type_idx); 04785 04786 if (TYP_TYPE(type_idx) == Structure) { 04787 04788 if (ATT_NUMERIC_CPNT(TYP_IDX(type_idx)) && new_offset_ne_zero) { 04789 04790 # if defined(_TARGET_PACK_HALF_WORD_TYPES) 04791 04792 t_idx = ATD_TYPE_IDX(SN_ATTR_IDX( 04793 ATT_FIRST_CPNT_IDX(attr_idx))); 04794 04795 if (PACK_HALF_WORD_TEST_CONDITION(t_idx)) { 04796 C_TO_F_INT(result.constant, 04797 TARGET_BITS_PER_WORD/2, 04798 CG_INTEGER_DEFAULT_TYPE); 04799 result.fld = NO_Tbl_Idx; 04800 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04801 left.fld = EQ_OFFSET_FLD(item); 04802 left.idx = EQ_OFFSET_IDX(item); 04803 04804 size_offset_binary_calc(&left, &result, Mod_Opr, &result); 04805 04806 size_offset_logical_calc(&zero, &result, Ne_Opr, &result); 04807 04808 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 04809 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04810 EQ_COLUMN_NUM(item), 04811 AT_OBJ_NAME_PTR(attr_idx)); 04812 } 04813 } 04814 else { 04815 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04816 EQ_COLUMN_NUM(item), 04817 AT_OBJ_NAME_PTR(attr_idx)); 04818 } 04819 04820 # elif defined(_INTEGER_1_AND_2) 04821 04822 if (on_off_flags.integer_1_and_2) { 04823 04824 t_idx = ATD_TYPE_IDX(SN_ATTR_IDX( 04825 ATT_FIRST_CPNT_IDX(attr_idx))); 04826 04827 if (PACK_8_BIT_TEST_CONDITION(t_idx)) { 04828 C_TO_F_INT(result.constant, 8, CG_INTEGER_DEFAULT_TYPE); 04829 result.fld = NO_Tbl_Idx; 04830 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04831 left.fld = EQ_OFFSET_FLD(item); 04832 left.idx = EQ_OFFSET_IDX(item); 04833 04834 size_offset_binary_calc(&left,&result,Mod_Opr,&result); 04835 04836 size_offset_logical_calc(&zero,&result,Ne_Opr,&result); 04837 04838 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 04839 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04840 EQ_COLUMN_NUM(item), 04841 AT_OBJ_NAME_PTR(attr_idx)); 04842 } 04843 } 04844 else if (PACK_16_BIT_TEST_CONDITION(t_idx)) { 04845 C_TO_F_INT(result.constant, 16,CG_INTEGER_DEFAULT_TYPE); 04846 result.fld = NO_Tbl_Idx; 04847 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04848 left.fld = EQ_OFFSET_FLD(item); 04849 left.idx = EQ_OFFSET_IDX(item); 04850 04851 size_offset_binary_calc(&left,&result,Mod_Opr,&result); 04852 size_offset_logical_calc(&zero,&result,Ne_Opr,&result); 04853 04854 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 04855 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04856 EQ_COLUMN_NUM(item), 04857 AT_OBJ_NAME_PTR(attr_idx)); 04858 } 04859 } 04860 else { 04861 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04862 EQ_COLUMN_NUM(item), 04863 AT_OBJ_NAME_PTR(attr_idx)); 04864 } 04865 } 04866 # else 04867 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04868 EQ_COLUMN_NUM(item), 04869 AT_OBJ_NAME_PTR(attr_idx)); 04870 # endif 04871 } 04872 } 04873 else if (new_offset_ne_zero) { 04874 04875 # if defined(_TARGET_PACK_HALF_WORD_TYPES) 04876 04877 if (PACK_HALF_WORD_TEST_CONDITION(type_idx)) { 04878 04879 C_TO_F_INT(result.constant, 04880 TARGET_BITS_PER_WORD/2, 04881 CG_INTEGER_DEFAULT_TYPE); 04882 result.fld = NO_Tbl_Idx; 04883 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04884 left.fld = EQ_OFFSET_FLD(item); 04885 left.idx = EQ_OFFSET_IDX(item); 04886 zero.fld = CN_Tbl_Idx; 04887 zero.idx = CN_INTEGER_ZERO_IDX; 04888 04889 size_offset_binary_calc(&left, &result, Mod_Opr, &result); 04890 04891 size_offset_logical_calc(&zero, &result, Ne_Opr, &result); 04892 04893 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 04894 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04895 EQ_COLUMN_NUM(item), 04896 AT_OBJ_NAME_PTR(attr_idx)); 04897 } 04898 } 04899 else { 04900 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04901 EQ_COLUMN_NUM(item), 04902 AT_OBJ_NAME_PTR(attr_idx)); 04903 } 04904 # elif defined(_INTEGER_1_AND_2) 04905 04906 if (on_off_flags.integer_1_and_2) { 04907 04908 if (PACK_8_BIT_TEST_CONDITION(type_idx)) { 04909 C_TO_F_INT(result.constant, 8, CG_INTEGER_DEFAULT_TYPE); 04910 result.fld = NO_Tbl_Idx; 04911 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04912 left.fld = EQ_OFFSET_FLD(item); 04913 left.idx = EQ_OFFSET_IDX(item); 04914 zero.fld = CN_Tbl_Idx; 04915 zero.idx = CN_INTEGER_ZERO_IDX; 04916 04917 size_offset_binary_calc(&left, &result, Mod_Opr, &result); 04918 04919 size_offset_logical_calc(&zero, &result, Ne_Opr, &result); 04920 04921 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 04922 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04923 EQ_COLUMN_NUM(item), 04924 AT_OBJ_NAME_PTR(attr_idx)); 04925 } 04926 } 04927 else if (PACK_16_BIT_TEST_CONDITION(type_idx)) { 04928 C_TO_F_INT(result.constant, 16, CG_INTEGER_DEFAULT_TYPE); 04929 result.fld = NO_Tbl_Idx; 04930 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04931 left.fld = EQ_OFFSET_FLD(item); 04932 left.idx = EQ_OFFSET_IDX(item); 04933 zero.fld = CN_Tbl_Idx; 04934 zero.idx = CN_INTEGER_ZERO_IDX; 04935 04936 size_offset_binary_calc(&left, &result, Mod_Opr, &result); 04937 04938 size_offset_logical_calc(&zero, &result, Ne_Opr, &result); 04939 04940 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 04941 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04942 EQ_COLUMN_NUM(item), 04943 AT_OBJ_NAME_PTR(attr_idx)); 04944 } 04945 } 04946 else { 04947 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04948 EQ_COLUMN_NUM(item), 04949 AT_OBJ_NAME_PTR(attr_idx)); 04950 } 04951 } 04952 # else 04953 PRINTMSG(EQ_LINE_NUM(item), 527, Error, 04954 EQ_COLUMN_NUM(item), 04955 AT_OBJ_NAME_PTR(attr_idx)); 04956 # endif 04957 } 04958 } 04959 04960 # if defined(_TARGET_DOUBLE_ALIGN) 04961 04962 if (EQ_DO_NOT_DALIGN(eq_idx)) { 04963 04964 /* Intentionally left blank */ 04965 } 04966 else if (DALIGN_TEST_CONDITION(type_idx)) { 04967 C_TO_F_INT(result.constant, 04968 TARGET_BITS_PER_WORD * 2, 04969 CG_INTEGER_DEFAULT_TYPE); 04970 result.fld = NO_Tbl_Idx; 04971 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 04972 left.fld = EQ_OFFSET_FLD(item); 04973 left.idx = EQ_OFFSET_IDX(item); 04974 zero.fld = CN_Tbl_Idx; 04975 zero.idx = CN_INTEGER_ZERO_IDX; 04976 04977 size_offset_binary_calc(&left, &result, Mod_Opr, &result); 04978 04979 size_offset_logical_calc(&zero, &result, Ne_Opr, &result); 04980 04981 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 04982 04983 /* If dalign_offset_ok, something else is in this equivalence */ 04984 /* group that needs daligning and it is aligned. This item */ 04985 /* needs to have 32 bit padding added to the start of the */ 04986 /* equivalence group to be daligned. If we do this, then the */ 04987 /* first item will get shifted off of a double word boundary. */ 04988 /* If -a dalign is specified, issue an error message. Other- */ 04989 /* wise issue a caution message. */ 04990 04991 if (dalign_offset_ok) { 04992 PRINTMSG(EQ_LINE_NUM(item), 1008, 04993 (cmd_line_flags.dalign) ? Error : Caution, 04994 EQ_COLUMN_NUM(item), AT_OBJ_NAME_PTR(attr_idx)); 04995 } 04996 else { 04997 dalign_shift_offset = TRUE; 04998 EQ_DALIGN_ME(eq_idx) = TRUE; 04999 } 05000 } 05001 else if (dalign_shift_offset) { 05002 05003 /* If dalign_shift_offset, something else is in this equiv */ 05004 /* group that needs daligning. This item needs a 32 bit pad */ 05005 /* added to the start of the equivalence group to be daligned.*/ 05006 /* If we do this, then this item will get shifted off a */ 05007 /* double word boundary. If -a dalign is specified, issue an */ 05008 /* error message. Otherwise issue a caution message. */ 05009 05010 PRINTMSG(EQ_LINE_NUM(item), 1008, 05011 (cmd_line_flags.dalign) ? Error : Caution, 05012 EQ_COLUMN_NUM(item), AT_OBJ_NAME_PTR(attr_idx)); 05013 } 05014 else { 05015 dalign_offset_ok = TRUE; 05016 EQ_DALIGN_ME(eq_idx) = TRUE; 05017 } 05018 } 05019 # endif 05020 05021 ATD_OFFSET_FLD(attr_idx) = EQ_OFFSET_FLD(item); 05022 ATD_OFFSET_IDX(attr_idx) = EQ_OFFSET_IDX(item); 05023 05024 if (!SB_IS_COMMON(sb_idx)) { 05025 05026 if (!ATD_OFFSET_ASSIGNED(attr_idx)) { 05027 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 05028 05029 new_len = stor_bit_size_of(attr_idx, TRUE, FALSE); 05030 05031 align_bit_length(&new_len, TARGET_BITS_PER_WORD); 05032 05033 result.fld = ATD_OFFSET_FLD(attr_idx); 05034 result.idx = ATD_OFFSET_IDX(attr_idx); 05035 length.fld = SB_LEN_FLD(sb_idx); 05036 length.idx = SB_LEN_IDX(sb_idx); 05037 05038 size_offset_binary_calc(&result, &new_len, Plus_Opr, &new_len); 05039 size_offset_logical_calc(&new_len, &length, Gt_Opr, &result); 05040 05041 if (THIS_IS_TRUE(result.constant, result.type_idx)) { 05042 SB_LEN_IDX(sb_idx) = ntr_const_tbl(new_len.type_idx, 05043 FALSE, 05044 new_len.constant); 05045 } 05046 } 05047 } 05048 item = EQ_NEXT_EQUIV_OBJ(item); 05049 } 05050 05051 05052 # if defined(_TARGET_DOUBLE_ALIGN) 05053 05054 /* Need to go through equivalence group again and make sure EQ_DALIGN */ 05055 /* are set correctly on all members in the group. */ 05056 05057 if (dalign_shift_offset && !dalign_offset_ok) { 05058 05059 /* If this is a common block, this storage block needs to shift */ 05060 /* to be double aligned. If this is not a common block, this */ 05061 /* block has been shifted by TARGET_BITS_PER_WORD so that */ 05062 /* everything is double aligned. This is used if equivalence */ 05063 /* blocks are merged because of host association. */ 05064 05065 EQ_DALIGN_SHIFT(eq_idx) = TRUE; 05066 05067 /* Adjust everything by 32 bits - unless this is a common block.*/ 05068 /* If this is a common block and dalign is on, we will adjust. */ 05069 /* later. If dalign is off, we will not adjust. This is */ 05070 /* handled in allocate_common_storage. */ 05071 05072 if (!SB_IS_COMMON(sb_idx)) { 05073 item = eq_idx; 05074 05075 while (item != NULL_IDX) { 05076 EQ_DALIGN_ME(item) = TRUE; 05077 result.fld = CN_Tbl_Idx; 05078 result.idx = CN_INTEGER_BITS_PER_WORD_IDX; 05079 left.fld = EQ_OFFSET_FLD(item); 05080 left.idx = EQ_OFFSET_IDX(item); 05081 05082 if (!size_offset_binary_calc(&left, &result, Plus_Opr, &result)){ 05083 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 05084 } 05085 05086 if (result.fld == NO_Tbl_Idx) { 05087 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx; 05088 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = ntr_const_tbl( 05089 result.type_idx, 05090 FALSE, 05091 result.constant); 05092 } 05093 else { 05094 ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = result.fld; 05095 ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = result.idx; 05096 } 05097 item = EQ_NEXT_EQUIV_OBJ(item); 05098 } 05099 05100 result.fld = CN_Tbl_Idx; 05101 result.idx = CN_INTEGER_BITS_PER_WORD_IDX; 05102 left.fld = SB_LEN_FLD(sb_idx); 05103 left.idx = SB_LEN_IDX(sb_idx); 05104 05105 if (!size_offset_binary_calc(&left, &result, Plus_Opr, &result)) { 05106 AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE; 05107 } 05108 05109 if (result.fld == NO_Tbl_Idx) { 05110 SB_LEN_FLD(sb_idx) = CN_Tbl_Idx; 05111 SB_LEN_IDX(sb_idx) = ntr_const_tbl(result.type_idx, 05112 FALSE, 05113 result.constant); 05114 } 05115 else { 05116 SB_LEN_FLD(sb_idx) = result.fld; 05117 SB_LEN_IDX(sb_idx) = result.idx; 05118 } 05119 } 05120 else { 05121 item = eq_idx; 05122 05123 while (item != NULL_IDX) { 05124 EQ_DALIGN_SHIFT(item) = TRUE; 05125 EQ_DALIGN_ME(item) = TRUE; 05126 item = EQ_NEXT_EQUIV_OBJ(item); 05127 } 05128 } 05129 } 05130 else if (dalign_shift_offset || dalign_offset_ok) { 05131 item = eq_idx; 05132 05133 while (item != NULL_IDX) { 05134 EQ_DALIGN_ME(item) = TRUE; 05135 item = EQ_NEXT_EQUIV_OBJ(item); 05136 } 05137 } 05138 # endif 05139 05140 group = EQ_NEXT_EQUIV_GRP(group); 05141 } 05142 05143 TRACE (Func_Exit, "final_equivalence_semantics", NULL); 05144 05145 return; 05146 05147 } /* final_equivalence_semantics */ 05148 05149 /******************************************************************************\ 05150 |* *| 05151 |* Description: *| 05152 |* This routine creates an integer temp that will tell which entry point *| 05153 |* you came in on. *| 05154 |* temp == 1 then main entry point. temp > 1 then, alternate entry. *| 05155 |* *| 05156 |* Input parameters: *| 05157 |* NONE *| 05158 |* *| 05159 |* Output parameters: *| 05160 |* NONE *| 05161 |* *| 05162 |* Returns: *| 05163 |* NOTHING *| 05164 |* *| 05165 \******************************************************************************/ 05166 05167 void set_up_which_entry_tmp(void) 05168 05169 { 05170 05171 int al_idx; 05172 int asg_idx; 05173 int attr_idx; 05174 int col; 05175 int i; 05176 int line; 05177 int save_curr_stmt_sh_idx; 05178 long_type the_constant; 05179 int tmp_idx; 05180 05181 05182 TRACE (Func_Entry, "set_up_which_entry_tmp", NULL); 05183 05184 if (SCP_WHICH_ENTRY_TMP(curr_scp_idx) == NULL_IDX) { 05185 05186 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05187 05188 /* get main pgm unit attr */ 05189 05190 attr_idx = SCP_ATTR_IDX(curr_scp_idx); 05191 line = SH_GLB_LINE(SCP_LAST_SH_IDX(curr_scp_idx)); 05192 col = SH_COL_NUM(SCP_LAST_SH_IDX(curr_scp_idx)); 05193 05194 /* create the index temp */ 05195 05196 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 05197 05198 SCP_WHICH_ENTRY_TMP(curr_scp_idx) = tmp_idx; 05199 05200 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 05201 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 05202 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 05203 05204 /* gen assignment to index temp at entry */ 05205 05206 the_constant = 1; 05207 05208 NTR_IR_TBL(asg_idx); 05209 IR_OPR(asg_idx) = Asg_Opr; 05210 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 05211 IR_LINE_NUM(asg_idx) = line; 05212 IR_COL_NUM(asg_idx) = col; 05213 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 05214 IR_IDX_L(asg_idx) = tmp_idx; 05215 IR_LINE_NUM_L(asg_idx) = line; 05216 IR_COL_NUM_L(asg_idx) = col; 05217 IR_LINE_NUM_R(asg_idx) = line; 05218 IR_COL_NUM_R(asg_idx) = col; 05219 IR_FLD_R(asg_idx) = CN_Tbl_Idx; 05220 IR_IDX_R(asg_idx) = CN_INTEGER_ONE_IDX; 05221 05222 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 05223 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05224 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 05225 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05226 05227 al_idx = SCP_ENTRY_IDX(curr_scp_idx); 05228 05229 for (i = 0; i < SCP_ALT_ENTRY_CNT(curr_scp_idx); i++) { 05230 05231 attr_idx = AL_ATTR_IDX(al_idx); 05232 05233 the_constant++; 05234 05235 /* gen assignment to index temp at entry */ 05236 05237 NTR_IR_TBL(asg_idx); 05238 IR_OPR(asg_idx) = Asg_Opr; 05239 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 05240 IR_LINE_NUM(asg_idx) = line; 05241 IR_COL_NUM(asg_idx) = col; 05242 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 05243 IR_IDX_L(asg_idx) = tmp_idx; 05244 IR_LINE_NUM_L(asg_idx) = line; 05245 IR_COL_NUM_L(asg_idx) = col; 05246 IR_LINE_NUM_R(asg_idx) = line; 05247 IR_COL_NUM_R(asg_idx) = col; 05248 IR_FLD_R(asg_idx) = CN_Tbl_Idx; 05249 IR_IDX_R(asg_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 05250 the_constant); 05251 05252 curr_stmt_sh_idx = ATP_FIRST_SH_IDX(attr_idx); 05253 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 05254 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 05255 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05256 05257 al_idx = AL_NEXT_IDX(al_idx); 05258 } 05259 05260 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05261 } 05262 05263 05264 TRACE (Func_Exit, "set_up_which_entry_tmp", NULL); 05265 05266 return; 05267 05268 } /* set_up_which_entry_tmp */ 05269 05270 /******************************************************************************\ 05271 |* *| 05272 |* Description: *| 05273 |* <description> *| 05274 |* *| 05275 |* Input parameters: *| 05276 |* NONE *| 05277 |* *| 05278 |* Output parameters: *| 05279 |* NONE *| 05280 |* *| 05281 |* Returns: *| 05282 |* NOTHING *| 05283 |* *| 05284 \******************************************************************************/ 05285 05286 # if defined(GENERATE_WHIRL) 05287 static void gen_user_code_start_opr(void) 05288 05289 { 05290 05291 int idx; 05292 int ir_idx; 05293 int save_curr_stmt_sh_idx; 05294 05295 TRACE (Func_Entry, "gen_user_code_start_opr", NULL); 05296 05297 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05298 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 05299 05300 NTR_IR_TBL(ir_idx); 05301 IR_OPR(ir_idx) = User_Code_Start_Opr; 05302 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 05303 IR_LINE_NUM(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05304 IR_COL_NUM(ir_idx) = 1; 05305 05306 gen_sh(After, Directive_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 1, 05307 FALSE, FALSE, TRUE); 05308 05309 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05310 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05311 05312 idx = SCP_ENTRY_IDX(curr_scp_idx); 05313 05314 while (idx) { 05315 curr_stmt_sh_idx = ATP_FIRST_SH_IDX(AL_ATTR_IDX(idx)); 05316 05317 NTR_IR_TBL(ir_idx); 05318 IR_OPR(ir_idx) = User_Code_Start_Opr; 05319 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 05320 IR_LINE_NUM(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx); 05321 IR_COL_NUM(ir_idx) = 1; 05322 05323 gen_sh(After, Directive_Stmt, SH_GLB_LINE(curr_stmt_sh_idx), 1, 05324 FALSE, FALSE, TRUE); 05325 05326 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 05327 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 05328 05329 idx = AL_NEXT_IDX(idx); 05330 } 05331 05332 05333 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05334 05335 TRACE (Func_Exit, "gen_user_code_start_opr", NULL); 05336 05337 return; 05338 05339 } /* gen_user_code_start_opr */ 05340 # endif 05341 05342 /******************************************************************************\ 05343 |* *| 05344 |* Description: *| 05345 |* <description> *| 05346 |* *| 05347 |* Input parameters: *| 05348 |* NONE *| 05349 |* *| 05350 |* Output parameters: *| 05351 |* NONE *| 05352 |* *| 05353 |* Returns: *| 05354 |* NOTHING *| 05355 |* *| 05356 \******************************************************************************/ 05357 05358 # if defined(GENERATE_WHIRL) 05359 static void insert_global_sh(void) 05360 05361 { 05362 int gl_sh_idx; 05363 int save_curr_stmt_sh_idx; 05364 int sh_idx; 05365 05366 TRACE (Func_Entry, "insert_global_sh", NULL); 05367 05368 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 05369 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 05370 gl_sh_idx = global_stmt_sh_idx; 05371 05372 while (gl_sh_idx) { 05373 05374 sh_idx = copy_from_gl_subtree(gl_sh_idx, SH_Tbl_Idx); 05375 05376 SH_NEXT_IDX(sh_idx) = SH_NEXT_IDX(curr_stmt_sh_idx); 05377 if (SH_NEXT_IDX(sh_idx) != NULL_IDX) { 05378 SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = sh_idx; 05379 } 05380 SH_PREV_IDX(sh_idx) = curr_stmt_sh_idx; 05381 SH_NEXT_IDX(curr_stmt_sh_idx) = sh_idx; 05382 curr_stmt_sh_idx = sh_idx; 05383 05384 gl_sh_idx = GL_SH_NEXT_IDX(gl_sh_idx); 05385 } 05386 05387 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05388 05389 TRACE (Func_Exit, "insert_global_sh", NULL); 05390 05391 return; 05392 05393 } /* insert_global_sh */ 05394 # endif 05395 05396 /******************************************************************************\ 05397 |* *| 05398 |* Description: *| 05399 |* Compares two global names to look for differences. They can be *| 05400 |* two definitions, two references or a reference and a definition. *| 05401 |* *| 05402 |* Input parameters: *| 05403 |* def_ga_idx -> Global_attr tbl entry describing the definition. *| 05404 |* GA_REFERENCED and GA_DEFINED are used to decide if this *| 05405 |* is a definition or a reference. GA_DEFINED rules. *| 05406 |* ref_ga_idx -> Global_attr tbl entry describing the reference. *| 05407 |* list_idx -> IR list table index describing local ref actual args *| 05408 |* spec_idx -> Global_attr tbl entry describing the reference. *| 05409 |* If ref_ga_idx is non-NULL then we use GA_DEFINED and *| 05410 |* GA_REFERENCED to decide if this is a definition or a *| 05411 |* reference. If ref_ga_idx is NULL, then this is a ref. *| 05412 |* attr_idx -> Attr index describing a definition. *| 05413 |* *| 05414 |* def_ga_idx is required. ref_ga_idx, list_idx or attr_idx is required.*| 05415 |* It is incorrect to specify more than one of those three. *| 05416 |* *| 05417 |* Output parameters: *| 05418 |* NONE *| 05419 |* *| 05420 |* Returns: *| 05421 |* NONE *| 05422 |* *| 05423 \******************************************************************************/ 05424 05425 void global_name_semantics(int def_ga_idx, 05426 int ref_ga_idx, 05427 int list_idx, 05428 int spec_idx, 05429 int attr_idx) 05430 05431 { 05432 uint act_file_line; 05433 int arg_attr_idx; 05434 int def_arg_idx; 05435 boolean def_defined; 05436 int gl_idx; 05437 int i; 05438 int il_idx; 05439 int info_idx; 05440 char line_name[256]; 05441 msg_severities_type msg_level; 05442 int msg_num; 05443 boolean need_expl_itrfc; 05444 int next_il_idx; 05445 int ref_arg_class; 05446 boolean ref_arg_class_known; 05447 int ref_arg_column; 05448 int ref_arg_idx; 05449 int ref_arg_line; 05450 char *ref_arg_name_ptr; 05451 int ref_array_elt; 05452 int ref_column; 05453 boolean ref_defined; 05454 boolean ref_elemental; 05455 boolean ref_global_dir; 05456 int ref_hollerith; 05457 boolean ref_in_interface; 05458 int ref_line; 05459 int ref_linear_type; 05460 char *ref_name_ptr; 05461 boolean ref_nosideeffects; 05462 int ref_num_dargs; 05463 int ref_pgm_unit; 05464 boolean ref_pure; 05465 int ref_rank; 05466 boolean ref_recursive; 05467 int ref_rslt_idx; 05468 int ref_type; 05469 boolean ref_vfunction; 05470 boolean same; 05471 int type_idx; 05472 05473 05474 TRACE (Func_Entry, "global_name_semantics", NULL); 05475 05476 need_expl_itrfc = FALSE; 05477 def_defined = GA_DEFINED(def_ga_idx); /* ATP_EXPL_ITRFC */ 05478 line_name[0] = '\0'; 05479 05480 GLOBAL_LINE_TO_FILE_LINE(GA_DEF_LINE(def_ga_idx), 05481 gl_idx, 05482 act_file_line); 05483 sprintf(line_name, "%d (%s)", act_file_line, GL_FILE_NAME_PTR(gl_idx)); 05484 05485 if (ref_ga_idx != NULL_IDX) { 05486 05487 /* We do not carry the extra argument in the global attr table. */ 05488 05489 ref_arg_idx = GAP_FIRST_IDX(ref_ga_idx); 05490 ref_arg_idx--; 05491 05492 ref_rslt_idx = GAP_RSLT_IDX(ref_ga_idx); 05493 ref_pgm_unit = GAP_PGM_UNIT(ref_ga_idx); 05494 ref_num_dargs = GAP_NUM_DARGS(ref_ga_idx); 05495 ref_name_ptr = GA_OBJ_NAME_PTR(ref_ga_idx); 05496 ref_defined = GA_DEFINED(ref_ga_idx); 05497 ref_line = GA_DEF_LINE(ref_ga_idx); 05498 ref_column = GA_DEF_COLUMN(ref_ga_idx); 05499 ref_in_interface = !GAP_PGM_UNIT_DEFINED(ref_ga_idx); 05500 ref_elemental = GAP_ELEMENTAL(ref_ga_idx); 05501 ref_nosideeffects = GAP_NOSIDE_EFFECTS(ref_ga_idx); 05502 ref_pure = GAP_PURE(ref_ga_idx); 05503 ref_recursive = GAP_RECURSIVE(ref_ga_idx); 05504 ref_vfunction = GAP_VFUNCTION(ref_ga_idx); 05505 ref_global_dir = GAP_GLOBAL_DIR(ref_ga_idx); 05506 05507 if (ref_rslt_idx == NULL_IDX) { 05508 ref_rank = 0; 05509 } 05510 else { 05511 ref_linear_type = GT_LINEAR_TYPE(GAD_TYPE_IDX(ref_rslt_idx)); 05512 ref_type = GT_TYPE(GAD_TYPE_IDX(ref_rslt_idx)); 05513 ref_rank = GAD_RANK(ref_rslt_idx); 05514 05515 if (ref_defined && 05516 (GAD_POINTER(ref_rslt_idx) || ref_rank != 0 || 05517 (ref_type == Character && 05518 GT_CHAR_CLASS(GAD_TYPE_IDX(ref_rslt_idx)) == Var_Len_Char))) { 05519 need_expl_itrfc = TRUE; 05520 } 05521 } 05522 } 05523 else if (attr_idx != NULL_IDX) { 05524 ref_pgm_unit = ATP_PGM_UNIT(attr_idx); 05525 ref_name_ptr = AT_OBJ_NAME_PTR(attr_idx); 05526 ref_defined = ATP_EXPL_ITRFC(attr_idx); 05527 ref_line = AT_DEF_LINE(attr_idx); 05528 ref_column = AT_DEF_COLUMN(attr_idx); 05529 ref_in_interface = ATP_IN_INTERFACE_BLK(attr_idx); 05530 ref_elemental = ATP_ELEMENTAL(attr_idx); 05531 ref_nosideeffects = ATP_NOSIDE_EFFECTS(attr_idx); 05532 ref_pure = ATP_PURE(attr_idx); 05533 ref_recursive = ATP_RECURSIVE(attr_idx); 05534 ref_vfunction = ATP_VFUNCTION(attr_idx); 05535 ref_global_dir = FALSE; 05536 05537 /* Skip past the extra argument if necessary. */ 05538 05539 if (ref_pgm_unit == Module) { 05540 ref_rslt_idx = NULL_IDX; 05541 ref_num_dargs = 0; 05542 ref_arg_idx = NULL_IDX; 05543 ref_rank = 0; 05544 } 05545 else { 05546 ref_rslt_idx = ATP_RSLT_IDX(attr_idx); 05547 ref_num_dargs = ATP_NUM_DARGS(attr_idx); 05548 ref_arg_idx = ATP_FIRST_IDX(attr_idx); 05549 05550 /* Set ref_arg_idx to one more than the number of dargs. One */ 05551 /* is subtracted from it at the start of the darg loop. */ 05552 05553 if (ref_defined && ATP_EXTRA_DARG(attr_idx)) { 05554 ref_num_dargs--; 05555 } 05556 else { 05557 ref_arg_idx--; 05558 } 05559 05560 if (ref_rslt_idx == NULL_IDX) { 05561 ref_rank = 0; 05562 ref_linear_type = Err_Res; 05563 ref_type = Integer; /* Default */ 05564 } 05565 else { 05566 ref_linear_type = TYP_LINEAR(ATD_TYPE_IDX(ref_rslt_idx)); 05567 ref_type = TYP_TYPE(ATD_TYPE_IDX(ref_rslt_idx)); 05568 ref_rank = (ATD_ARRAY_IDX(ref_rslt_idx) != NULL_IDX) ? 05569 BD_RANK(ATD_ARRAY_IDX(ref_rslt_idx)) : 0; 05570 05571 if (ref_defined && 05572 (ATD_POINTER(ref_rslt_idx) || ref_rank != 0 || 05573 (ref_type == Character && 05574 TYP_CHAR_CLASS(ATD_TYPE_IDX(ref_rslt_idx)) == Var_Len_Char))) { 05575 need_expl_itrfc = TRUE; 05576 } 05577 } 05578 } 05579 } 05580 else { 05581 next_il_idx = list_idx; 05582 ref_pgm_unit = ATP_PGM_UNIT(spec_idx); 05583 ref_rslt_idx = ATP_RSLT_IDX(spec_idx); 05584 ref_num_dargs = ATP_NUM_DARGS(spec_idx); 05585 ref_name_ptr = AT_OBJ_NAME_PTR(spec_idx); 05586 ref_defined = ATP_EXPL_ITRFC(spec_idx); 05587 ref_line = stmt_start_line; 05588 ref_column = stmt_start_col; 05589 ref_in_interface = ATP_IN_INTERFACE_BLK(spec_idx); 05590 ref_elemental = ATP_ELEMENTAL(spec_idx); 05591 ref_nosideeffects = ATP_NOSIDE_EFFECTS(spec_idx); 05592 ref_pure = ATP_PURE(spec_idx); 05593 ref_recursive = ATP_RECURSIVE(spec_idx); 05594 ref_vfunction = ATP_VFUNCTION(spec_idx); 05595 ref_global_dir = FALSE; 05596 05597 if (ref_defined && ATP_EXTRA_DARG(spec_idx)) { 05598 ref_num_dargs--; 05599 } 05600 05601 if (ref_rslt_idx == NULL_IDX) { 05602 ref_rank = 0; 05603 } 05604 else { 05605 ref_linear_type = TYP_LINEAR(ATD_TYPE_IDX(ref_rslt_idx)); 05606 ref_type = TYP_TYPE(ATD_TYPE_IDX(ref_rslt_idx)); 05607 ref_rank = (ATD_ARRAY_IDX(ref_rslt_idx) != NULL_IDX) ? 05608 BD_RANK(ATD_ARRAY_IDX(ref_rslt_idx)) : 0; 05609 05610 /* Skip past the extra argument if necessary. */ 05611 05612 if (next_il_idx != NULL_IDX && 05613 FUNCTION_MUST_BE_SUBROUTINE(ref_rslt_idx) && FALSE) { 05614 /* keep source level don't need this */ 05615 next_il_idx = IL_NEXT_LIST_IDX(next_il_idx); 05616 } 05617 } 05618 } 05619 05620 if ((GAP_PGM_UNIT(def_ga_idx) != ref_pgm_unit) || 05621 (GAP_PGM_UNIT_DEFINED(def_ga_idx) && ref_defined && !ref_in_interface)){ 05622 05623 if (ref_global_dir || GAP_GLOBAL_DIR(def_ga_idx)) { 05624 goto EXIT; /* Specified in a global directive - only */ 05625 } 05626 05627 /* The two program units are not the same, as in one is a FUNCTION */ 05628 /* and one is a SUBROUTINE, OR they both are the same, but there */ 05629 /* are two definitions. */ 05630 05631 # if defined(_ERROR_DUPLICATE_GLOBALS) 05632 msg_level = Error; 05633 # else 05634 msg_level = (GAP_PGM_UNIT(def_ga_idx) == Module || 05635 ref_pgm_unit == Module) ? Error : Warning; 05636 # endif 05637 05638 if (def_defined) { 05639 msg_num = (ref_defined) ? 1282 : 1293; 05640 } 05641 else { 05642 msg_num = 1620; 05643 } 05644 05645 PRINTMSG(ref_line, msg_num, msg_level, ref_column, 05646 ref_name_ptr, 05647 pgm_unit_str[GAP_PGM_UNIT(def_ga_idx)], 05648 line_name, 05649 pgm_unit_str[ref_pgm_unit]); 05650 05651 /* If the program units are different, other checks make no sense. */ 05652 05653 goto EXIT; 05654 } 05655 05656 if (!def_defined && !ref_defined) { /* Two references */ 05657 05658 if (GAP_VFUNCTION(def_ga_idx) ^ ref_vfunction) { 05659 PRINTMSG(ref_line, 1625, Warning, ref_column, 05660 ref_name_ptr, 05661 line_name, 05662 "VFUNCTION"); 05663 } 05664 05665 if (GAP_NOSIDE_EFFECTS(def_ga_idx) ^ ref_nosideeffects) { 05666 PRINTMSG(ref_line, 1625, Warning, ref_column, 05667 ref_name_ptr, 05668 line_name, 05669 "NOSIDE EFFECTS"); 05670 } 05671 05672 /* Cannot check dargs or result types for two references. */ 05673 /* These may be interlanguage calls. */ 05674 05675 goto EXIT; 05676 } 05677 05678 05679 05680 /* Check type and rank of the function result if Function */ 05681 05682 if (GAP_RSLT_IDX(def_ga_idx) != NULL_IDX && 05683 ref_rslt_idx != NULL_IDX && 05684 GAP_PGM_UNIT(def_ga_idx) == Function) { 05685 05686 if (ref_ga_idx != NULL_IDX) { 05687 same = compare_global_type_rank(GAP_RSLT_IDX(def_ga_idx), 05688 GAP_RSLT_IDX(ref_ga_idx), 05689 NULL_IDX, 05690 NULL_IDX, 05691 FALSE); 05692 } 05693 else if (attr_idx != NULL_IDX) { 05694 same = compare_global_type_rank(GAP_RSLT_IDX(def_ga_idx), 05695 NULL_IDX, 05696 ATP_RSLT_IDX(attr_idx), 05697 NULL_IDX, 05698 FALSE); 05699 } 05700 else { 05701 same = compare_global_type_rank(GAP_RSLT_IDX(def_ga_idx), 05702 NULL_IDX, 05703 ATP_RSLT_IDX(spec_idx), 05704 NULL_IDX, 05705 FALSE); 05706 } 05707 05708 if (!same) { 05709 05710 if (def_defined) { 05711 msg_level = Warning; 05712 05713 # if defined(_ERROR_DUPLICATE_GLOBALS) 05714 05715 if (ref_defined) { 05716 msg_level = Error; 05717 } 05718 # endif 05719 PRINTMSG(ref_line, 1294, msg_level, ref_column, 05720 ref_name_ptr, 05721 line_name, 05722 GA_OBJ_NAME_PTR(GAP_RSLT_IDX(def_ga_idx))); 05723 } 05724 else { 05725 msg_num = (ref_defined) ? 1618 : 1617; 05726 msg_level = (msg_num == 1617) ? Caution : Warning; 05727 PRINTMSG(ref_line, msg_num, msg_level, ref_column, 05728 ref_name_ptr, 05729 line_name); 05730 } 05731 } 05732 } 05733 05734 /* If list_idx is non-NULL, we do not have a number of dargs. */ 05735 /* To get it, we need to count the number of list items. */ 05736 05737 if (list_idx == NULL_IDX && 05738 (ref_defined || def_defined) && 05739 ref_num_dargs != GAP_NUM_DARGS(def_ga_idx)) { 05740 msg_level = Warning; 05741 05742 # if defined(_ERROR_DUPLICATE_GLOBALS) 05743 05744 if (def_defined && ref_defined) { 05745 msg_level = Error; 05746 } 05747 # endif 05748 PRINTMSG(ref_line, 1295, msg_level, ref_column, 05749 ref_name_ptr, 05750 line_name, 05751 GAP_NUM_DARGS(def_ga_idx), 05752 ref_num_dargs); 05753 goto EXIT; 05754 } 05755 05756 /* Check ELEMENTAL, PURE, VFUNCTION, NOSIDE EFFECTS and RECURSIVE */ 05757 05758 if (ref_defined && def_defined) { 05759 05760 if (GAP_ELEMENTAL(def_ga_idx) ^ ref_elemental) { 05761 PRINTMSG(ref_line, 1624, Warning, ref_column, 05762 ref_name_ptr, 05763 line_name, 05764 "ELEMENTAL"); 05765 } 05766 05767 /* There is a rule in f95 before NOTE 12.4 that states that */ 05768 /* the interface may specify a procedure that is not pure */ 05769 /* if the procedure is defined to be pure. */ 05770 05771 if (GAP_PURE(def_ga_idx) ^ ref_pure) { 05772 05773 if (GAP_PURE(def_ga_idx) && ref_in_interface || 05774 ref_pure && GAP_IN_INTERFACE_BLK(def_ga_idx)) { 05775 05776 /* Intentionally blank */ 05777 } 05778 else { 05779 PRINTMSG(ref_line, 1624, Warning, ref_column, 05780 ref_name_ptr, 05781 line_name, 05782 "PURE"); 05783 } 05784 } 05785 05786 if (GAP_RECURSIVE(def_ga_idx) ^ ref_recursive) { 05787 PRINTMSG(ref_line, 1624, Warning, ref_column, 05788 ref_name_ptr, 05789 line_name, 05790 "RECURSIVE"); 05791 } 05792 05793 } 05794 05795 def_arg_idx = GAP_FIRST_IDX(def_ga_idx); 05796 05797 def_arg_idx--; /* Set up so we can increment correctly */ 05798 05799 for (i = 0; i < GAP_NUM_DARGS(def_ga_idx); i++ ) { 05800 def_arg_idx++; 05801 05802 if (ref_ga_idx != NULL_IDX) { 05803 ref_arg_idx++; 05804 ref_arg_line = GA_DEF_LINE(ref_arg_idx); 05805 ref_arg_column = GA_DEF_COLUMN(ref_arg_idx); 05806 ref_arg_name_ptr = GA_OBJ_NAME_PTR(ref_arg_idx); 05807 ref_arg_class = GA_OBJ_CLASS(ref_arg_idx); 05808 ref_arg_class_known = TRUE; 05809 05810 if (GA_OPTIONAL(ref_arg_idx)) { 05811 need_expl_itrfc = TRUE; 05812 } 05813 05814 if (ref_arg_class == Data_Obj) { 05815 ref_arg_class_known = GAD_CLASS(ref_arg_idx) != Atd_Unknown; 05816 ref_rank = GAD_RANK(ref_arg_idx); 05817 ref_array_elt = GAD_ARRAY_ELEMENT_REF(ref_arg_idx); 05818 ref_linear_type = GT_LINEAR_TYPE(GAD_TYPE_IDX(ref_arg_idx)); 05819 ref_type = GT_TYPE(GAD_TYPE_IDX(ref_arg_idx)); 05820 ref_hollerith = (GAD_CLASS(ref_ga_idx) == Constant) ? 05821 GAD_HOLLERITH(ref_ga_idx) : Not_Hollerith; 05822 05823 if (GAD_POINTER(ref_arg_idx) || GAD_TARGET(ref_arg_idx) || 05824 GAD_ASSUMED_SHAPE_ARRAY(ref_arg_idx)) { 05825 need_expl_itrfc = TRUE; 05826 } 05827 } 05828 } 05829 else if (attr_idx != NULL_IDX) { 05830 ref_arg_idx++; 05831 arg_attr_idx = SN_ATTR_IDX(ref_arg_idx); 05832 05833 if (SN_LINE_NUM(ref_arg_idx) != 0) { 05834 ref_arg_line = SN_LINE_NUM(ref_arg_idx); 05835 ref_arg_column = SN_COLUMN_NUM(ref_arg_idx); 05836 } 05837 else { 05838 ref_arg_line = AT_DEF_LINE(arg_attr_idx); 05839 ref_arg_column = AT_DEF_COLUMN(arg_attr_idx); 05840 } 05841 ref_arg_name_ptr = AT_OBJ_NAME_PTR(arg_attr_idx); 05842 ref_arg_class = AT_OBJ_CLASS(arg_attr_idx); 05843 ref_arg_class_known = TRUE; 05844 05845 if (AT_OPTIONAL(arg_attr_idx)) { 05846 need_expl_itrfc = TRUE; 05847 } 05848 05849 if (ref_arg_class == Data_Obj) { 05850 ref_arg_class_known = ATD_CLASS(arg_attr_idx) != Atd_Unknown; 05851 ref_rank = (ATD_ARRAY_IDX(arg_attr_idx) == NULL_IDX) ? 05852 0 : BD_RANK(ATD_ARRAY_IDX(arg_attr_idx)); 05853 ref_array_elt = ATD_ARRAY_IDX(arg_attr_idx) == NULL_IDX; 05854 ref_linear_type = TYP_LINEAR(ATD_TYPE_IDX(arg_attr_idx)); 05855 ref_type = TYP_TYPE(ATD_TYPE_IDX(arg_attr_idx)); 05856 ref_hollerith = (ATD_CLASS(arg_attr_idx) != Constant) ? 05857 Not_Hollerith : 05858 CN_HOLLERITH_TYPE(ATD_CONST_IDX(arg_attr_idx)); 05859 05860 if (ATD_POINTER(arg_attr_idx) || ATD_TARGET(arg_attr_idx) || 05861 (ATD_ARRAY_IDX(arg_attr_idx) != NULL_IDX && FALSE && 05862 BD_ARRAY_CLASS(ATD_ARRAY_IDX(arg_attr_idx)) == Assumed_Shape)){ 05863 need_expl_itrfc = TRUE; 05864 } 05865 } 05866 } 05867 else { 05868 il_idx = next_il_idx; 05869 05870 if (il_idx == NULL_IDX) { /* Out of reference args */ 05871 PRINTMSG(ref_line, 1295, Warning, ref_column, 05872 ref_name_ptr, 05873 line_name, 05874 GAP_NUM_DARGS(def_ga_idx), 05875 i+1); /* Number of dargs */ 05876 goto EXIT; 05877 } 05878 05879 info_idx = IL_ARG_DESC_IDX(il_idx); 05880 next_il_idx = IL_NEXT_LIST_IDX(il_idx); 05881 ref_arg_line = arg_info_list[info_idx].line; 05882 ref_arg_column = arg_info_list[info_idx].col; 05883 05884 if (IL_FLD(il_idx) == AT_Tbl_Idx) { 05885 ref_arg_name_ptr = AT_OBJ_NAME_PTR(IL_IDX(il_idx)); 05886 ref_arg_class = AT_OBJ_CLASS(IL_IDX(il_idx)); 05887 05888 if (ref_arg_class == Data_Obj) { 05889 ref_arg_class_known = ATD_CLASS(IL_IDX(il_idx)) != Atd_Unknown; 05890 } 05891 else { 05892 ref_arg_class_known = TRUE; 05893 } 05894 } 05895 05896 /* KAY - Another hole - what if this is a constant or an expression?*/ 05897 else { 05898 ref_arg_name_ptr = " "; 05899 ref_arg_class = 0; 05900 ref_arg_class_known = arg_info_list[info_idx].pgm_unit; 05901 } 05902 05903 if (!arg_info_list[info_idx].pgm_unit) { 05904 ref_rank = arg_info_list[info_idx].ed.rank; 05905 ref_array_elt = arg_info_list[info_idx].ed.array_elt; 05906 ref_linear_type = arg_info_list[info_idx].ed.linear_type; 05907 ref_type = arg_info_list[info_idx].ed.type; 05908 ref_hollerith = (IL_FLD(list_idx) == CN_Tbl_Idx) ? 05909 CN_HOLLERITH_TYPE(IL_IDX(list_idx)) : 05910 Not_Hollerith; 05911 } 05912 } 05913 05914 if (GA_OBJ_CLASS(def_arg_idx) == Data_Obj) { 05915 05916 if (GA_COMPILER_GEND(def_arg_idx) && 05917 GAD_CLASS(def_arg_idx) == Dummy_Argument) { /* Alt return */ 05918 05919 if (ref_defined) { 05920 05921 if (ref_arg_class != Data_Obj) { 05922 PRINTMSG(ref_arg_line, 1296, Warning, ref_arg_column, 05923 ref_name_ptr, 05924 line_name, 05925 i + 1); /* darg number */ 05926 continue; 05927 } 05928 05929 if ((attr_idx != NULL_IDX || spec_idx != NULL_IDX) && 05930 AT_COMPILER_GEND(ref_arg_idx) && 05931 ATD_CLASS(ref_arg_idx) == Dummy_Argument) { 05932 05933 /* Ok - intentionally blank */ 05934 } 05935 else if (ref_ga_idx != NULL_IDX && 05936 GA_COMPILER_GEND(ref_arg_idx) && 05937 GAD_CLASS(ref_arg_idx) == Dummy_Argument) { 05938 05939 /* Ok - intentionally blank */ 05940 } 05941 else { 05942 PRINTMSG(ref_arg_line, 1296, Warning, ref_arg_column, 05943 ref_name_ptr, 05944 line_name, 05945 i + 1); /* darg number */ 05946 continue; 05947 } 05948 } 05949 else if (ref_arg_class != Label) { 05950 PRINTMSG(ref_arg_line, 1296, Warning, ref_arg_column, 05951 ref_name_ptr, 05952 line_name); 05953 continue; 05954 } 05955 05956 continue; /* No more checks for this darg */ 05957 } 05958 05959 if (GAD_CLASS(def_arg_idx) != Atd_Unknown && 05960 ref_arg_class != Data_Obj) { 05961 05962 /* Dummy is data object. Actual is procedure */ 05963 05964 /* If it is unknown - there is not enough info */ 05965 /* to decide if this is a Pgm_Unit or Data_Obj */ 05966 05967 if (def_defined) { /* Def is definition, other is ref or def */ 05968 PRINTMSG(ref_arg_line, 1297, Caution, ref_arg_column, 05969 ref_name_ptr, 05970 line_name, 05971 GA_OBJ_NAME_PTR(def_arg_idx)); 05972 } 05973 else { /* Assume reference is defined */ 05974 PRINTMSG(ref_arg_line, 1300, Caution, ref_arg_column, 05975 ref_name_ptr, 05976 line_name, 05977 ref_arg_name_ptr); 05978 } 05979 continue; 05980 } 05981 05982 if (!GAD_IGNORE_TKR(def_arg_idx) && ref_rank != GAD_RANK(def_arg_idx)){ 05983 05984 /* ranks are different */ 05985 05986 if (ref_rank == 0) { /* The second is scalar */ 05987 05988 if ((!def_defined && GAD_ARRAY_ELEMENT_REF(def_arg_idx)) || 05989 ref_array_elt) { 05990 05991 /* If the first is a reference and the arg is an array */ 05992 /* element reference then the second can be a scalar. */ 05993 /* If the second is a reference and the arg is an array */ 05994 /* element reference, then the first can be an array. */ 05995 } 05996 else if (def_defined) { /* First is an array. */ 05997 PRINTMSG(ref_arg_line, 1615, Warning, ref_arg_column, 05998 ref_name_ptr, 05999 line_name, 06000 GA_OBJ_NAME_PTR(def_arg_idx)); 06001 continue; 06002 } 06003 else { 06004 PRINTMSG(ref_arg_line, 1619, Caution, ref_arg_column, 06005 ref_name_ptr, 06006 line_name, 06007 i+1); /* Arg number */ 06008 continue; 06009 } 06010 } 06011 else if (GAD_RANK(def_arg_idx) == 0) { 06012 06013 /* One is scalar, the second is an array */ 06014 06015 if ((!def_defined && GAD_ARRAY_ELEMENT_REF(def_arg_idx)) || 06016 ref_array_elt) { 06017 06018 /* If the first is a reference and the arg is an array */ 06019 /* element reference then the second can be an array. */ 06020 /* If the second is a reference and the arg is an array */ 06021 /* element reference, then the first can be a scalar. */ 06022 } 06023 else if (def_defined) { /* def/def or def/ref */ 06024 PRINTMSG(ref_arg_line, 1278, Warning, ref_arg_column, 06025 ref_name_ptr, 06026 line_name, 06027 GA_OBJ_NAME_PTR(def_arg_idx)); 06028 } 06029 else { 06030 PRINTMSG(ref_arg_line, 1616, Caution, ref_arg_column, 06031 ref_name_ptr, 06032 line_name, 06033 i+1); /* Arg number */ 06034 } 06035 continue; 06036 } 06037 } 06038 06039 if (GAD_IGNORE_TKR(def_arg_idx)) { 06040 06041 /* intentionally blank */ 06042 /* This dummy arg will match any type, so skip */ 06043 /* the type and kind type checking below. */ 06044 } 06045 else { 06046 type_idx = GAD_TYPE_IDX(def_arg_idx); 06047 same = TRUE; 06048 06049 if (GT_TYPE(type_idx) == ref_type && 06050 GT_LINEAR_TYPE(type_idx) == ref_linear_type) { 06051 06052 if (GT_TYPE(type_idx) == Structure) { 06053 06054 if (ref_ga_idx != NULL_IDX) { 06055 same = compare_global_derived_type( 06056 GT_STRUCT_IDX(type_idx), 06057 GT_STRUCT_IDX(GAD_TYPE_IDX(ref_arg_idx)), 06058 NULL_IDX); 06059 } 06060 else if (attr_idx != NULL_IDX) { 06061 same = compare_global_derived_type( 06062 GT_STRUCT_IDX(type_idx), 06063 NULL_IDX, 06064 TYP_IDX(ATD_TYPE_IDX(arg_attr_idx))); 06065 } 06066 else { 06067 same = compare_global_derived_type( 06068 GT_STRUCT_IDX(type_idx), 06069 NULL_IDX, 06070 TYP_IDX(arg_info_list[info_idx].ed.type_idx)); 06071 } 06072 } 06073 } 06074 else if (GT_TYPE(type_idx) == Character && ref_type == Character) { 06075 same = TRUE; 06076 } 06077 else if (!ref_defined && !def_defined) { 06078 06079 /* Two references. Compare both ways. We can be the most */ 06080 /* lenient with this type of comparison. */ 06081 06082 same = compare_global_args(GT_TYPE(type_idx), 06083 GT_LINEAR_TYPE(type_idx), 06084 ref_type, 06085 ref_linear_type, 06086 ref_hollerith); 06087 06088 if (!same) { 06089 06090 /* This could be considered kludgy. We compare this both */ 06091 /* ways rather than duplicating the code. If either way */ 06092 /* compares we consider it the same. */ 06093 06094 same = compare_global_args(ref_type, 06095 ref_linear_type, 06096 GT_TYPE(type_idx), 06097 GT_LINEAR_TYPE(type_idx), 06098 GAD_CLASS(def_arg_idx) == Constant? 06099 GAD_HOLLERITH(def_arg_idx): 06100 Not_Hollerith); 06101 } 06102 } 06103 else if (ref_defined && def_defined) { 06104 06105 /* Comparing two definitions - Can be most strict */ 06106 06107 same = FALSE; 06108 } 06109 else { /* A reference and a definition */ 06110 06111 if (def_defined) { 06112 same = compare_global_args(GT_TYPE(type_idx), 06113 GT_LINEAR_TYPE(type_idx), 06114 ref_type, 06115 ref_linear_type, 06116 ref_hollerith); 06117 } 06118 else { /* Ref is defined */ 06119 same = compare_global_args(ref_type, 06120 ref_linear_type, 06121 GT_TYPE(type_idx), 06122 GT_LINEAR_TYPE(type_idx), 06123 GAD_CLASS(def_arg_idx) == Constant? 06124 GAD_HOLLERITH(def_arg_idx): 06125 Not_Hollerith); 06126 } 06127 } 06128 06129 if (!same) { 06130 06131 if (def_defined) { 06132 PRINTMSG(ref_arg_line, 1279, Warning, ref_arg_column, 06133 ref_name_ptr, 06134 line_name, 06135 GA_OBJ_NAME_PTR(def_arg_idx)); 06136 } 06137 else { 06138 PRINTMSG(ref_arg_line, 1301, Caution, ref_arg_column, 06139 ref_name_ptr, 06140 line_name, 06141 i+1); /* Arg number */ 06142 } 06143 } 06144 } 06145 } 06146 else if (GA_OBJ_CLASS(def_arg_idx) == Label) { 06147 } 06148 else if (GA_OBJ_CLASS(def_arg_idx) == Pgm_Unit) { 06149 06150 if (ref_arg_class != Pgm_Unit && ref_arg_class_known) { 06151 06152 if (def_defined) { 06153 PRINTMSG(ref_arg_line, 1660, Caution, ref_arg_column, 06154 ref_name_ptr, 06155 line_name, 06156 GA_OBJ_NAME_PTR(def_arg_idx)); 06157 } 06158 else { 06159 PRINTMSG(ref_arg_line, 1661, Caution, ref_arg_column, 06160 ref_name_ptr, 06161 line_name, 06162 ref_arg_name_ptr); 06163 } 06164 continue; 06165 } 06166 06167 if (ref_ga_idx != NULL_IDX) { 06168 ref_pgm_unit = GAP_PGM_UNIT(ref_arg_idx); 06169 } 06170 else if (attr_idx != NULL_IDX) { 06171 ref_pgm_unit = ATP_PGM_UNIT(arg_attr_idx); 06172 } 06173 else if (IL_FLD(il_idx) == AT_Tbl_Idx) { 06174 ref_pgm_unit = ATP_PGM_UNIT(IL_IDX(il_idx)); 06175 } 06176 else { /* KAY - We should issue a message if this is an expr. */ 06177 ref_pgm_unit = Pgm_Unknown; 06178 } 06179 06180 if (ref_pgm_unit == Function) { 06181 06182 if (ref_ga_idx != NULL_IDX) { 06183 ref_rslt_idx = GAP_RSLT_IDX(ref_arg_idx); 06184 } 06185 else if (attr_idx != NULL_IDX) { 06186 ref_rslt_idx = ATP_RSLT_IDX(arg_attr_idx); 06187 } 06188 else { 06189 ref_rslt_idx = ATP_RSLT_IDX(IL_IDX(il_idx)); 06190 } 06191 06192 if (GAP_PGM_UNIT(def_arg_idx) == Function) { 06193 06194 if (ref_rslt_idx == NULL_IDX || 06195 GAP_RSLT_IDX(def_arg_idx) == NULL_IDX) { 06196 06197 /* One or both results missing - Intentionally blank */ 06198 06199 } 06200 else { 06201 06202 if (ref_ga_idx != NULL_IDX) { 06203 same = compare_global_type_rank(GAP_RSLT_IDX(def_arg_idx), 06204 ref_rslt_idx, 06205 NULL_IDX, 06206 NULL_IDX, 06207 FALSE); 06208 } 06209 else { /* Attr_idx & list_idx are both set to an attr index */ 06210 same = compare_global_type_rank(GAP_RSLT_IDX(def_arg_idx), 06211 NULL_IDX, 06212 ref_rslt_idx, 06213 NULL_IDX, 06214 FALSE); 06215 } 06216 06217 if (!same) { 06218 06219 if (def_defined) { 06220 PRINTMSG(ref_arg_line, 1298, Warning, ref_arg_column, 06221 ref_name_ptr, 06222 line_name, 06223 GA_OBJ_NAME_PTR(def_arg_idx), 06224 ref_arg_name_ptr); 06225 } 06226 else { 06227 PRINTMSG(ref_arg_line, 1614, Caution, ref_arg_column, 06228 ref_name_ptr, 06229 line_name, 06230 i + 1); /* Arg number */ 06231 } 06232 } 06233 } 06234 } 06235 else if (GAP_PGM_UNIT(def_arg_idx) != Pgm_Unknown) { 06236 PRINTMSG(ref_arg_line, 1299, Warning, ref_arg_column, 06237 ref_name_ptr, 06238 line_name, 06239 pgm_unit_str[GAP_PGM_UNIT(def_arg_idx)], 06240 GA_OBJ_NAME_PTR(def_arg_idx)); 06241 } 06242 } 06243 else if (ref_pgm_unit == Subroutine) { 06244 06245 if (GAP_PGM_UNIT(def_arg_idx) == Subroutine || 06246 GAP_PGM_UNIT(def_arg_idx) == Pgm_Unknown) { 06247 06248 /* Intentionally blank */ 06249 } 06250 else { 06251 PRINTMSG(ref_arg_line, 1299, Warning, ref_arg_column, 06252 ref_name_ptr, 06253 line_name, 06254 pgm_unit_str[GAP_PGM_UNIT(def_arg_idx)], 06255 GA_OBJ_NAME_PTR(def_arg_idx)); 06256 } 06257 } /* else Pgm_Unknown should match. */ 06258 } 06259 } /* End for */ 06260 06261 if (list_idx != NULL_IDX && next_il_idx != NULL_IDX) { 06262 06263 /* More reference args than definition dargs */ 06264 06265 il_idx = next_il_idx; 06266 06267 while (il_idx != NULL_IDX) { 06268 i++; 06269 il_idx = IL_NEXT_LIST_IDX(il_idx); 06270 } 06271 PRINTMSG(ref_line, 1295, Warning, ref_column, 06272 ref_name_ptr, 06273 line_name, 06274 GAP_NUM_DARGS(def_ga_idx), 06275 i); /* Number of dargs */ 06276 } 06277 06278 if (def_defined && ref_defined) { 06279 06280 /* Intentionally blank */ 06281 } 06282 else if (def_defined && GAP_NEEDS_EXPL_ITRFC(def_ga_idx)) { 06283 PRINTMSG(ref_line, 1277, Error, ref_column, 06284 ref_name_ptr, 06285 "defined", 06286 line_name); 06287 } 06288 else if (need_expl_itrfc) { /* Ref is defined */ 06289 PRINTMSG(ref_line, 1277, Error, ref_column, 06290 ref_name_ptr, 06291 "referenced", 06292 line_name); 06293 } 06294 06295 06296 EXIT: 06297 06298 TRACE (Func_Exit, "global_name_semantics", NULL); 06299 06300 return; 06301 06302 } /* global_name_semantics */ 06303 06304 /******************************************************************************\ 06305 |* *| 06306 |* Description: *| 06307 |* compares a global and local attr for type, kind type, and rank. *| 06308 |* This is used for global semantics. One dummy argument is a local *| 06309 |* attribute entry and one dummy argument is a global attribute entry. *| 06310 |* *| 06311 |* Input parameters: *| 06312 |* *| 06313 |* Output parameters: *| 06314 |* NONE *| 06315 |* *| 06316 |* Returns: *| 06317 |* TRUE is same in all three categories. *| 06318 |* FALSE otherwise. *| 06319 |* *| 06320 \******************************************************************************/ 06321 static boolean compare_global_type_rank(int def_ga_idx, 06322 int ref_ga_idx, 06323 int attr_idx, 06324 int il_idx, 06325 boolean full_array_compare) 06326 { 06327 int array_idx; 06328 int gt_idx; 06329 int info_idx; 06330 int ref_linear_type; 06331 int ref_rank; 06332 int ref_type; 06333 int ref_type_idx; 06334 boolean same; 06335 06336 06337 TRACE (Func_Entry, "compare_global_type_rank", NULL); 06338 06339 /* One of the comparisons is always a global entry, but the second */ 06340 /* comparison can be a global entry, an attr table entry or from IR. */ 06341 /* Gather the information that we need for checking. */ 06342 06343 if (il_idx != NULL_IDX) { 06344 info_idx = IL_ARG_DESC_IDX(il_idx); 06345 ref_type_idx = arg_info_list[info_idx].ed.type_idx; 06346 ref_linear_type = arg_info_list[info_idx].ed.linear_type; 06347 ref_type = arg_info_list[info_idx].ed.type; 06348 ref_rank = arg_info_list[info_idx].ed.rank; 06349 array_idx = NULL_IDX; /* Do not have an array index. */ 06350 } 06351 else if (attr_idx != NULL_IDX) { 06352 array_idx = ATD_ARRAY_IDX(attr_idx); 06353 ref_rank = array_idx != NULL_IDX ? BD_RANK(array_idx) : 0; 06354 ref_type_idx = ATD_TYPE_IDX(attr_idx); 06355 ref_linear_type = TYP_LINEAR(ref_type_idx); 06356 ref_type = TYP_TYPE(ref_type_idx); 06357 } 06358 else { 06359 array_idx = GAD_ARRAY_IDX(ref_ga_idx); 06360 ref_rank = GAD_RANK(ref_ga_idx); 06361 ref_type_idx = GAD_TYPE_IDX(ref_ga_idx); 06362 ref_linear_type = GT_LINEAR_TYPE(ref_type_idx); 06363 ref_type = GT_TYPE(ref_type_idx); 06364 } 06365 06366 same = TRUE; 06367 gt_idx = GAD_TYPE_IDX(def_ga_idx); 06368 06369 if (ref_rank != GAD_RANK(def_ga_idx) || ref_type != GT_TYPE(gt_idx)) { 06370 same = FALSE; 06371 } 06372 else if (ref_type == Structure) { 06373 06374 if (il_idx != NULL_IDX || attr_idx != NULL_IDX) { 06375 same = compare_global_derived_type(GT_STRUCT_IDX(gt_idx), 06376 NULL_IDX, 06377 TYP_IDX(ref_type_idx)); 06378 } 06379 else { 06380 same = compare_global_derived_type(GT_STRUCT_IDX(ref_type_idx), 06381 GT_STRUCT_IDX(gt_idx), 06382 NULL_IDX); 06383 } 06384 } 06385 else if (ref_type != Character && 06386 ref_linear_type != GT_LINEAR_TYPE(gt_idx)) { 06387 same = FALSE; 06388 } 06389 06390 if (same && full_array_compare && array_idx != NULL_IDX) { 06391 06392 if (attr_idx != NULL_IDX) { 06393 same = compare_global_array(GAD_ARRAY_IDX(def_ga_idx), 06394 NULL_IDX, 06395 array_idx); 06396 } 06397 else { 06398 same = compare_global_array(GAD_ARRAY_IDX(def_ga_idx), 06399 array_idx, 06400 NULL_IDX); 06401 } 06402 } 06403 06404 TRACE (Func_Exit, "compare_global_type_rank", NULL); 06405 06406 return(same); 06407 06408 } /* compare_global_type_rank */ 06409 06410 /******************************************************************************\ 06411 |* *| 06412 |* Description: *| 06413 |* Compare two derived types. The first is always from the global *| 06414 |* tables. The second can be from the global or local attr table. *| 06415 |* *| 06416 |* Input parameters: *| 06417 |* ga_idx -> Index to a global derived type to be compared. *| 06418 |* ga2_idx -> Index to a second global derived type to be compared. *| 06419 |* attr_idx -> Index to a local derived type to be compared. *| 06420 |* *| 06421 |* Output parameters: *| 06422 |* NONE *| 06423 |* *| 06424 |* Returns: *| 06425 |* TRUE if they are the same, else FALSE. *| 06426 |* *| 06427 \******************************************************************************/ 06428 static boolean compare_global_derived_type(int ga_idx, 06429 int ga2_idx, 06430 int attr_idx) 06431 06432 { 06433 int cpnt_idx; 06434 int ga_cpnt_idx; 06435 int ga_type_idx; 06436 int ga_struct_idx; 06437 int len1; 06438 int len2; 06439 int mod_idx1; 06440 int mod_idx2; 06441 long *name1; 06442 long *name2; 06443 int num_cpnts; 06444 boolean same; 06445 boolean self_ptr; 06446 int sn_idx; 06447 int struct_idx; 06448 long_type *the_constant; 06449 int the_type_idx; 06450 int type_idx; 06451 int type_linear; 06452 06453 06454 TRACE (Func_Entry, "compare_global_derived_type", NULL); 06455 06456 if (attr_idx != NULL_IDX) { 06457 06458 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 06459 attr_idx = AT_ATTR_LINK(attr_idx); 06460 } 06461 06462 /* Check to see if this is the same type and has */ 06463 /* entered into the global type table already. */ 06464 06465 if (GT_STRUCT_IDX(ATT_GLOBAL_TYPE_IDX(attr_idx)) == ga_idx) { 06466 same = TRUE; 06467 goto DONE; 06468 } 06469 06470 if (AT_USE_ASSOCIATED(attr_idx)) { 06471 name2 = AT_ORIG_NAME_LONG(attr_idx); 06472 len2 = AT_ORIG_NAME_LEN(attr_idx); 06473 mod_idx2 = AT_MODULE_IDX(attr_idx); 06474 } 06475 else { 06476 name2 = AT_OBJ_NAME_LONG(attr_idx); 06477 len2 = AT_NAME_LEN(attr_idx); 06478 mod_idx2 = NULL_IDX; 06479 } 06480 } 06481 else { 06482 06483 /* Check to see if this is the same type and has been entered. */ 06484 06485 if (ga2_idx == ga_idx) { 06486 same = TRUE; 06487 goto DONE; 06488 } 06489 if (GA_USE_ASSOCIATED(ga2_idx)) { 06490 name2 = GA_ORIG_NAME_LONG(ga2_idx); 06491 len2 = GA_ORIG_NAME_LEN(ga2_idx); 06492 mod_idx2 = GA_MODULE_IDX(ga2_idx); 06493 } 06494 else { 06495 name2 = GA_OBJ_NAME_LONG(ga2_idx); 06496 len2 = GA_NAME_LEN(ga2_idx); 06497 mod_idx2 = NULL_IDX; 06498 } 06499 } 06500 06501 if (GA_USE_ASSOCIATED(ga_idx)) { 06502 name1 = GA_ORIG_NAME_LONG(ga_idx); 06503 len1 = GA_ORIG_NAME_LEN(ga_idx); 06504 mod_idx1 = GA_MODULE_IDX(ga_idx); 06505 } 06506 else { 06507 name1 = GA_OBJ_NAME_LONG(ga_idx); 06508 len1 = GA_NAME_LEN(ga_idx); 06509 mod_idx1 = NULL_IDX; 06510 } 06511 06512 if (compare_names(name1, len1, name2, len2) != 0) { 06513 same = FALSE; 06514 goto DONE; 06515 } 06516 06517 if (ga2_idx != NULL_IDX) { /* Global to global comparison */ 06518 06519 if (mod_idx1 == mod_idx2 && mod_idx1 != NULL_IDX) { 06520 same = TRUE; 06521 goto DONE; 06522 } 06523 06524 same = (!GAT_PRIVATE_CPNT(ga2_idx) && !GAT_PRIVATE_CPNT(ga_idx) && 06525 GAT_SEQUENCE_SET(ga2_idx) && GAT_SEQUENCE_SET(ga_idx) && 06526 GAT_NUM_CPNTS(ga2_idx) == GAT_NUM_CPNTS(ga_idx) && 06527 compare_target_consts(GAT_STRUCT_BIT_LEN(ga2_idx), 06528 GAT_STRUCT_LIN_TYPE(ga2_idx), 06529 GAT_STRUCT_BIT_LEN(ga_idx), 06530 GAT_STRUCT_LIN_TYPE(ga_idx), 06531 Eq_Opr)); 06532 06533 cpnt_idx = GAT_FIRST_CPNT_IDX(ga2_idx); 06534 } 06535 else { 06536 06537 if (mod_idx1 != NULL_IDX && mod_idx2 != NULL_IDX) { 06538 06539 /* Both are from modules. Check to see if this has been entered */ 06540 /* into the global tables. If not, these still may be the same. */ 06541 06542 if (ATP_GLOBAL_ATTR_IDX(mod_idx2) == mod_idx1) { 06543 same = TRUE; 06544 goto DONE; 06545 } 06546 06547 name1 = GA_OBJ_NAME_LONG(mod_idx1); 06548 len1 = GA_NAME_LEN(mod_idx1); 06549 name2 = AT_OBJ_NAME_LONG(mod_idx2); 06550 len2 = AT_NAME_LEN(mod_idx2); 06551 06552 if (compare_names(name1, len1, name2, len2) == 0) { 06553 06554 /* They are from the same module */ 06555 /* Shortcut - set the modules index to the global table. */ 06556 06557 ATP_GLOBAL_ATTR_IDX(mod_idx2) = mod_idx1; 06558 same = TRUE; 06559 goto DONE; 06560 } 06561 } 06562 06563 same = (!ATT_PRIVATE_CPNT(attr_idx) && !GAT_PRIVATE_CPNT(ga_idx) && 06564 ATT_SEQUENCE_SET(attr_idx) && GAT_SEQUENCE_SET(ga_idx) && 06565 ATT_NUM_CPNTS(attr_idx) == GAT_NUM_CPNTS(ga_idx) && 06566 compare_target_consts( 06567 &CN_CONST(ATT_STRUCT_BIT_LEN_IDX(attr_idx)), 06568 TYP_LINEAR(CN_TYPE_IDX(ATT_STRUCT_BIT_LEN_IDX(attr_idx))), 06569 GAT_STRUCT_BIT_LEN(ga_idx), 06570 GAT_STRUCT_LIN_TYPE(ga_idx), 06571 Eq_Opr)); 06572 sn_idx = ATT_FIRST_CPNT_IDX(attr_idx); 06573 } 06574 06575 if (!same) goto DONE; 06576 06577 ga_cpnt_idx = GAT_FIRST_CPNT_IDX(ga_idx); 06578 num_cpnts = GAT_NUM_CPNTS(ga_idx); 06579 06580 while (num_cpnts > 0) { 06581 ga_type_idx = GAD_TYPE_IDX(ga_cpnt_idx); 06582 06583 if (ga2_idx == NULL_IDX) { 06584 cpnt_idx = SN_ATTR_IDX(sn_idx); 06585 sn_idx = SN_SIBLING_LINK(sn_idx); 06586 type_idx = ATD_TYPE_IDX(cpnt_idx); 06587 type_linear = TYP_LINEAR(type_idx); 06588 06589 same = ATD_POINTER(cpnt_idx) == GAD_POINTER(ga_cpnt_idx) && 06590 TYP_TYPE(type_idx) == GT_TYPE(ga_type_idx) && 06591 (compare_names(AT_OBJ_NAME_LONG(cpnt_idx), 06592 AT_NAME_LEN(cpnt_idx), 06593 GA_OBJ_NAME_LONG(ga_cpnt_idx), 06594 GA_NAME_LEN(ga_cpnt_idx)) == 0); 06595 06596 same = same && compare_global_array(GAD_ARRAY_IDX(ga_cpnt_idx), 06597 NULL_IDX, 06598 ATD_ARRAY_IDX(cpnt_idx)); 06599 } 06600 else { 06601 type_idx = GAD_TYPE_IDX(cpnt_idx); 06602 type_linear = GT_LINEAR_TYPE(type_idx); 06603 06604 same = GAD_POINTER(cpnt_idx) == GAD_POINTER(ga_cpnt_idx) && 06605 GT_TYPE(type_idx) == GT_TYPE(ga_type_idx) && 06606 (compare_names(GA_OBJ_NAME_LONG(cpnt_idx), 06607 GA_NAME_LEN(cpnt_idx), 06608 GA_OBJ_NAME_LONG(ga_cpnt_idx), 06609 GA_NAME_LEN(ga_cpnt_idx)) == 0); 06610 06611 same = same && compare_global_array(GAD_ARRAY_IDX(cpnt_idx), 06612 GAD_ARRAY_IDX(ga_cpnt_idx), 06613 NULL_IDX); 06614 } 06615 06616 if (!same) goto DONE; 06617 06618 /* Components, so they must be constants */ 06619 06620 if (GT_TYPE(ga_type_idx) == Character) { 06621 06622 if (ga2_idx == NULL_IDX) { 06623 the_constant = &CN_CONST(TYP_IDX(type_idx)); 06624 the_type_idx = CN_TYPE_IDX(TYP_IDX(type_idx)); 06625 } 06626 else { 06627 the_constant = GT_LENGTH(ga_type_idx); 06628 the_type_idx = GT_LENGTH_LIN_TYPE(ga_type_idx); 06629 } 06630 same = compare_target_consts(the_constant, 06631 the_type_idx, 06632 GT_LENGTH(GAD_TYPE_IDX(ga_cpnt_idx)), 06633 GT_LENGTH_LIN_TYPE(GAD_TYPE_IDX(ga_cpnt_idx)), 06634 Eq_Opr); 06635 } 06636 else if (GT_TYPE(ga_type_idx) == Structure) { 06637 06638 if (ga2_idx == NULL_IDX) { 06639 struct_idx = TYP_IDX(type_idx); 06640 ga_struct_idx = NULL_IDX; 06641 self_ptr = (struct_idx == attr_idx); 06642 } 06643 else { 06644 struct_idx = NULL_IDX; 06645 ga_struct_idx = GT_STRUCT_IDX(type_idx); 06646 self_ptr = (struct_idx == ga2_idx); 06647 } 06648 06649 if (GT_STRUCT_IDX(ga_type_idx) == ga_idx && self_ptr) { 06650 06651 /* Pointers to self - intentionally blank. Note: ga2_idx */ 06652 /* or attr_idx will be NULL. They both cannot be set. */ 06653 } 06654 else if (( self_ptr && GT_STRUCT_IDX(ga_type_idx) != ga_idx) || 06655 (!self_ptr && GT_STRUCT_IDX(ga_type_idx) == ga_idx)) { 06656 same = FALSE; 06657 goto DONE; 06658 } 06659 else { 06660 same = compare_global_derived_type(GT_STRUCT_IDX(ga_type_idx), 06661 ga_struct_idx, 06662 struct_idx); 06663 } 06664 } 06665 else { 06666 same = (type_linear == GT_LINEAR_TYPE(ga_type_idx)); 06667 } 06668 ga_cpnt_idx++; 06669 num_cpnts--; 06670 } 06671 06672 DONE: 06673 06674 TRACE (Func_Exit, "compare_global_derived_type", NULL); 06675 06676 return(same); 06677 06678 } /* compare_global_derived_type */ 06679 06680 /******************************************************************************\ 06681 |* *| 06682 |* Description: *| 06683 |* Compare two arrays, The first one is from the global bounds table, *| 06684 |* The second one can be local or global. *| 06685 |* *| 06686 |* Input parameters: *| 06687 |* gb_idx -> Index to global bounds table entry to compare. *| 06688 |* gb2_idx -> Index to another global bounds table entry to compare. *| 06689 |* bd_idx -> Index to local bounds table entry to compare. *| 06690 |* *| 06691 |* Output parameters: *| 06692 |* NONE *| 06693 |* *| 06694 |* Returns: *| 06695 |* TRUE if they are the same, else FALSE. *| 06696 |* *| 06697 \******************************************************************************/ 06698 06699 static boolean compare_global_array(int gb_idx, 06700 int gb2_idx, 06701 int bd_idx) 06702 { 06703 int dim; 06704 boolean same; 06705 06706 06707 TRACE (Func_Entry, "compare_global_array", NULL); 06708 06709 if (gb2_idx != NULL_IDX) { /* Global to global compare */ 06710 06711 if (gb2_idx == gb_idx) { 06712 same = TRUE; 06713 } 06714 else if (gb2_idx == NULL_IDX || gb_idx == NULL_IDX) { 06715 same = FALSE; /* One is NULL and one is not NULL */ 06716 } 06717 else { 06718 same = GB_RANK(gb2_idx) == GB_RANK(gb_idx) && 06719 GB_ARRAY_CLASS(gb2_idx) == GB_ARRAY_CLASS(gb_idx) && 06720 GB_ARRAY_SIZE(gb2_idx) == GB_ARRAY_SIZE(gb_idx); 06721 06722 06723 if (same && GB_ARRAY_CLASS(gb2_idx) == Explicit_Shape && 06724 GB_ARRAY_SIZE(gb2_idx) == Constant_Size) { 06725 06726 for (dim = 1; dim <= GB_RANK(gb2_idx); dim++) { 06727 same = compare_target_consts(GB_LOWER_BOUND(gb_idx, dim), 06728 GT_LINEAR_TYPE(GB_LB_TYPE(gb_idx,dim)), 06729 GB_LOWER_BOUND(gb2_idx, dim), 06730 GT_LINEAR_TYPE(GB_LB_TYPE(gb2_idx,dim)), 06731 Eq_Opr) && 06732 compare_target_consts(GB_UPPER_BOUND(gb_idx, dim), 06733 GT_LINEAR_TYPE(GB_UB_TYPE(gb_idx,dim)), 06734 GB_UPPER_BOUND(gb2_idx, dim), 06735 GT_LINEAR_TYPE(GB_UB_TYPE(gb2_idx,dim)), 06736 Eq_Opr); 06737 if (!same) break; 06738 } 06739 } 06740 } 06741 } 06742 06743 /* Global to local compare */ 06744 06745 else if (bd_idx == NULL_IDX || gb_idx == NULL_IDX) { 06746 same = (bd_idx == NULL_IDX && gb_idx == NULL_IDX); 06747 } 06748 else if (BD_GLOBAL_IDX(bd_idx) == gb_idx) { 06749 same = TRUE; 06750 } 06751 else { /* Compare the header, but not the line and column numbers */ 06752 same = BD_RANK(bd_idx) == GB_RANK(gb_idx) && 06753 BD_ARRAY_CLASS(bd_idx) == GB_ARRAY_CLASS(gb_idx) && 06754 BD_ARRAY_SIZE(bd_idx) == GB_ARRAY_SIZE(gb_idx); 06755 06756 if (same && BD_ARRAY_CLASS(bd_idx) == Explicit_Shape && 06757 BD_ARRAY_SIZE(bd_idx) == Constant_Size) { 06758 06759 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 06760 same = compare_target_consts(&CN_CONST(BD_LB_IDX(bd_idx, dim)), 06761 CN_TYPE_IDX(BD_LB_IDX(bd_idx, dim)), 06762 GB_LOWER_BOUND(gb_idx, dim), 06763 GT_LINEAR_TYPE(GB_LB_TYPE(gb_idx,dim)), 06764 Eq_Opr) && 06765 compare_target_consts(&CN_CONST(BD_UB_IDX(bd_idx, dim)), 06766 CN_TYPE_IDX(BD_UB_IDX(bd_idx, dim)), 06767 GB_UPPER_BOUND(gb_idx, dim), 06768 GT_LINEAR_TYPE(GB_UB_TYPE(gb_idx,dim)), 06769 Eq_Opr); 06770 if (!same) break; 06771 } 06772 } 06773 } 06774 06775 TRACE (Func_Exit, "compare_global_array", NULL); 06776 06777 return(same); 06778 06779 } /* compare_global_array */ 06780 06781 /******************************************************************************\ 06782 |* *| 06783 |* Description: *| 06784 |* Compare the type of two args. One is a def and one is a ref. *| 06785 |* If you have two ref's. Call this routine twice. If one or the *| 06786 |* other is the SAME then the two references are okay. *| 06787 |* *| 06788 |* Input parameters: *| 06789 |* def_type -> definition type *| 06790 |* def_linear_type -> definition linear type *| 06791 |* ref_type -> reference type *| 06792 |* ref_linear_type -> reference linear type *| 06793 |* ref_hollerith -> reference hollerith info *| 06794 |* def_ga_struct_idx -> definition structure index *| 06795 |* ref_ga_struct_idx -> reference global structure index *| 06796 |* ref_at_struct_idx -> reference attr structure index *| 06797 |* NOTE: If the type is a structure, then either ref_ga_struct_idx or *| 06798 |* ref_at_struct_idx should be set, but not both. *| 06799 |* *| 06800 |* Output parameters: *| 06801 |* NONE *| 06802 |* *| 06803 |* Returns: *| 06804 |* TRUE if they are the same, else FALSE. *| 06805 |* *| 06806 \******************************************************************************/ 06807 06808 static boolean compare_global_args(int def_type, 06809 int def_linear_type, 06810 int ref_type, 06811 int ref_linear_type, 06812 int ref_hollerith) 06813 { 06814 boolean same; 06815 06816 TRACE (Func_Entry, "compare_global_args", NULL); 06817 06818 if (ref_linear_type == Short_Typeless_Const && 06819 (def_type == Integer || 06820 def_type == Real || 06821 def_type == Complex)) { 06822 same = TRUE; 06823 } 06824 else if (ref_type == Typeless && 06825 (def_type == Integer || def_type == Real) && 06826 num_host_wds[ref_linear_type] == num_host_wds[def_linear_type]) { 06827 same = TRUE; 06828 } 06829 else if (ref_linear_type == Short_Typeless_Const && 06830 (ref_hollerith == H_Hollerith || 06831 ref_hollerith == L_Hollerith) && 06832 def_type == Character) { 06833 same = TRUE; 06834 } 06835 else if ((ref_type == Integer && def_type == CRI_Ptr) || 06836 (ref_type == CRI_Ptr && def_type == Integer)) { 06837 same = TRUE; 06838 } 06839 else { 06840 same = FALSE; 06841 } 06842 06843 TRACE (Func_Exit, "compare_global_args", NULL); 06844 06845 return(same); 06846 06847 } /* compare_global_args */
1.7.6.1 
