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 * ==================================================================== 00038 * 00039 * 00040 * Revision history: 00041 * dd-mmm-95 - Original Version 00042 * 00043 * Description: This handles symbol table conversions - types are 00044 * converted in cwh_types.c. Variables and so forth 00045 * come through fei_object and use a storage class set 00046 * up by fei_seg. If the storage class is a COMMON, or 00047 * BASED then fei_seg returns the ST of the base. Procedures 00048 * come through fei_proc_def, labels through fei_label_def_named, 00049 * constants in fei_arith_con or fei_pattern_con. 00050 * In general, the object created is passed back to PDGCS 00051 * in a packet with a tag. It's stored by the FE which provides 00052 * it as an argument when appropriate. 00053 * 00054 * There are various odds and ends associated with STs 00055 * in an auxiliary data structure called AUXST (cwh_auxst*). 00056 * The AUXST & a few lists allows information for the FE to 00057 * accumulate until it's in a suitable form for WHIRL. 00058 * 00059 * Definitions of bit masks, PDGCS values and the like 00060 * are in fef90/i_cvrt.{m,h} 00061 * 00062 * ==================================================================== 00063 * ==================================================================== 00064 */ 00065 /*REFERENCED*/ 00066 static char *source_file = __FILE__; 00067 00068 #ifdef _KEEP_RCS_ID 00069 #endif /* _KEEP_RCS_ID */ 00070 00071 00072 /* general compiler includes */ 00073 00074 #include "defs.h" 00075 #include "glob.h" 00076 #include "stab.h" 00077 #include "strtab.h" 00078 #include "errors.h" 00079 #include "targ_const.h" 00080 #include "config_targ.h" 00081 #include "const.h" 00082 #include "wn.h" 00083 #include "wn_util.h" 00084 #include "dwarf_DST_producer.h" 00085 #include "cxx_memory.h" 00086 #include "cwh_stk.h" 00087 #include <stdio.h> 00088 00089 /* FE includes */ 00090 00091 #include "i_cvrt.h" 00092 00093 /* conversion includes */ 00094 00095 #include "cwh_defines.h" 00096 #include "cwh_types.h" 00097 #include "cwh_addr.h" 00098 #include "cwh_expr.h" 00099 #include "cwh_block.h" 00100 #include "cwh_stmt.h" 00101 #include "cwh_preg.h" 00102 #include "cwh_auxst.h" 00103 #include "cwh_stab.h" 00104 #include "cwh_stab.i" 00105 #include "cwh_dst.h" 00106 #include "cwh_mkdepend.h" 00107 #include "sgi_cmd_line.h" 00108 00109 /*=================================================== 00110 * 00111 * fei_next_func_idx 00112 * 00113 * Called for any function or entry point - bump 00114 * a counter to serve as an idx. 00115 * 00116 * Create the SYMTAB for a function. 00117 * If this is an internal procedure, then it is 00118 * processed before its parent. To nest correctly, 00119 * the parent's symtab is allocated first. A parent 00120 * may have several children, so don't reallocate 00121 * its SYMTAB. SYMTABs are popped in cwh_stab_end_procs. 00122 * ( and briefly by fei_proc_parent) 00123 * 00124 ==================================================== 00125 */ 00126 /*ARGSUSED*/ 00127 extern INTPTR 00128 fei_next_func_idx(INT32 Pu_arg, 00129 INT32 Proc_arg, 00130 INT32 altentry_idx) 00131 { 00132 00133 STB_pkt *p ; 00134 static INT32 i = 0 ; 00135 PROC_CLASS proc ; 00136 00137 proc = (PROC_CLASS) Proc_arg; 00138 00139 if (altentry_idx == 0) { 00140 00141 00142 if (NOT_IN_PU ) { 00143 00144 New_Scope (HOST_LEVEL, FE_Mempool, TRUE ); 00145 cwh_auxst_register_table(); 00146 Host_Top = -1; //should keep this? 00147 Has_nested_proc = FALSE ;//? 00148 Hosted_Equivalences = NULL; 00149 Alttemp_ST = NULL; 00150 Altbase_ST = NULL; 00151 Altaddress_ST = NULL; 00152 00153 } 00154 00155 if (proc == PDGCS_Proc_Intern) { 00156 00157 New_Scope (INTERNAL_LEVEL, FE_Mempool, TRUE); 00158 cwh_auxst_register_table(); 00159 } 00160 00161 Equivalences = NULL; 00162 entry_point_count = 0 ; 00163 STB_list = NULL ; 00164 } 00165 00166 i++; 00167 p = cwh_stab_packet(cast_to_void(i), is_CONST); 00168 return(cast_to_int(p)); 00169 } 00170 00171 00172 /*=================================================== 00173 * 00174 * fei_proc 00175 * 00176 * This routine consolidates the interface routines 00177 * fei_proc_def(), fei_proc_parent(), fei_proc_imp(). 00178 * 00179 ==================================================== 00180 */ 00181 /*ARGSUSED*/ 00182 INTPTR 00183 fei_proc(char *name_string, 00184 INT32 lineno, 00185 INT32 Sym_class_arg, 00186 INT32 Class_arg, 00187 INT32 num_dum_args, 00188 INT32 parent_stx, 00189 INT32 first_st_idx, 00190 INT32 alt_entry_idx, 00191 TYPE result_type, 00192 INT32 proc_idx, 00193 INT64 flags, 00194 INT32 in_interface, 00195 INT32 coarray_concurrent ) 00196 { 00197 INTPTR p; 00198 00199 if (test_flag(flags, FEI_PROC_DEFINITION)){ 00200 p = fei_proc_def(name_string, 00201 lineno, 00202 Sym_class_arg, 00203 Class_arg, 00204 0, 00205 0, 00206 num_dum_args, 00207 parent_stx, 00208 first_st_idx, 00209 alt_entry_idx, 00210 result_type, 00211 0, 00212 proc_idx, 00213 flags, 00214 coarray_concurrent); 00215 } 00216 00217 if (test_flag(flags, FEI_PROC_IN_INTERFACE)) { 00218 p = fei_proc_interface(name_string, 00219 lineno, 00220 Sym_class_arg, 00221 Class_arg, 00222 0, 00223 0, 00224 num_dum_args, 00225 parent_stx, 00226 first_st_idx, 00227 alt_entry_idx, 00228 result_type, 00229 0, 00230 proc_idx, 00231 flags, 00232 coarray_concurrent); 00233 } 00234 00235 00236 if (test_flag(flags, FEI_PROC_PARENT)) { 00237 p = fei_proc_parent(name_string, 00238 lineno, 00239 Sym_class_arg, 00240 0, 00241 num_dum_args, 00242 parent_stx, 00243 first_st_idx, 00244 alt_entry_idx, 00245 result_type, 00246 proc_idx, 00247 flags); 00248 } 00249 00250 if (test_flag(flags, FEI_PROC_IMPORTED)) { 00251 p = fei_proc_imp(lineno, 00252 name_string, 00253 0, 00254 0, 00255 Sym_class_arg, 00256 Class_arg, 00257 result_type, 00258 flags, 00259 in_interface); 00260 00261 } 00262 00263 return(p); 00264 } 00265 00266 00267 00268 /*=================================================== 00269 * 00270 * fei_proc_def 00271 * 00272 * Build an ST for an entry point to a procedure. 00273 * Establish local data structures (cwh_stab.i) to 00274 * record dummy arguments and alternate entry points. 00275 * 00276 * Internal and module procedures may need their 00277 * names adjusting. All entry points go into the 00278 * global symbol table, as the BE doesn't look for 00279 * TEXT STs in nested SYMTAB. If a procedure 00280 * was referenced earlier, an ST was created in 00281 * fei_proc_imp, but without argument information, 00282 * so the ST is patched up here. 00283 * 00284 ==================================================== 00285 */ 00286 /*ARGSUSED*/ 00287 INTPTR 00288 fei_proc_def(char *name_string, 00289 INT32 lineno, 00290 INT32 Sym_class_arg, 00291 INT32 Class_arg, 00292 INT32 unused1, 00293 INT32 unused2, 00294 INT32 num_dum_args, 00295 INT32 parent_stx, 00296 INT32 first_st_idx, 00297 INT32 alt_entry_idx, 00298 TYPE result_type, 00299 INT32 cmcs_node, 00300 INT32 proc_idx, 00301 INT64 flags , 00302 INT32 coarray_concurrent) 00303 { 00304 ST * st ; 00305 TY_IDX ty ; 00306 STB_pkt *p ; 00307 FUNCTION_SYM sym_class; 00308 PROC_CLASS Class; 00309 BOOL is_inline_func = FALSE; 00310 ST_EXPORT eclass; 00311 TY_IDX ret_ty; 00312 00313 still_in_preamble = TRUE; 00314 00315 sym_class = (FUNCTION_SYM) Sym_class_arg; 00316 Class = (PROC_CLASS) Class_arg; 00317 00318 /* fn result type - void for results by formal */ 00319 00320 ret_ty = cast_to_TY(t_TY(result_type)) ; 00321 ty = cwh_types_mk_procedure_TY(ret_ty,num_dum_args,TRUE,FALSE); 00322 00323 if (Class == PDGCS_Proc_Intern) { 00324 00325 eclass = EXPORT_LOCAL_INTERNAL; 00326 is_inline_func = TRUE; 00327 Has_nested_proc = TRUE; 00328 00329 } else { 00330 00331 eclass = EXPORT_PREEMPTIBLE; 00332 if (test_flag(flags,FEI_PROC_OPTIONAL_DIR)) 00333 eclass = EXPORT_OPTIONAL; 00334 00335 } 00336 00337 /* Seen this symbol via a forward reference in fei_proc_imp? */ 00338 00339 st = cwh_auxst_find_item(Top_Text,name_string); 00340 00341 if (st == NULL) { 00342 00343 PU_IDX idx = cwh_stab_mk_pu(ty, CURRENT_SYMTAB); 00344 00345 st = New_ST(GLOBAL_SYMTAB); 00346 cwh_auxst_clear(st); 00347 ST_Init (st, Save_Str(name_string), CLASS_FUNC, SCLASS_TEXT, eclass, (TY_IDX) idx); 00348 Set_ST_ofst(st,0); 00349 cwh_auxst_add_to_list(&Top_Text,st,FALSE); 00350 00351 00352 } 00353 else { 00354 Set_ST_sclass(st, SCLASS_TEXT); 00355 Set_ST_export(st, eclass); 00356 } 00357 00358 /* if fei_proc_imp made ST, then ST has a default void return */ 00359 /* which should be replaced with the correct return type/args */ 00360 00361 00362 00363 PU_IDX pu_idx = ST_pu(st); 00364 PU& pu = Pu_Table[pu_idx]; 00365 pu.lexical_level =CURRENT_SYMTAB; /*"interface" declared in nested PU gave a wrong 00366 * PU level;must reset the PU level for "later" 00367 * defintion ---fzhao 00368 */ 00369 00370 Set_PU_prototype (pu, ty); 00371 Set_PU_f90_lang (pu); 00372 Set_PU_need_unparsed(pu); 00373 00374 if (is_inline_func) 00375 Set_PU_is_inline_function(pu); 00376 00377 cwh_stab_set_linenum(st,lineno); 00378 00379 /* is the MAIN anonymous? If not, create a MAIN */ 00380 /* external for debug information */ 00381 00382 if (sym_class == Main_Pgm) { 00383 00384 INTPTR midx; 00385 Set_PU_is_mainpu(pu); 00386 Set_PU_no_inline(pu); 00387 00388 # if 0 00389 /*fzhao:don't generate this extra symbal table entry for main pgrogam !*/ 00390 Main_ST = NULL; 00391 00392 if (strcmp(crayf90_def_main,ST_name(st)) != 0) { 00393 00394 midx = fei_proc_imp(lineno, 00395 def_main, 00396 0, 00397 0, 00398 Main_Pgm, 00399 PDGCS_Proc_Imported, 00400 result_type, 00401 0); 00402 00403 Main_ST = cast_to_ST(cast_to_STB(midx)->item); 00404 Set_ST_pu(Main_ST, pu_idx); 00405 cwh_stab_set_linenum(Main_ST,lineno); 00406 } 00407 # endif 00408 } 00409 00410 #if 0 00411 if (sym_class == Fort_Blockdata) 00412 DevWarn(("TODO_NEW_SYMTAB: blockdata")); 00413 #endif 00414 00415 if (sym_class == F90_Module) { 00416 cwh_add_to_module_files_table(name_string); 00417 } 00418 00419 if (Class == PDGCS_Proc_Intern) 00420 Set_PU_is_nested_func(pu); 00421 00422 if (Class == PDGCS_Proc_Extern) 00423 if (Has_nested_proc) 00424 Set_PU_uplevel(pu); 00425 00426 if (test_flag(flags, FEI_PROC_RECURSE)) 00427 Set_PU_recursive(pu); 00428 00429 // if (test_flag(flags,FEI_PROC_IN_INTERFACE) && 00430 // test_flag(flags,FEI_PROC_M_IMPORTED)) 00431 // Set_ST_is_M_imported(st); 00432 00433 cwh_auxst_alloc_proc_entry(st,num_dum_args, ret_ty); 00434 00435 if (test_flag(flags, FEI_PROC_HASRSLT)) 00436 Set_ST_auxst_has_rslt_tmp(st,TRUE); 00437 00438 if (test_flag(flags, FEI_PROC_ELEMENTAL)) 00439 Set_ST_auxst_is_elemental(st,TRUE); 00440 00441 if (test_flag(flags, FEI_PROC_MODULE)) 00442 Set_ST_is_in_module(st); 00443 00444 if (test_flag(flags, FEI_PROC_ENTRY)) { 00445 00446 Set_ST_auxst_is_altentry(st,TRUE); 00447 cwh_auxst_add_item(Procedure_ST,st,l_ALTENTRY); 00448 00449 } else { 00450 00451 Scope_tab [Current_scope].st = st; 00452 Procedure_ST = st ; 00453 cwh_stab_pu_has_globals = FALSE; 00454 00455 /* Since we need use this function to get interface block information */ 00456 /* we have to keep blocks un_initialize when we get PUs by interface */ 00457 00458 if (!test_flag(flags,FEI_PROC_IN_INTERFACE)) 00459 cwh_block_init_pu(); 00460 00461 if (test_flag(flags, FEI_PROC_HAS_ALT_ENTRY)) 00462 Set_PU_has_altentry(pu); 00463 } 00464 00465 if ((Class == PDGCS_Proc_Extern) || 00466 (Class == PDGCS_Proc_Intern)) 00467 cwh_stab_adjust_name(st); 00468 00469 // cosubroutien or cofunction ---FMZ 00470 if ( coarray_concurrent ) 00471 Set_ST_is_coarray_concurrent(st); 00472 00473 00474 st_for_distribute_temp=NULL; 00475 preg_for_distribute.preg=-1; 00476 00477 entry_point_count++ ; 00478 00479 p = cwh_stab_packet(st, is_ST); 00480 return(cast_to_int(p)); 00481 } 00482 00483 /**************************************************************************/ 00484 INTPTR 00485 fei_proc_interface(char *name_string, 00486 INT32 lineno, 00487 INT32 Sym_class_arg, 00488 INT32 Class_arg, 00489 INT32 unused1, 00490 INT32 unused2, 00491 INT32 num_dum_args, 00492 INT32 parent_stx, 00493 INT32 first_st_idx, 00494 INT32 alt_entry_idx, 00495 TYPE result_type, 00496 INT32 cmcs_node, 00497 INT32 proc_idx, 00498 INT64 flags, 00499 INT32 coarray_concurrent ) 00500 { 00501 ST * st ; 00502 TY_IDX ty ; 00503 STB_pkt *p ; 00504 FUNCTION_SYM sym_class; 00505 PROC_CLASS Class; 00506 BOOL is_inline_func = FALSE; 00507 ST_EXPORT eclass; 00508 TY_IDX ret_ty; 00509 00510 sym_class = (FUNCTION_SYM) Sym_class_arg; 00511 Class = (PROC_CLASS) Class_arg; 00512 eclass = EXPORT_PREEMPTIBLE; 00513 00514 /* fn result type - void for results by formal */ 00515 00516 ret_ty = cast_to_TY(t_TY(result_type)) ; 00517 ty = cwh_types_mk_procedure_TY(ret_ty,num_dum_args,TRUE,FALSE); 00518 00519 00520 st = cwh_auxst_find_item(Top_Text,name_string); 00521 00522 if (st == NULL) { 00523 00524 PU_IDX idx = cwh_stab_mk_pu(ty, CURRENT_SYMTAB); 00525 st = New_ST(GLOBAL_SYMTAB); 00526 cwh_auxst_clear(st); 00527 ST_Init (st, Save_Str(name_string), CLASS_FUNC, SCLASS_TEXT, eclass, (TY_IDX) idx); 00528 Set_ST_ofst(st,0); 00529 cwh_auxst_add_to_list(&Top_Text,st,FALSE); 00530 00531 } 00532 00533 /* if fei_proc_imp made ST, then ST has a default void return */ 00534 /* which should be replaced with the correct return type/args */ 00535 00536 00537 00538 cwh_stab_set_linenum(st,lineno); 00539 PU_IDX pu_idx = ST_pu(st); 00540 PU& pu = Pu_Table[pu_idx]; 00541 00542 Set_PU_need_unparsed(pu); 00543 00544 if (test_flag(flags, FEI_PROC_RECURSE)) 00545 Set_PU_recursive(pu); 00546 00547 cwh_auxst_alloc_proc_entry(st,num_dum_args, ret_ty); 00548 00549 if (test_flag(flags, FEI_PROC_HASRSLT)) 00550 Set_ST_auxst_has_rslt_tmp(st,TRUE); 00551 00552 if (test_flag(flags, FEI_PROC_ELEMENTAL)) 00553 Set_ST_auxst_is_elemental(st,TRUE); 00554 00555 if (test_flag(flags, FEI_PROC_MODULE)) 00556 Set_ST_is_in_module(st); 00557 00558 if (test_flag(flags, FEI_PROC_ENTRY)) { 00559 00560 Set_ST_auxst_is_altentry(st,TRUE); 00561 cwh_auxst_add_item(Procedure_ST,st,l_ALTENTRY); 00562 00563 } else { 00564 00565 Procedure_ST = st ; 00566 00567 if (test_flag(flags, FEI_PROC_HAS_ALT_ENTRY)) 00568 Set_PU_has_altentry(pu); 00569 } 00570 00571 00572 // cosubroutien or cofunction ---FMZ 00573 if ( coarray_concurrent ) 00574 Set_ST_is_coarray_concurrent(st); 00575 00576 00577 st_for_distribute_temp=NULL; 00578 preg_for_distribute.preg=-1; 00579 00580 entry_point_count++ ; 00581 00582 p = cwh_stab_packet(st, is_ST); 00583 return(cast_to_int(p)); 00584 } 00585 00586 00587 /*=================================================== 00588 * 00589 * fei_proc_imp 00590 * 00591 * Build an ST for an function which is 00592 * referenced in the code. Sometimes this is a TEXT 00593 * symbol created in fei_proc_def, so we go looking 00594 * for these first, before creating an EXTERNAL symbol. 00595 * 00596 * If this is a forward reference, a proc_def for the 00597 * symbol may be seen later, when the ST created here 00598 * gets details filled in. 00599 * 00600 ==================================================== 00601 */ 00602 /*ARGSUSED*/ 00603 INTPTR 00604 fei_proc_imp(INT32 lineno, 00605 char *name_string, 00606 INT32 unused1, 00607 INT32 unused2, 00608 INT32 Sclass_arg, 00609 INT32 Class_arg, 00610 TYPE result_type, 00611 INT64 flags, 00612 INT32 in_interface) 00613 { 00614 ST * st ; 00615 ST * st_local_cp; 00616 STB_pkt *p ; 00617 PROC_CLASS Class; 00618 FUNCTION_SYM sym_class; 00619 TY_IDX ret_cp_ty; 00620 TY_IDX ty_cp; 00621 PU_IDX pu_cp_idx; 00622 00623 INT map = 0; 00624 00625 00626 sym_class = (FUNCTION_SYM) Sclass_arg; 00627 Class = (PROC_CLASS) Class_arg; 00628 00629 st = NULL ; 00630 switch (Class) { 00631 case PDGCS_Proc_Imported: /* external subroutine */ 00632 case PDGCS_Proc_Intern_Ref: 00633 case PDGCS_Proc_SrcIntrin: /*PU is intrinsic function*/ 00634 00635 st = cwh_auxst_find_item(Top_Text,name_string); 00636 00637 if ( st == NULL ) { 00638 00639 ST_EXPORT eclass = EXPORT_PREEMPTIBLE; 00640 00641 if (test_flag(flags,FEI_PROC_OPTIONAL_DIR)) 00642 eclass = EXPORT_OPTIONAL; 00643 00644 // create procedure TY with 0 args. Don't know how many 00645 // there are in a forward ref. 00646 00647 00648 INT32 level = HOST_LEVEL ; 00649 00650 if (Class == PDGCS_Proc_Intern_Ref) 00651 { 00652 level = INTERNAL_LEVEL; 00653 eclass = EXPORT_LOCAL_INTERNAL; 00654 00655 } 00656 00657 if (Class == PDGCS_Proc_SrcIntrin) /* FMZ add for keep intrinsic as call */ 00658 { 00659 level = INTERNAL_LEVEL; 00660 eclass = EXPORT_INTRINSIC; 00661 } 00662 00663 while (map < NUM_INAMEMAP && 00664 (strcmp(Iname_Map[map].oldname,name_string))) 00665 ++map; 00666 00667 if (map < NUM_INAMEMAP ) 00668 st = cwh_stab_mk_fn_0args(Iname_Map[map].newname, 00669 eclass, 00670 level, 00671 cast_to_TY(t_TY(result_type))); 00672 00673 else 00674 st = cwh_stab_mk_fn_0args(name_string, 00675 eclass, 00676 level, 00677 cast_to_TY(t_TY(result_type))); 00678 00679 00680 cwh_auxst_add_to_list(&Top_Text,st,FALSE); 00681 } 00682 break; 00683 00684 default: 00685 break; 00686 } 00687 00688 BOOL input_form_module = (test_flag(flags,FEI_PROC_M_IMPORTED)); 00689 BOOL declared_in_model = (test_flag(flags, FEI_PROC_MODULE) && !input_form_module); 00690 00691 00692 if (Class == PDGCS_Proc_Imported && 00693 !in_interface && 00694 !input_form_module && 00695 !(sym_class == F90_Module)) { 00696 st_local_cp = Copy_ST(st,CURRENT_SYMTAB); 00697 st_local_cp->storage_class = SCLASS_EXTERN; 00698 ret_cp_ty = cast_to_TY(t_TY(result_type)) ; 00699 ty_cp = cwh_types_mk_procedure_TY(ret_cp_ty,0,TRUE,FALSE); 00700 pu_cp_idx = cwh_stab_mk_pu(ty_cp, CURRENT_SYMTAB); 00701 00702 Set_PU_decl_view(pu_cp_idx); /*the extra PU entry for declaration only--Oct */ 00703 Set_PU_need_unparsed(pu_cp_idx); 00704 00705 st_local_cp->u2.type =(TY_IDX)pu_cp_idx ; 00706 Set_ST_ofst(st_local_cp, 0); 00707 00708 if (!declared_in_model) 00709 Set_ST_base(st_local_cp,st); 00710 else Set_ST_is_in_module(st_local_cp); 00711 } 00712 00713 if (sym_class == F90_Module){ 00714 Set_ST_emit_symbol(st); 00715 Set_ST_is_in_module(st); 00716 } 00717 00718 if (test_flag(flags, FEI_PROC_HASRSLT)) 00719 Set_ST_auxst_has_rslt_tmp(st,TRUE) ; 00720 00721 if (test_flag(flags, FEI_PROC_ELEMENTAL)) 00722 Set_ST_auxst_is_elemental(st,TRUE); 00723 00724 p = cwh_stab_packet(st, is_ST); 00725 return(cast_to_int(p)); 00726 } 00727 00728 /*=================================================== 00729 * 00730 * fei_arith_con 00731 * 00732 * Build an ST for a constant, unless an integral 00733 * constant when we pass back a WN. 00734 * 00735 ==================================================== 00736 */ 00737 extern INTPTR 00738 fei_arith_con(TYPE type, SLONG *start) 00739 { 00740 WN * wn; 00741 ST * st; 00742 TY_IDX ty; 00743 TYPE_ID bt; 00744 TCON tcon; 00745 QUAD_TYPE q,q1 ; 00746 float * f ; 00747 double * d ; 00748 STB_pkt * r ; 00749 INT64 iconst; 00750 00751 ty = cast_to_TY(t_TY(type)); 00752 bt = TY_mtype(ty) ; 00753 00754 if (MTYPE_is_integral(bt)) { 00755 00756 /* May need to sign-extend constant */ 00757 if (bt == MTYPE_I8 || bt == MTYPE_U8) { 00758 iconst = *(INT64 *) start; 00759 } else { 00760 iconst = (INT64) * start; 00761 } 00762 if (bt == MTYPE_I1) { 00763 iconst = (iconst << 56) >> 56; 00764 } else if (bt == MTYPE_I2) { 00765 iconst = (iconst << 48) >> 48; 00766 } else if (bt == MTYPE_I4) { 00767 iconst = (iconst << 32) >> 32; 00768 } 00769 00770 wn = WN_CreateIntconst(Intconst_Opcode [op_form [bt]], 00771 iconst) ; 00772 00773 r = cwh_stab_packet(wn,is_WN); 00774 00775 } else if (MTYPE_is_void(bt)) { 00776 00777 wn = WN_CreateIntconst(OPC_U8INTCONST,(INT64) * (UINT32 *)start) ; 00778 r = cwh_stab_packet(wn,is_WN); 00779 00780 } else if (MTYPE_is_float(bt)) { 00781 00782 switch (bt) { 00783 case MTYPE_F4 : 00784 tcon = Host_To_Targ_Float_4(bt,(float) * (float *) start); 00785 break ; 00786 00787 case MTYPE_F8 : 00788 tcon = Host_To_Targ_Float(bt,(double) * (double *) start); 00789 break ; 00790 00791 case MTYPE_FQ: 00792 /* Convert from Cray IEEE format to MIPS format */ 00793 memcpy(&q,start,sizeof (QUAD_TYPE)); 00794 tcon = Host_To_Targ_Quad(q); 00795 break ; 00796 00797 case MTYPE_C4 : 00798 f = (float *) start ; 00799 tcon = Host_To_Targ_Complex_4 ( bt, *f, *(f + 1)); 00800 break ; 00801 00802 case MTYPE_C8 : 00803 d = (double *) start ; 00804 tcon = Host_To_Targ_Complex( bt, *d, *(d + 1)); 00805 break ; 00806 00807 case MTYPE_CQ : 00808 memcpy(&q,start,sizeof (QUAD_TYPE)); 00809 memcpy(&q1,start+4,sizeof (QUAD_TYPE)); 00810 tcon = Host_To_Targ_Complex_Quad (q,q1); 00811 break ; 00812 00813 default: 00814 DevAssert((0),("Odd float constant")); 00815 } 00816 00817 st = New_Const_Sym(Enter_tcon (tcon), ty); 00818 r = cwh_stab_packet(st,is_ST); 00819 00820 } else 00821 DevAssert((0),("Unimplemented constant")); 00822 00823 return (cast_to_int(r)) ; 00824 00825 } 00826 00827 /*=================================================== 00828 * 00829 * fei_pattern_con 00830 * 00831 * Build an ST for an untyped or string constant. 00832 * Strtab is global, assumes any TY global. 00833 * 00834 ==================================================== 00835 */ 00836 /*ARGSUSED*/ 00837 extern INTPTR 00838 fei_pattern_con(TYPE type,char *start,INT64 bitsize) 00839 { 00840 TY_IDX ty ; 00841 ST * st ; 00842 00843 TCON tc; 00844 00845 ty = cast_to_TY(t_TY(type)); 00846 tc = Host_To_Targ_String (MTYPE_STRING,start,TY_size(ty)); 00847 st = Gen_String_Sym (&tc,ty,FALSE); 00848 00849 return(cast_to_int(st)); 00850 00851 } 00852 00853 /*=================================================== 00854 * 00855 * fei_proc_parent 00856 * 00857 * Make the current SYMTAB the parent of an 00858 * internal procedure so Hosted variables can 00859 * be inserted into the host. 00860 * 00861 * For a recursive parent called from the child, it 00862 * may be this is the only time the function name is 00863 * seen, (its fei_proc_imp), so create an ST for 00864 * the parent. 00865 * 00866 ==================================================== 00867 */ 00868 /*ARGSUSED*/ 00869 INTPTR 00870 fei_proc_parent( char *name_string, 00871 INT32 lineno, 00872 INT32 Sym_class_arg, 00873 INT32 unused, 00874 INT32 num_dum_args, 00875 INT32 parent_stx, 00876 INT32 first_st_idx, 00877 INT32 aux_idx, 00878 TYPE result_type, 00879 INTPTR st_idx, 00880 INT64 flags ) 00881 { 00882 INT32 level; 00883 FUNCTION_SYM sym_class; 00884 00885 sym_class = (FUNCTION_SYM) Sym_class_arg; 00886 00887 st_idx = fei_proc_imp(lineno, 00888 name_string, 00889 0, 00890 0, 00891 sym_class, 00892 PDGCS_Proc_Imported, 00893 result_type, 00894 flags, 00895 0); 00896 00897 level = PU_lexical_level(Get_Current_PU()) - 1; 00898 00899 if (level != GLOBAL_SYMTAB) { 00900 STB_pkt * p ; 00901 00902 Current_scope = level; 00903 00904 // if this is a forward ref, the scope table ST hasn't been set. 00905 // set it here, so can use Get_Current_PU on host procedures 00906 // (say after fei_proc_parent has popped symtabs). 00907 00908 p = cast_to_STB(st_idx); 00909 Scope_tab[level].st = cast_to_ST(p->item); 00910 } 00911 00912 if (test_flag(flags, FEI_PROC_HAS_ALT_ENTRY)) 00913 Set_PU_has_altentry(Get_Current_PU ()); 00914 00915 return(st_idx); 00916 } 00917 00918 /*=================================================== 00919 * 00920 * fei_object 00921 * 00922 * Build an ST for a symbol eg: a variable. The 00923 * default behaviour is to build an ST using the type 00924 * info and storage_idx created earlier. But there 00925 * are many tweaks for edge cases. 00926 * 00927 * The FE considers hosted and internal symbol tables 00928 * distinct. WHIRL doesn't. Nested procedures appear 00929 * before their host, so if a reference to a hosted 00930 * thing appears, it's allocated in the host's 00931 * symbol table. Subsequent appearances lookup the 00932 * host object. If the nested procedure references 00933 * the host function result or dummy argument, then 00934 * a call to fei_proc_parent resets the current symbol 00935 * table and the argument list of the host is processed. 00936 * 00937 * 00938 ==================================================== 00939 */ 00940 /*ARGSUSED*/ 00941 INTPTR 00942 fei_object(char * name_string, 00943 TYPE type, 00944 INT64 flag_bits, 00945 INT32 Sym_class_arg, 00946 INTPTR storage_idx, 00947 INT32 arg_num, 00948 INTPTR ptr_st_idx, 00949 INT64 offset, 00950 INT32 arg_intent, 00951 INT64 size, 00952 INT32 type_aux, 00953 INT32 alignment, 00954 INT32 distr_idx, 00955 INT32 node_1, 00956 INT32 node_2, 00957 INT32 lineno, 00958 INTPTR modst_idx) 00959 { 00960 TY_IDX ty ; 00961 TY_IDX tr_idx; 00962 ST * st ; 00963 ST * st1; 00964 ST * base_st ; 00965 00966 BOOL hosted ; 00967 BOOL eq ; 00968 BOOL in_common ; 00969 BOOL derived_type_or_imported_var=FALSE; 00970 INT64 off ; 00971 SYMTAB_IDX st_level; 00972 00973 STB_pkt *p; 00974 STB_pkt *o; 00975 STB_pkt *b; 00976 STB_pkt *modp; 00977 00978 00979 OBJECT_SYM sym_class; 00980 00981 sym_class = (OBJECT_SYM) Sym_class_arg; 00982 00983 ty = cast_to_TY(t_TY(type)); 00984 p = cast_to_STB(storage_idx); 00985 /* need to seperate two cases:interface & contained pu */ 00986 00987 if (!interface_pu) 00988 hosted = (sym_class == Hosted_Dummy_Procedure) || 00989 (sym_class == Hosted_Dummy_Arg ) || 00990 (sym_class == Hosted_Compiler_Temp) || 00991 (sym_class == Hosted_User_Variable ) || 00992 (sym_class == CRI_Pointee && 00993 (test_flag(flag_bits,FEI_OBJECT_INNER_REF) || 00994 test_flag(flag_bits,FEI_OBJECT_INNER_DEF))) ; 00995 else 00996 hosted = FALSE; 00997 00998 00999 /* ignore hosted args w/o inner ref/defs because don't */ 01000 /* want duplicates in symbol table for debug info (only */ 01001 /* do lookup if inner ref/def, for speed). However flags */ 01002 /* on compiler temps not always set, and Namelist lists */ 01003 /* are built even if the ref/def isn't set on a varbl */ 01004 01005 01006 if (hosted && 01007 sym_class != Hosted_Compiler_Temp && 01008 !test_flag(flag_bits,FEI_OBJECT_INNER_REF) && 01009 !test_flag(flag_bits,FEI_OBJECT_INNER_DEF) && 01010 !test_flag(flag_bits,FEI_OBJECT_NAMELIST_ITEM)) 01011 return (0); 01012 01013 /* ignore stmt fn dummy arg - not used */ 01014 01015 if (test_flag(flag_bits,FEI_OBJECT_SF_DARG)) 01016 return(0); 01017 01018 01019 /* is this a reference to a hosted object within a nested */ 01020 /* routine? If so just return the hosted object */ 01021 01022 01023 if ((test_flag(flag_bits,FEI_OBJECT_INNER_REF)) || 01024 (test_flag(flag_bits,FEI_OBJECT_INNER_DEF)) || 01025 (sym_class == Hosted_Compiler_Temp)) { 01026 01027 ST * sl = cwh_stab_earlier_hosted(name_string); 01028 if (sl != NULL) { 01029 01030 cwh_stab_adjust_base_name(sl); 01031 01032 /* if hosted dummy ref appeared within nested procedure */ 01033 /* add to dummy list of host, ie: what we're processing now */ 01034 /* It may be a struct-by-value so don't add to arg list,but */ 01035 /* need correct count & TY in internal data structures */ 01036 01037 if (sym_class == Dummy_Arg || sym_class == Dummy_Procedure) { 01038 01039 if (ST_is_return_var(sl) && TY_kind(ST_type(sl)) != KIND_POINTER) 01040 cwh_auxst_patch_proc(ST_type(sl)); 01041 01042 else { 01043 01044 BOOL rtmp = test_flag(flag_bits,FEI_OBJECT_RESULT_TEMP); 01045 ST * dmst = sl; 01046 01047 /* if CQ fn entry point - add return address to arg list */ 01048 01049 if (rtmp && Altaddress_ST != NULL) 01050 dmst = Altaddress_ST ; 01051 01052 cwh_auxst_add_dummy(dmst,rtmp); 01053 } 01054 } 01055 01056 st1 = Scope_tab[CURRENT_SYMTAB].st; 01057 if (ST_is_in_module(st1)) //current PU is moudel 01058 Set_ST_base(sl,st1); 01059 o = cwh_stab_packet(sl,is_ST); 01060 return(cast_to_int(o)); 01061 } 01062 } 01063 01064 01065 /* offsets are set, but ignored for host variables, for */ 01066 /* locals, they don't appear. For common items we need them */ 01067 01068 off = 0 ; 01069 if (test_flag(flag_bits,FEI_OBJECT_OFF_ASSIGNED)) { 01070 01071 off = bit_to_byte(offset); 01072 01073 if (p->form == is_SCLASS) 01074 if ((cast_to_SCLASS((long)p->item) != SCLASS_COMMON) && 01075 (cast_to_SCLASS((long)p->item) != SCLASS_MODULE) && 01076 (cast_to_SCLASS((long)p->item) != SCLASS_DGLOBAL)) 01077 off = 0 ; 01078 } 01079 01080 /* is this a reference to an item in a COMMON which we've already */ 01081 /* seen? IF so find the ST being used for the element of the common */ 01082 01083 in_common = ((p->form == is_ST) && (IS_COMMON(cast_to_ST(p->item)))) || 01084 ((sym_class == CRI_Pointee) && IS_COMMON(cast_to_ST((cast_to_STB(ptr_st_idx))->item))); 01085 01086 if (in_common) { 01087 01088 /* if it's a pointee in COMMON, its base is on the l_COMLIST */ 01089 /* and the ptr/pointee are associated via the auxst */ 01090 01091 if (sym_class == CRI_Pointee) { 01092 01093 STB_pkt *bb = cast_to_STB(ptr_st_idx); 01094 DevAssert((bb->form == is_ST),("odd pointer base")); 01095 01096 ST * ptr = cast_to_ST(bb->item); 01097 DevAssert((ptr),("odd pointee")); 01098 01099 st = cwh_auxst_cri_pointee(ST_base(ptr),0); 01100 } else { 01101 st = cwh_stab_seen_common_element(cast_to_ST(p->item),off,name_string); 01102 } 01103 01104 if (st) { 01105 if (test_flag(flag_bits,FEI_OBJECT_NOT_PT_TO_UNIQUE_MEM)) { 01106 Clear_ST_pt_to_unique_mem(st); 01107 } 01108 o = cwh_stab_packet(st,is_ST); 01109 01110 if (decl_distribute_pragmas) 01111 cwh_stab_distrib_pragmas(st) ; 01112 return(cast_to_int(o)); 01113 } 01114 } 01115 01116 /* 01117 * keep derived types and module variables have single 01118 * global ST entries ---FMZ 01119 * 01120 */ 01121 01122 derived_type_or_imported_var = modst_idx ? TRUE: FALSE; 01123 01124 if (derived_type_or_imported_var && !in_common) { 01125 modp = cast_to_STB(modst_idx); 01126 st = cwh_stab_seen_derived_type_or_imported_var(cast_to_ST(modp->item) 01127 ,name_string); 01128 if (st) { 01129 o = cwh_stab_packet(st,is_ST); 01130 return(cast_to_int(o)); 01131 } 01132 } 01133 01134 /* figure out which symbol table this object goes in */ 01135 /* ie: is it in COMMON somehow perhpas via CRI_Pointer as base */ 01136 01137 if (in_common || (sym_class == Name)|| 01138 (test_flag(flag_bits, FEI_OBJECT_IN_MODULE))) { 01139 01140 /* add test_flag(flag_bits, FEI_OBJECT_IN_MODULE) to keep the initial * 01141 * variables in module still to be in global ST table --fzhao */ 01142 01143 st_level = GLOBAL_SYMTAB ; 01144 01145 } else { 01146 01147 st_level = CURRENT_SYMTAB; 01148 if (hosted && IN_NESTED_PU) 01149 st_level = HOST_LEVEL ; 01150 } 01151 01152 if (test_flag(flag_bits, FEI_OBJECT_IN_MODULE)) 01153 st_level = GLOBAL_SYMTAB ; 01154 01155 st = New_ST(st_level); 01156 cwh_auxst_clear(st); 01157 01158 ST_Init(st, 01159 Save_Str(name_string), 01160 object_map[sym_class], 01161 cast_to_SCLASS((long)p->item), 01162 EXPORT_LOCAL, 01163 ty); 01164 if (test_flag(flag_bits,FEI_OBJECT_IN_COMMON)) 01165 if (sym_class == Name) { 01166 Set_ST_is_not_used (st); 01167 } 01168 01169 if (test_flag(flag_bits, FEI_OBJECT_IN_MODULE) ) { 01170 if (!PU_is_nested_func(Pu_Table[ST_pu(Scope_tab[CURRENT_SYMTAB].st)])) { 01171 st1 = Scope_tab[CURRENT_SYMTAB].st; 01172 cwh_auxst_add_item(st1,st,l_TYMDLIST) ; 01173 } else st1 = st; 01174 01175 if (hosted) 01176 cwh_stab_enter_hosted(st); 01177 Set_ST_base(st,st1); 01178 01179 } 01180 01181 Set_ST_ofst(st, off); 01182 01183 cwh_stab_set_linenum(st,lineno); 01184 01185 /* general setup above, special tweaks below here */ 01186 01187 /* ty is the function return TY. Make it */ 01188 /* into ptr TY of FUNCTION returning ty */ 01189 01190 if ((sym_class == Dummy_Procedure) || 01191 (sym_class == Hosted_Dummy_Procedure)) { 01192 01193 Set_ST_is_value_parm(st); 01194 ty = cwh_types_mk_procedure_TY (ty,0,TRUE,hosted); 01195 01196 Set_ST_type(st, cwh_types_mk_pointer_TY(ty,hosted)); 01197 } 01198 01199 /* is this a compiler-generated temp? Mark if so. The FE sets the */ 01200 /* flag on static temps too, but the symbol table objects to */ 01201 /* {F,P}STATIC, DGLOBALS etc. */ 01202 01203 if ((sym_class == Compiler_Temp) || 01204 (sym_class == Hosted_Compiler_Temp)) { 01205 Set_ST_auxst_is_tmp(st,TRUE); 01206 01207 if (ST_sclass(st) == SCLASS_AUTO || 01208 ST_sclass(st) == SCLASS_FORMAL || 01209 ST_sclass(st) == SCLASS_FORMAL_REF) 01210 Set_ST_is_temp_var(st); 01211 } 01212 01213 if (test_flag(flag_bits,FEI_OBJECT_PARAMETER)) 01214 Set_ST_is_parameter(st); 01215 01216 /* F90 pointers and assumed-shape dummies are non-contiguous */ 01217 if (test_flag(flag_bits,FEI_OBJECT_PRIVATE)) 01218 Set_ST_is_private(st); 01219 01220 if (test_flag(flag_bits,FEI_OBJECT_ASSUMD_SHAPE) || 01221 test_flag(flag_bits,FEI_OBJECT_DV_IS_PTR)) { 01222 Set_ST_auxst_is_non_contiguous(st, TRUE); 01223 Set_TY_is_f90_assumed_shape(ST_type(st)); 01224 } 01225 01226 if (test_flag(flag_bits, FEI_OBJECT_DEFERRED_SHAPE)) 01227 Set_TY_is_f90_deferred_shape(ST_type(st)); 01228 01229 01230 if (test_flag(flag_bits, FEI_OBJECT_ASSUMED_SIZE)) { 01231 Set_ST_auxst_is_assumed_size(st, TRUE) ; 01232 Set_TY_is_f90_assumed_size(ST_type(st)) ; } 01233 01234 if (test_flag(flag_bits, FEI_OBJECT_IN_MODULE)) 01235 Set_ST_is_in_module(st); 01236 if (test_flag(flag_bits, FEI_OBJECT_EXTERNAL)) 01237 Set_ST_is_external(st); 01238 01239 01240 if (test_flag(flag_bits,FEI_OBJECT_READ_ONLY)) { 01241 Set_ST_is_const_var(st); 01242 } 01243 01244 /* if dummy, name is the address. CQ, array, character results */ 01245 /* are addresses. Struct temp addresses should be values if 16B */ 01246 /* or less and are converted here rather than FE */ 01247 01248 if (ST_sclass(st) == SCLASS_FORMAL) { 01249 BOOL formal = TRUE; 01250 01251 if (test_flag(flag_bits,FEI_OBJECT_RESULT_TEMP)) { 01252 01253 /* does ABI require fn result in regs - see cwh_defines.h */ 01254 01255 # if 0 01256 if (STRUCT_BY_VALUE(ty)) { 01257 01258 Set_ST_sclass(st, SCLASS_AUTO); 01259 01260 if (! hosted) 01261 cwh_auxst_patch_proc(ty); 01262 01263 formal = FALSE; 01264 sym_class = Function_Rslt ; 01265 p->form = is_UNDEF ; 01266 01267 } else 01268 # endif 01269 01270 Set_ST_auxst_is_rslt_tmp(st, TRUE); 01271 01272 01273 if (TY_kind(ty) != KIND_STRUCT) { 01274 01275 /* character/array result varbl address or for CQ results, st will */ 01276 /* be made so below, Structs will be FORMAL_REFS so no pointer */ 01277 01278 Set_ST_type(st, cwh_types_mk_pointer_TY(ty,hosted)); 01279 Set_ST_is_value_parm(st); 01280 } 01281 01282 if (TY_kind(ty) != KIND_SCALAR) { 01283 01284 /* seen alt entry temp already? Use it. This one is same TY_IDX */ 01285 /* ie: ptr to dtype, character etc. Only scalar intrinsic entries */ 01286 /* may differ on result type. Alttemp_ST is for results of entry */ 01287 /* points so applies only to host (level) procedure result varbls */ 01288 01289 if (ST_level(st) == HOST_LEVEL) { 01290 // if (Alttemp_ST != NULL) 01291 // st = Alttemp_ST ; 01292 01293 // Alttemp_ST = st ; 01294 } 01295 01296 } else if (TY_mtype(ty) == MTYPE_CQ) { 01297 01298 /* CQ scalar result. If alt entry, make local temp */ 01299 /* & preserve ST as result address. Maybe hosted.. */ 01300 /* but fei_proc_parent called so in host temporarily*/ 01301 01302 if (PU_has_altentry(Get_Current_PU())) { 01303 01304 ST * rt = st ; 01305 01306 /* create a stack temp for result var and */ 01307 /* an equivalence group for entry pts */ 01308 01309 st = cwh_stab_altentry_temp(ST_name(st),hosted); 01310 01311 Set_ST_name(rt, Save_Str(".resaddr.")); 01312 01313 if (Altaddress_ST == NULL) 01314 Altaddress_ST = rt ; 01315 01316 if (hosted) 01317 Set_ST_has_nested_ref(Altaddress_ST); 01318 else 01319 cwh_auxst_add_dummy(Altaddress_ST,TRUE); 01320 01321 01322 cwh_auxst_add_item(ST_base(st),st,l_EQVLIST); 01323 Set_ST_is_equivalenced(st); 01324 01325 sym_class = Function_Rslt ; 01326 p->form = is_UNDEF ; 01327 formal = FALSE; 01328 } 01329 } 01330 01331 } else { 01332 if (test_flag(flag_bits,FEI_OBJECT_OPTIONAL)) 01333 Set_ST_is_optional_argument(st); 01334 01335 switch (arg_intent) { 01336 case 1: 01337 Set_ST_is_intent_in_argument(st); 01338 break; 01339 01340 case 2: 01341 Set_ST_is_intent_out_argument(st); 01342 break; 01343 default: 01344 break; 01345 01346 } /*switch*/ 01347 } 01348 01349 if (formal) 01350 cwh_stab_formal_ref(st,hosted); 01351 01352 } 01353 01354 /* allocatable & assumed shape cannot be aliases, unless a pointer TARGET */ 01355 01356 if (test_flag(flag_bits,FEI_OBJECT_ALLOCATE) || 01357 test_flag(flag_bits,FEI_OBJECT_ASSUMD_SHAPE)) { 01358 01359 if (!test_flag(flag_bits,FEI_OBJECT_TARGET) && 01360 !test_flag(flag_bits,FEI_OBJECT_NOT_PT_TO_UNIQUE_MEM)) { 01361 Set_ST_pt_to_unique_mem(st); 01362 } 01363 } 01364 01365 01366 /* If automatic, create symbol, and pointer as */ 01367 /* base. Offset is ST of address temp (base). */ 01368 /* For Cray pointers, the base comes from ptr_st_idx. */ 01369 /* If this is a Host Pointee, the only way to figure */ 01370 /* it is to look at the base and use its SYMTAB */ 01371 01372 01373 if (p->form == is_SCLASS && (cast_to_SCLASS((long)p->item) == SCLASS_BASED)) { 01374 01375 if (sym_class == CRI_Pointee) { 01376 b = cast_to_STB(ptr_st_idx); 01377 base_st = cast_to_ST(b->item); 01378 cwh_auxst_cri_pointee(base_st, st); 01379 01380 } else { 01381 b = cast_to_STB((UINTPS) offset); 01382 base_st = cast_to_ST(b->item); 01383 } 01384 01385 Set_ST_base(st, base_st); 01386 Set_ST_ofst(st, 0); 01387 Set_ST_sclass(st, ST_sclass(base_st)); 01388 01389 Set_ST_auxst_is_auto_or_cpointer(st, TRUE); 01390 01391 if (test_flag(flag_bits, FEI_OBJECT_TARGET)) 01392 Set_ST_is_f90_target(base_st) ; 01393 else if (sym_class != CRI_Pointee && 01394 !test_flag(flag_bits,FEI_OBJECT_NOT_PT_TO_UNIQUE_MEM)) 01395 Set_ST_pt_to_unique_mem(base_st); 01396 01397 Set_ST_type(base_st, cwh_types_mk_pointer_TY(ty,hosted)); 01398 01399 /* make base name into p_<based_varbl> for intelligibility & w2f output*/ 01400 01401 if (!hosted) 01402 cwh_stab_adjust_base_name(st); 01403 } 01404 01405 01406 01407 /* Is part of some earlier base, eg: common or equivalence */ 01408 01409 eq = test_flag(flag_bits,FEI_OBJECT_EQUIV) ; 01410 01411 if (p->form == is_ST) { 01412 Set_ST_sclass(st, ST_sclass(cast_to_ST(p->item))); 01413 01414 if (!test_flag(flag_bits,FEI_OBJECT_IN_COMMON)&& ( 01415 ST_sclass(cast_to_ST(p->item))==SCLASS_COMMON || 01416 ST_sclass(cast_to_ST(p->item))==SCLASS_MODULE )) 01417 Set_ST_sclass(st,SCLASS_AUTO); 01418 01419 Set_ST_base(st, cast_to_ST(p->item)); 01420 01421 // this above stmt set base_idx for variables in common block 01422 01423 01424 /* adding rename of use'd varbl in later PU to */ 01425 /* module data initalized earlier? */ 01426 01427 if (ST_sclass(st) == SCLASS_DGLOBAL) 01428 Set_ST_is_initialized(st); 01429 01430 if (eq) 01431 Set_ST_is_equivalenced(st); 01432 } 01433 01434 /* record the hosted object, so other routines use same ST */ 01435 01436 if (hosted) { 01437 cwh_stab_enter_hosted(st); 01438 01439 if (IS_AUTO_OR_FORMAL(st)) 01440 Set_ST_has_nested_ref(st); 01441 01442 } 01443 01444 /* Set function result flags - May be function result shared */ 01445 /* between entry points, when it has an EQUIV base */ 01446 /* If there is an integer result the TY size is at least I8 */ 01447 01448 if ((sym_class == Function_Rslt) || 01449 (hosted && test_flag(flag_bits,FEI_OBJECT_RESULT_TEMP))) { 01450 01451 if (Has_Base_Block(st)) { 01452 01453 TY_IDX temp_ty_idx = ST_type (ST_base(st)); 01454 Set_TY_align (temp_ty_idx, 8); 01455 Set_ST_type (ST_base(st), temp_ty_idx); 01456 Set_ST_is_return_var(ST_base(st)); 01457 cwh_stab_altres_offset(st,hosted); 01458 01459 } else if (ST_sclass(st) != SCLASS_FORMAL_REF) 01460 Set_ST_is_return_var(st); 01461 } 01462 01463 /* Non hosted, formal to be added to fn's list of dummies. */ 01464 /* Maybe was found in 'earlier hosted' list though if it */ 01465 /* was a Host dummy used within internal routine */ 01466 01467 if (IS_FORMAL(st)) { 01468 01469 if (! hosted ) 01470 cwh_auxst_add_dummy(st,test_flag(flag_bits,FEI_OBJECT_RESULT_TEMP)); 01471 } 01472 01473 /* Add COMMON or EQUIVALENCEd item to internal lists */ 01474 01475 if (Has_Base_Block(st)) { 01476 01477 if (IS_COMMON(ST_base(st))) { 01478 if (sym_class != CRI_Pointee) 01479 cwh_auxst_add_item(ST_base(st),st,l_COMLIST) ; 01480 01481 } else if (eq) { 01482 cwh_auxst_add_item(ST_base(st),st,l_EQVLIST); 01483 } 01484 } 01485 01486 /* if a dope vector for a pointer, set flag & check type is f90 pointer */ 01487 01488 if (test_flag(flag_bits, FEI_OBJECT_DV_IS_PTR)) { 01489 Set_ST_auxst_is_f90_pointer(st, TRUE); 01490 tr_idx = Make_F90_Pointer_Type(ty); 01491 Set_TY_is_f90_pointer(tr_idx); 01492 Set_ST_type(st,tr_idx); 01493 Set_ST_is_my_pointer(st) ; 01494 01495 if (ST_sclass(st) == SCLASS_FORMAL) { 01496 DevAssert(TY_is_f90_pointer(TY_pointed(ST_type(st))),(" missing pf90p")); 01497 } else { 01498 DevAssert(TY_is_f90_pointer(ST_type(st)),(" missing f90p")); 01499 } 01500 } 01501 01502 if (test_flag(flag_bits, FEI_OBJECT_ALLOCATE)) { 01503 Set_ST_auxst_is_allocatable(st, TRUE) ; 01504 Set_ST_is_allocatable(st) ; } 01505 01506 if (test_flag(flag_bits,FEI_OBJECT_RESULT_TEMP)) 01507 Set_ST_is_return_var(st); 01508 01509 if (test_flag(flag_bits, FEI_OBJECT_ASSUMD_SHAPE)) { 01510 Set_ST_auxst_is_assumed_shape(st, TRUE) ; 01511 Set_TY_is_f90_assumed_shape(ST_type(st)); } 01512 01513 if (test_flag(flag_bits, FEI_OBJECT_DEFERRED_SHAPE)) 01514 Set_TY_is_f90_deferred_shape(ST_type(st)); 01515 01516 if (test_flag(flag_bits, FEI_OBJECT_IN_MODULE)) 01517 Set_ST_is_in_module(st); 01518 if (test_flag(flag_bits, FEI_OBJECT_EXTERNAL)) 01519 Set_ST_is_external(st); 01520 01521 if (modst_idx) { /* this variable imported by use stmt */ 01522 modp = cast_to_STB(modst_idx); 01523 Set_ST_base(st, cast_to_ST(modp->item)); 01524 cwh_auxst_add_item(ST_base(st),st,l_TYMDLIST) ; 01525 } 01526 01527 if (test_flag(flag_bits, FEI_OBJECT_ASSUMED_SIZE)) { 01528 Set_ST_auxst_is_assumed_size(st, TRUE) ; 01529 Set_TY_is_f90_assumed_size(ST_type(st)) ; } 01530 01531 01532 if (test_flag(flag_bits, FEI_OBJECT_TARGET)) 01533 Set_ST_is_f90_target(st) ; 01534 01535 if (test_flag(flag_bits, FEI_OBJECT_ACTUAL_ARG)) 01536 cwh_expr_set_flags(st,f_T_PASSED); 01537 01538 /* for distributed arrays, put the ST into the */ 01539 /* distribute pragmas and write out the pragmas. */ 01540 01541 if (decl_distribute_pragmas) 01542 cwh_stab_distrib_pragmas(st) ; 01543 01544 if (!Has_Base_Block(st)) 01545 DevAssert((ST_ofst(st) == 0),("Offset?")); 01546 01547 o = cwh_stab_packet(st,is_ST); 01548 return(cast_to_int(o)); 01549 } 01550 01551 /*================================================== 01552 * Use stmt rename-only list 01553 * 01554 *================================================= 01555 */ 01556 01557 void 01558 fei_rename_list(char * name_string) 01559 { 01560 ST *st; 01561 st = New_ST(CURRENT_SYMTAB); 01562 ST_Init(st, 01563 Save_Str(name_string), 01564 CLASS_NAME, 01565 SCLASS_UNKNOWN, 01566 EXPORT_LOCAL, 01567 (TY_IDX)0); 01568 cwh_stk_push(st,ST_item); 01569 01570 } 01571 01572 /*=================================================== 01573 * 01574 * fei_seg 01575 * 01576 * Given a description of a storage block, look 01577 * at the segment and generate an SCLASS to return. 01578 * The SCLASS will be handed to fei_new_object and the like. 01579 * 01580 * If a COMMON name, make an ST for it and return 01581 * that. Elements of the Common will be added to the 01582 * Common's AUXST. FE_Partial_Split is default, if 01583 * Full Split required it's done later. 01584 * 01585 * If an equivalence base, then make the base ST here 01586 * as we lose the segment information. It's used 01587 * when a based object appears in fei_object. 01588 * 01589 ==================================================== 01590 */ 01591 /*ARGSUSED*/ 01592 INTPTR 01593 fei_seg (char * name_string, 01594 INT32 Seg_type_arg, 01595 INT32 owner, 01596 INT32 parent, 01597 INT32 aux_index, 01598 INT32 flag_bits, 01599 INT32 nest_level, 01600 INT64 block_length ) 01601 { 01602 INT32 rt ; 01603 ST *st ; 01604 ST *st1; 01605 STB_pkt *p ; 01606 SEGMENT_TYPE seg_type; 01607 TY_IDX ty; 01608 01609 seg_type = (SEGMENT_TYPE) Seg_type_arg; 01610 01611 if ((seg_type == Seg_Common ) ) { 01612 01613 BOOL is_duplicate = test_flag(flag_bits,FEI_SEG_DUPLICATE); 01614 01615 st = cwh_stab_common_ST(name_string, block_length,0); 01616 01617 if (test_flag(flag_bits,FEI_SEG_THREADPRIVATE)) { 01618 Set_ST_is_thread_private(st); 01619 Set_ST_not_gprel(st); 01620 } 01621 01622 if (test_flag(flag_bits,FEI_SEG_MODULE)) 01623 Set_ST_auxst_is_module_data(st,TRUE); 01624 01625 if (test_flag(flag_bits,FEI_SEG_EXTERNAL)) 01626 Set_ST_is_external(st); 01627 01628 cwh_auxst_add_to_list(&Commons_Already_Seen,st,FALSE); 01629 01630 ty = ST_type(st); 01631 01632 if (test_flag(flag_bits,FEI_SEG_VOLATILE)) 01633 Set_TY_is_volatile(ty); 01634 01635 #if 0 01636 else { /* found common from earlier PU. Check?/set flags */ 01637 01638 if (test_flag(flag_bits,FEI_SEG_THREADPRIVATE)) { 01639 Set_ST_is_thread_private(st); 01640 Set_ST_not_gprel(st); 01641 } 01642 } 01643 #endif 01644 01645 /* add to list of COMMONs requiring DST info */ 01646 01647 cwh_auxst_add_item(Procedure_ST,st,l_DST_COMLIST); 01648 01649 p = cwh_stab_packet(st,is_ST); 01650 01651 } else if (test_flag(flag_bits,FEI_SEG_EQUIVALENCED)) { 01652 01653 /* if saw hosted equiv from internal procedure, use that */ 01654 st = cwh_stab_earlier_hosted(name_string); 01655 if (st == NULL) { 01656 SYMTAB_IDX level = CURRENT_SYMTAB; 01657 01658 if (seg_type == Seg_Non_Local_Stack) 01659 level = HOST_LEVEL ; 01660 01661 st = New_ST(level); 01662 cwh_auxst_clear(st); 01663 ST_Init(st, Save_Str(name_string), CLASS_VAR, SCLASS_AUTO, EXPORT_LOCAL,0); 01664 01665 if (test_flag(flag_bits,FEI_SEG_MODULE)) //June 01666 st1 = Scope_tab[CURRENT_SYMTAB].st; 01667 else st1 = st; 01668 01669 Set_ST_base(st, st1); 01670 01671 Set_ST_ofst(st, 0); 01672 01673 if (test_flag(flag_bits,FEI_SEG_SAVED) || (seg_type == Seg_Static_Local)) 01674 Set_ST_sclass(st, SCLASS_PSTATIC); 01675 else 01676 Set_ST_is_temp_var(st); 01677 01678 if (seg_type == Seg_Non_Local_Stack) { 01679 cwh_stab_enter_hosted(st); 01680 Set_ST_has_nested_ref(st); 01681 } 01682 01683 Set_ST_type(st, cwh_types_mk_equiv_TY(block_length)); 01684 01685 if (test_flag(flag_bits,FEI_SEG_MODULE)){ 01686 Set_ST_auxst_is_module_data(st,TRUE); 01687 Set_ST_is_in_module(st); 01688 } 01689 01690 if (test_flag(flag_bits,FEI_SEG_EXTERNAL)) 01691 Set_ST_is_external(st); 01692 cwh_stab_to_list_of_equivs(st,seg_type == Seg_Non_Local_Stack); 01693 } 01694 if (test_flag(flag_bits,FEI_SEG_EXTERNAL)){ 01695 Set_ST_is_external(st); 01696 } 01697 01698 p = cwh_stab_packet(st,is_ST); 01699 01700 } else { /* get SCLASS */ 01701 rt = cast_to_int(segment_map[seg_type]); 01702 p = cwh_stab_packet(cast_to_void(rt),is_SCLASS); 01703 } 01704 01705 return (cast_to_int(p)); 01706 } 01707 01708 01709 /*=================================================== 01710 * 01711 * fei_name 01712 * 01713 * Introduces a new name, but often an alternative 01714 * for one we have seen already. So far, only dummies 01715 * in entry points that are the same name as a dummy 01716 * in the procedure header are of interest. They have 01717 * not been through fei_object for this entry point 01718 * so didn't get stuck onto the dummy list... 01719 * 01720 * Lists of Namelist items are built up here, then 01721 * associated with a Namelist name in fei_namelist. 01722 * 01723 ==================================================== 01724 */ 01725 /*ARGSUSED*/ 01726 INTPTR 01727 fei_name (char *name_string, 01728 INT32 st_grp, 01729 INTPTR st_idx, 01730 INT32 prev_idx, 01731 INT32 idx ) 01732 { 01733 ST * st; 01734 STB_pkt *p; 01735 STB_pkt *r; 01736 01737 r = NULL ; 01738 01739 switch ((SYM_GROUP)st_grp) { 01740 case Sym_Namelist: 01741 01742 if (prev_idx == 0) 01743 Namelist = NULL; 01744 01745 p = cast_to_STB(st_idx); 01746 DevAssert((p->form == is_ST),(" name item??")); 01747 01748 st = cast_to_ST(p->item); 01749 (void) cwh_auxst_add_to_list(&Namelist,st,FALSE) ; 01750 r = cwh_stab_packet(cast_to_void(Namelist),is_LIST); 01751 break ; 01752 01753 case Sym_Object: 01754 01755 if (st_idx != 0){ 01756 01757 if (entry_point_count > 1 ) { 01758 01759 p = cast_to_STB(st_idx); 01760 01761 if (p->form == is_ST) { 01762 st = cast_to_ST(p->item) ; 01763 01764 if (IS_FORMAL(st) ) { 01765 if (!cwh_auxst_find_dummy(st)) 01766 cwh_auxst_add_dummy(st,FALSE); 01767 } 01768 } 01769 } 01770 } else { 01771 /* Just return a pointer to a duplicate of the name string */ 01772 cwh_mkdepend_add_name(idx, name_string); 01773 } 01774 break; 01775 01776 case Sym_Null: 01777 cwh_mkdepend_add_name(idx, name_string); 01778 break; 01779 01780 default: 01781 break ; 01782 } 01783 return(cast_to_int(r)); 01784 } 01785 /*=================================================== 01786 * 01787 * fei_namelist 01788 * 01789 * Introduces a namelist name, and the associated 01790 * list of components (idx). Put them in the 01791 * symbol table. 01792 * 01793 ==================================================== 01794 */ 01795 /*ARGSUSED*/ 01796 INTPTR 01797 fei_namelist(char * name_string, 01798 INT32 nitems, 01799 INTPTR idx, 01800 INT32 in_model ) 01801 { 01802 ST * st; 01803 TY_IDX ty; 01804 STB_pkt *p; 01805 STB_pkt *l; 01806 WN * wn; 01807 WN * wn1; 01808 OPCODE opc; 01809 WN * block; 01810 ITEM *element; 01811 int i = 0; 01812 01813 ty = cwh_types_mk_namelist_TY(nitems); 01814 if (in_model){ 01815 st = New_ST(GLOBAL_SYMTAB); 01816 Set_ST_is_in_module(st); 01817 } 01818 else 01819 st = New_ST(CURRENT_SYMTAB);// here,if in module then should be 01820 //GLOBAL_SYMTAB 01821 cwh_auxst_clear(st); 01822 ST_Init(st, Save_Str(name_string), CLASS_VAR, SCLASS_AUTO, EXPORT_LOCAL, ty); 01823 Set_ST_ofst(st, 0); 01824 01825 p = cwh_stab_packet(cast_to_void(st),is_ST) ; 01826 01827 if (in_model >2) 01828 Set_ST_is_external(st); 01829 01830 l = cast_to_STB(idx); 01831 DevAssert((l->form == is_LIST),("Nm list??")); 01832 cwh_auxst_add_list(st, (LIST *) l->item, l_NAMELIST); 01833 01834 opc = OPCODE_make_op(OPR_NAMELIST,MTYPE_V,MTYPE_V); 01835 wn = WN_Create(opc,nitems); 01836 WN_st_idx(wn) = ST_st_idx(st); 01837 element = NULL; 01838 // add kids 01839 while ((element = cwh_auxst_next_element( 01840 st,element,l_NAMELIST)) != NULL ) { 01841 wn1 = WN_Create(OPC_IDNAME,0); 01842 01843 st = I_element(element); 01844 WN_st_idx(wn1) = ST_st_idx(st); 01845 WN_kid(wn,i) = wn1; 01846 i++; 01847 // printf("namelist %s\n",ST_name(st)); 01848 01849 } 01850 cwh_block_append_given_id(wn,First_Block,FALSE); 01851 01852 return (cast_to_int(p)); 01853 } 01854 01855 /*=================================================== 01856 * 01857 * fei_label 01858 * 01859 * Introduces a new label. Give it an ST and return. 01860 * Internal labels are named in the FFE, but the 01861 * name is ignored here. 01862 * 01863 * Symtab_last label is incremented for internal labels 01864 * in Gen_Label, but not for others. Numbers should be 01865 * unique for WN, so bump here. 01866 * 01867 ==================================================== 01868 */ 01869 /*ARGSUSED*/ 01870 INT32 01871 fei_label(char *name_string, 01872 INT32 flags, 01873 INT32 Class, 01874 char *fmt_string, 01875 INT32 debug) 01876 { 01877 LABEL_IDX l_idx; 01878 01879 switch ((LABEL_SYM)Class) { 01880 01881 case PDGCS_Lbl_User : 01882 case PDGCS_Lbl_Format: 01883 { 01884 LABEL& lbl = New_LABEL (CURRENT_SYMTAB, l_idx); 01885 LABEL_Init(lbl, Save_Str(name_string), LKIND_DEFAULT); 01886 } 01887 break ; 01888 01889 case PDGCS_Lbl_Internal: 01890 case PDGCS_Lbl_LoopInternal: 01891 { 01892 LABEL& int_lbl = New_LABEL (CURRENT_SYMTAB, l_idx); 01893 if ((LABEL_SYM)Class==PDGCS_Lbl_LoopInternal) 01894 LABEL_Init(int_lbl, 0, LKIND_LOOP_GEN); 01895 else 01896 LABEL_Init(int_lbl, 0, LKIND_INTERNAL); 01897 } 01898 break ; 01899 01900 default: 01901 DevAssert((0),(" Unexpected Label")); 01902 01903 } 01904 return(cast_to_int(l_idx)); 01905 } 01906 01907 /*=================================================== 01908 * 01909 * cwh_stab_set_symtab 01910 * 01911 * Set the current SYMTAB correctly. If this is 01912 * an internal procedure, be may have been processing 01913 * Host dummies - see fei_proc_parent - and now 01914 * need to go back to the child. 01915 * 01916 * symtab == scope : there can be only 1 pair of 01917 * internal/external routines being processed at once. 01918 * 01919 ==================================================== 01920 */ 01921 extern void 01922 cwh_stab_set_symtab(ST *st) 01923 { 01924 Current_scope = PU_lexical_level(st); 01925 } 01926 01927 /*=================================================== 01928 * 01929 * cwh_stab_const_ST 01930 * 01931 * Make(find) an ST from the INTCONST(CONST) in this WN. 01932 * 01933 ==================================================== 01934 */ 01935 extern ST * 01936 cwh_stab_const_ST(WN *wn) 01937 { 01938 TCON tcon; 01939 ST *st ; 01940 01941 if (WNOPR(wn) == OPR_CONST) 01942 st = WN_st(wn); 01943 01944 else if (WNOPR(wn) == OPR_INTCONST) { 01945 tcon = Host_To_Targ (WNRTY(wn),WN_const_val(wn)); 01946 st = New_Const_Sym(Enter_tcon (tcon), Be_Type_Tbl(WNRTY(wn))); 01947 01948 } else { 01949 DevAssert((0),("unexpected WN")); 01950 } 01951 return st; 01952 } 01953 01954 /*=================================================== 01955 * 01956 * cwh_stab_const 01957 * 01958 * Make a WN from the ST for this const, 01959 * 01960 ==================================================== 01961 */ 01962 extern WN * 01963 cwh_stab_const(ST *st) 01964 { 01965 WN *wn ; 01966 TYPE_ID bt; 01967 01968 bt = TY_mtype(ST_type(st)); 01969 wn = WN_CreateConst (Const_Opcode [bt],st); 01970 01971 return(wn); 01972 } 01973 01974 /*=================================================== 01975 * 01976 * cwh_stab_address_temp_ST 01977 * 01978 * Make an ST for a local (AUTO) address temp. Sets 01979 * 01980 * ST_is_temp_var - avoids DST info. 01981 * 01982 * If uniq is TRUE sets 01983 * 01984 * ST_pt_to_unique_mem - not target of ptr. 01985 * 01986 ==================================================== 01987 */ 01988 extern ST * 01989 cwh_stab_address_temp_ST(char * name, TY_IDX ty , BOOL uniq) 01990 { 01991 ST * st ; 01992 01993 st = New_ST(CURRENT_SYMTAB); 01994 cwh_auxst_clear(st); 01995 ST_Init (st, 01996 Save_Str(cwh_types_mk_anon_name(name)), 01997 CLASS_VAR, 01998 SCLASS_AUTO, 01999 EXPORT_LOCAL, 02000 ty); 02001 02002 Set_ST_is_temp_var(st); 02003 02004 if (uniq) 02005 Set_ST_pt_to_unique_mem(st); 02006 02007 cwh_expr_temp_set_pragma(st); 02008 return st ; 02009 } 02010 02011 /*================================================================ 02012 * 02013 * cwh_stab_temp_ST 02014 * 02015 * Makes an ST for a temp, marks it LOCAL if in PDO 02016 * 02017 * ================================================================ 02018 */ 02019 extern ST * 02020 cwh_stab_temp_ST(TY_IDX ty,char * name) 02021 { 02022 ST * st; 02023 02024 st = Gen_Temp_Symbol(ty,name); 02025 cwh_auxst_clear(st); 02026 cwh_expr_temp_set_pragma(st) ; 02027 02028 return st; 02029 } 02030 02031 /*=================================================== 02032 * 02033 * cwh_stab_add_pragma 02034 * 02035 * Set given flag in ST's pragma. Only the 02036 * ACCESSED_ID pragma for host variables referenced 02037 * within internal procedures are handled. If a NULL 02038 * was returned from the preamble routine, then we 02039 * were probably in a declaration & there was no block 02040 * to add the pragma too. It'll be done when the code 02041 * is executed. 02042 * 02043 ==================================================== 02044 */ 02045 extern void 02046 cwh_stab_add_pragma(ST *st, WN_PRAGMA_ACCESSED_FLAGS flag ) 02047 { 02048 WN * wn ; 02049 enum site block = block_ca ; 02050 02051 wn = cwh_auxst_pragma(st); 02052 02053 if (wn == NULL) { 02054 02055 wn = WN_CreatePragma (WN_PRAGMA_ACCESSED_ID,st,0,flag); 02056 02057 if (cwh_stmt_add_to_preamble(wn, block)) 02058 (void) cwh_auxst_pragma(st,wn); 02059 else 02060 WN_DELETE_Tree(wn); 02061 02062 } else 02063 WN_pragma_arg2(wn) = WN_pragma_arg2(wn) | flag ; 02064 } 02065 02066 /*=================================================== 02067 * 02068 * cwh_stab_packet 02069 * 02070 * Sometimes we return either a WN, an ST, or constant. 02071 * to the PDGCS layer. eg: for an array bound or character 02072 * len. To distinguish they are tagged. 02073 * 02074 ==================================================== 02075 */ 02076 extern STB_pkt * 02077 cwh_stab_packet(void * thing, enum is_form fm) 02078 { 02079 STB_pkt *p ; 02080 02081 p = cwh_stab_packet_typed(thing,fm, 0) ; 02082 return (p) ; 02083 } 02084 02085 /*=================================================== 02086 * 02087 * cwh_stab_packet_typed 02088 * 02089 * TYped version of above. In the case of 02090 * a logical constant, we have to type the WN to 02091 * distinguish it from an integer. Other instances 02092 * could use the mechanism, but don't. (no need); 02093 * 02094 ==================================================== 02095 */ 02096 extern STB_pkt * 02097 cwh_stab_packet_typed(void * thing, enum is_form fm, TY_IDX ty) 02098 { 02099 STB_pkt *p ; 02100 02101 p = (STB_pkt *) malloc(sizeof(STB_pkt)) ; 02102 02103 p->item = thing ; 02104 p->form = fm ; 02105 p->ty = ty ; 02106 p->next = STB_list; 02107 02108 STB_list = p ; 02109 02110 return (p) ; 02111 } 02112 02113 /*=================================================== 02114 * 02115 * cwh_stab_free_packet 02116 * 02117 * Free the STB packet list 02118 * 02119 ==================================================== 02120 */ 02121 static void 02122 cwh_stab_free_packet(void) 02123 { 02124 02125 STB_pkt *p ; 02126 STB_pkt *q ; 02127 02128 p = STB_list ; 02129 02130 while (p != NULL) { 02131 q = p->next ; 02132 free(p); 02133 p = q ; 02134 } 02135 02136 STB_list = NULL ; 02137 02138 } 02139 /*=============================================== 02140 * 02141 * cwh_stab_end_procs 02142 * 02143 * Clean up at the end of a procedure. Get rid of 02144 * packets and auxst info created for this PU. 02145 * 02146 * Set Scope to host, or global symtab. 02147 * fei_next_func_idx will adjust to whatever's next. 02148 * 02149 *=============================================== 02150 */ 02151 extern void 02152 cwh_stab_end_procs(void) 02153 { 02154 cwh_stab_free_packet(); 02155 cwh_auxst_free() ; 02156 02157 if (! IN_NESTED_PU) 02158 Has_nested_proc = FALSE ; 02159 02160 cwh_auxst_un_register_table() ; 02161 Delete_Scope(CURRENT_SYMTAB); 02162 02163 Current_scope -= 1; 02164 cwh_auxst_clear_per_PU(); 02165 entry_point_count = 0 ; 02166 } 02167 02168 /*=============================================== 02169 * 02170 * cwh_stab_earlier_hosted 02171 * 02172 * Internal procedures are entered before hosts, 02173 * so to reference the host variable within the 02174 * inner procedure, the 'internal' version was 02175 * placed in the host symbol table. Now, processing 02176 * the host symbols, have been given an ST with a 02177 * inner def/ref, so want to find the one used earlier 02178 * and return that. It may be a reference to a host 02179 * symbol from another internal proc of course. 02180 * 02181 *=============================================== 02182 */ 02183 static ST * 02184 cwh_stab_earlier_hosted(const char * name) 02185 { 02186 ST * sl ; 02187 INT32 i ; 02188 02189 for(i = 0 ; i <= Host_Top ; i ++) { 02190 sl = Host_STs[i]; 02191 if (ST_class(sl) == CLASS_VAR) 02192 if (strcmp(name,ST_name(sl)) == 0) 02193 return (sl); 02194 } 02195 return (NULL); 02196 } 02197 02198 /*=============================================== 02199 * 02200 * cwh_stab_enter_hosted 02201 * 02202 * Save this ST on the list of hosted varbls 02203 * while processing the inner procedure. When 02204 * processing the host then this ST is the one 02205 * to look for & use. 02206 * 02207 *=============================================== 02208 */ 02209 static void 02210 cwh_stab_enter_hosted(ST * st) 02211 { 02212 Host_Top ++ ; 02213 02214 if (Host_Top >= Host_Current_Size) { 02215 Host_Current_Size += HOST_ST_SIZE_CHANGE; 02216 Host_STs = (ST **) realloc(Host_STs,sizeof(ST *)*Host_Current_Size); 02217 } 02218 02219 Host_STs[Host_Top] = st; 02220 } 02221 02222 /*=============================================== 02223 * 02224 * cwh_stab_adjust_name 02225 * 02226 * Internal and module procedures are named 02227 * <proc>.in.<host>, but for DST information the 02228 * additional information should be stripped off 02229 * and the stem used. DW_AT_linkage strings 02230 * preserve the original, so the linker can find it. 02231 * 02232 * The MAIN program is an exception - we want MAIN, 02233 * as the ST for ld to resolve the executable from 02234 * main_/crt0 but require the program name as a 02235 * debuggable name. 02236 * 02237 * [email protected] -> removed the name change 02238 * in main program 02239 * 02240 * This builds the stem, and tacks it into the 02241 * ST's AUXST. 02242 * 02243 *=============================================== 02244 */ 02245 static void 02246 cwh_stab_adjust_name(ST * st) 02247 { 02248 char *p; 02249 char *s; 02250 char c; 02251 INT32 n; 02252 02253 s = ST_name(st); 02254 02255 PU& pu = Pu_Table[ST_pu(st)]; 02256 if (PU_is_mainpu(pu)) { 02257 02258 //Set_ST_name(st, Save_Str(def_main_u)); 02259 02260 //if (!strcmp(crayf90_def_main,s)) 02261 // s = def_main ; 02262 02263 n = strlen(s); 02264 p = (char *) malloc(n+1); 02265 (void) cwh_auxst_stem_name(st,strcpy(p,s)); 02266 p[n-1] = '\0'; 02267 02268 } else { 02269 02270 c = '.' ; 02271 p = strchr(s,c); 02272 02273 if (p != NULL) { 02274 02275 n = p-s+1; 02276 p = (char *) malloc(n); 02277 p = strncpy(p,s,n-1); 02278 p[n-1] = '\0'; 02279 02280 cwh_auxst_stem_name(st,p); 02281 } 02282 } 02283 } 02284 02285 /*=============================================== 02286 * 02287 * cwh_stab_adjust_base_name. 02288 * 02289 * The FE gives temps names t$<n>. To make w2f 02290 * output and IR a little more intelligible, the 02291 * name of a base (address) temp is altered to be 02292 * p_<object>. 02293 * 02294 * For a hosted ST, this must happen only in the 02295 * host. eg: several internal procedures may use 02296 * the same t$3 from the host, so match them all, 02297 * then alter the ST. 02298 * 02299 *=============================================== 02300 */ 02301 static void 02302 cwh_stab_adjust_base_name(ST * st) 02303 { 02304 02305 if (Has_Base_Block(st)) { 02306 ST * base = ST_base(st); 02307 if (ST_is_temp_var(base)) 02308 if (ST_sclass(base) == SCLASS_AUTO) 02309 if (!ST_is_return_var(base)) 02310 if (!ST_has_nested_ref(st) || 02311 (ST_has_nested_ref(st) && CURRENT_SYMTAB == HOST_LEVEL)) 02312 Set_ST_name(base,Save_Str2("p_",ST_name(st))); 02313 } 02314 } 02315 02316 /*=============================================== 02317 * 02318 * cwh_stab_main_ST 02319 * 02320 * Returns the ST * of an CLASS_EXTERNAL ST used 02321 * to put out DST info for named programs. 02322 * 02323 *=============================================== 02324 */ 02325 extern ST * 02326 cwh_stab_main_ST(void) 02327 { 02328 return Main_ST; 02329 } 02330 02331 /*=============================================== 02332 * 02333 * cwh_stab_set_linenum 02334 * 02335 * Set the line number where the ST was declared 02336 * in the AUXST 02337 * 02338 *=============================================== 02339 */ 02340 extern void 02341 cwh_stab_set_linenum(ST *st, INT32 lineno) 02342 { 02343 USRCPOS *pos; 02344 char *file_name; 02345 static char *last_file_name = NULL; 02346 static INT32 last_file_num = 0 ; 02347 INT32 local_line_num; 02348 02349 pos = cwh_auxst_srcpos_addr(st); 02350 file_name = global_to_local_file(lineno); 02351 local_line_num = global_to_local_line_number(lineno); 02352 if (last_file_name != file_name) 02353 last_file_num = cwh_dst_enter_path(file_name); 02354 02355 USRCPOS_filenum(*pos) = last_file_num ; 02356 USRCPOS_linenum(*pos) = local_line_num; 02357 02358 last_file_name = file_name ; 02359 } 02360 02361 /*=============================================== 02362 * 02363 * cwh_stab_formal_ref 02364 * 02365 * Given an ST of SCLASS FORMAL, decide if 02366 * it should be a SCLASS_FORMAL_REF. 02367 * ie: it's scalar and by address. 02368 * 02369 *=============================================== 02370 */ 02371 static void 02372 cwh_stab_formal_ref(ST * st, BOOL host) 02373 { 02374 02375 TY_IDX ty ; 02376 02377 if (!ST_is_value_parm(st)) { 02378 02379 ty = ST_type(st); 02380 02381 if (TY_kind(ty) == KIND_SCALAR || TY_kind(ty) == KIND_STRUCT) 02382 Set_ST_sclass(st, SCLASS_FORMAL_REF); 02383 else 02384 Set_ST_type(st, cwh_types_mk_pointer_TY(ty, host)); 02385 } 02386 } 02387 02388 /*=============================================== 02389 * 02390 * cwh_stab_full_split 02391 * 02392 * Given an ST of a common block, with 02393 * elements of the COMMON ordered by offset within 02394 * the AUXST, split the common fully. 02395 * 02396 * This is lifted from mfef77 as the split should 02397 * be consistent with f77 .o files which contain 02398 * similar common definitions. 02399 * 02400 *=============================================== 02401 */ 02402 static void 02403 cwh_stab_full_split(ST *c, enum list_name list) 02404 { 02405 ITEM * el; 02406 INT32 nf; 02407 INT32 i; 02408 LIST *l; 02409 FIELDS fp_table ; 02410 02411 l = cwh_auxst_get_list(c,l_COMLIST); 02412 if ( l == NULL) 02413 return; 02414 02415 nf = L_num(l); 02416 if (nf == 0) 02417 return ; 02418 02419 if (ST_is_initialized(c) || TY_is_volatile(ST_type(c))) { 02420 cwh_stab_mk_flds(c,list); 02421 return ; 02422 } 02423 02424 fp_table = (FIELDS) malloc ( sizeof(FIELD_ITEM) * nf) ; 02425 02426 i = 0 ; 02427 el = NULL ; 02428 02429 while ((el = cwh_auxst_next_element(c,el,list)) != NULL ) { 02430 02431 ST *st = I_element(el); 02432 FIELDS_fp(i) = st; 02433 FIELDS_first_offset(i) = ST_ofst(st); 02434 FIELDS_last_offset(i) = ST_ofst(st) + TY_size(ST_type(st)) - 1; 02435 i ++ ; 02436 } 02437 02438 DevAssert((i==nf),(" cant count")); 02439 02440 // cwh_stab_dump_FIELDS(fp_table,0,nf-1); 02441 02442 cwh_stab_find_overlaps(fp_table,nf); 02443 02444 /* if the COMMON was split, issue the elements of each partition 02445 * then the list of partitions which make up the COMMON. If not 02446 * split just issue all the elements of the COMMON. 02447 */ 02448 02449 if (cwh_stab_split_common(c,fp_table,nf)) { 02450 02451 el = NULL ; 02452 while ((el = cwh_auxst_next_element(c,el,l_SPLITLIST)) != NULL ) { 02453 02454 cwh_stab_mk_flds(I_element(el),l_COMLIST); 02455 } 02456 02457 cwh_stab_mk_flds(c,l_SPLITLIST); 02458 02459 L_num(l) = 0 ; 02460 L_first(l) = NULL ; 02461 L_last(l) = NULL ; 02462 02463 } else 02464 cwh_stab_mk_flds(c,list); 02465 02466 free(fp_table); 02467 02468 } 02469 02470 /*=============================================== 02471 * 02472 * cwh_stab_find_overlaps 02473 * 02474 * Utility function for Full_Split_Common. 02475 * Given an array of FIELDS ordered by first 02476 * offset, find any overlaps cause by equivalence, 02477 * and make all corresponding first & last offsets 02478 * reflect the size of the equivalence block 02479 * 02480 *=============================================== 02481 */ 02482 static void 02483 cwh_stab_find_overlaps(FIELDS fp_table, INT32 nf) 02484 { 02485 INT32 i,j,first; 02486 INT64 last_offset; 02487 INT64 first_offset; 02488 02489 first = 0; 02490 first_offset = FIELDS_first_offset(0); 02491 last_offset = FIELDS_last_offset(0); 02492 02493 for ( i = 1; i < nf; i++ ) { 02494 02495 if ( FIELDS_first_offset(i) > last_offset ) { 02496 02497 for ( j = first; j < i; j++ ) { 02498 02499 FIELDS_first_offset(j) = first_offset; 02500 FIELDS_last_offset(j) = last_offset; 02501 } 02502 02503 first = i; 02504 first_offset = FIELDS_first_offset(i); 02505 last_offset = FIELDS_last_offset(i); 02506 02507 } else if ( FIELDS_last_offset(i) > last_offset ) 02508 last_offset = FIELDS_last_offset(i); 02509 } 02510 02511 for ( j = first; j < i; j++ ) { 02512 02513 FIELDS_first_offset(j) = first_offset; 02514 FIELDS_last_offset(j) = last_offset; 02515 } 02516 } 02517 02518 02519 /*=============================================== 02520 * 02521 * cwh_stab_split_common 02522 * 02523 * Utility function for Full_Split_Common. 02524 * Given an array of FIELDS ordered by first 02525 * offset, and separated into non-overalapping 02526 * groups, split the common. 02527 * 02528 * All fields within an equivalence group have 02529 * the same first_offset and the last_offset 02530 * & hence extent of group. 02531 * 02532 * If the common was split return TRUE. 02533 * 02534 *=============================================== 02535 */ 02536 static BOOL 02537 cwh_stab_split_common(ST * c, FIELDS fp_table, INT32 nf) 02538 { 02539 ST * e ; 02540 ST * nc ; 02541 TY_IDX ty ; 02542 TY_IDX tc ; 02543 02544 INT32 i,j,k ; 02545 INT32 first ; 02546 INT32 full_split_last_array = -1; 02547 INT64 first_offset; 02548 INT64 last_offset; 02549 BOOL seen_a_split = FALSE ; 02550 02551 02552 tc = ST_type(c); 02553 first = 0; 02554 first_offset = FIELDS_first_offset(0); 02555 last_offset = FIELDS_last_offset(0); 02556 full_split_last_array = -1; 02557 02558 02559 for ( i = 1; i < nf; i++ ) { 02560 02561 if ( FIELDS_last_offset(i) > last_offset ) { 02562 02563 e = FIELDS_fp(i); 02564 ty = ST_type(e); 02565 02566 if ((TY_kind(ty) == KIND_ARRAY) && 02567 (FIELDS_first_offset(i) % TY_align(tc) == 0)) { 02568 02569 if ( TY_size(ty) >= FE_Full_Split_Array_Limit ) { 02570 02571 BOOL split = FALSE; 02572 02573 for ( j = 0; j < FE_Full_Split_Limits_Count; j++ ) { 02574 02575 if ( FIELDS_first_offset(i) - first_offset 02576 < FE_Full_Split_Limits [j].rel_offset 02577 - FE_Full_Split_Limits [j].delta ) 02578 break; 02579 02580 if ( need_to_split ( FIELDS_first_offset(i), 02581 first_offset, 02582 FE_Full_Split_Limits [j].rel_offset, 02583 FE_Full_Split_Limits [j].delta ) ) { 02584 split = TRUE; 02585 seen_a_split = TRUE; 02586 break; 02587 } 02588 02589 for (k = full_split_last_array; 02590 k >= 0; 02591 k = FIELDS_prev_array_index(k) ) { 02592 02593 if ( need_to_split (FIELDS_first_offset(i), 02594 FIELDS_first_offset(k), 02595 FE_Full_Split_Limits [j].rel_offset, 02596 FE_Full_Split_Limits [j].delta ) ) { 02597 split = TRUE; 02598 seen_a_split = TRUE; 02599 break; 02600 } 02601 } 02602 if ( split ) 02603 break; 02604 } 02605 02606 if ( split ) { 02607 02608 nc = cwh_stab_split_ST(c, 02609 FIELDS_first_offset(first), 02610 FIELDS_last_offset(i-1)); 02611 cwh_stab_emit_split(nc,fp_table,first, i-1); 02612 cwh_auxst_add_item(c,nc, l_SPLITLIST); 02613 if (ST_is_thread_private(c)) Set_ST_is_thread_private(nc); 02614 first = i; 02615 first_offset = FIELDS_first_offset(i); 02616 full_split_last_array = -1; 02617 } 02618 02619 FIELDS_prev_array_index(i) = full_split_last_array; 02620 full_split_last_array = i; 02621 } 02622 } 02623 last_offset = FIELDS_last_offset(i); 02624 } 02625 } 02626 02627 if (seen_a_split) { 02628 nc = cwh_stab_split_ST(c, 02629 FIELDS_first_offset(first), 02630 FIELDS_last_offset(i-1)); 02631 cwh_stab_emit_split(nc,fp_table,first, i-1); 02632 cwh_auxst_add_item(c,nc, l_SPLITLIST); 02633 } 02634 02635 return seen_a_split ; 02636 } 02637 02638 /*=============================================== 02639 * 02640 * need_to_split 02641 * 02642 * Utility function for cwh_stab_split_common 02643 * Given an current position and offset decide 02644 * if the block has to be split. 02645 * 02646 *=============================================== 02647 */ 02648 static BOOL 02649 need_to_split (INT64 cur_offset, 02650 INT64 base_offset, 02651 INT64 rel_offset, 02652 int delta ) 02653 { 02654 BOOL split; 02655 INT64 offset; 02656 02657 offset = cur_offset - base_offset; 02658 offset = offset % rel_offset; 02659 02660 split = ( offset < delta ) || ( offset > ( rel_offset - delta ) ); 02661 02662 return split; 02663 } 02664 02665 /*=============================================== 02666 * 02667 * cwh_stab_dump_FIELDS 02668 * 02669 * Dumps n items of a FIELDS array. the indexes 02670 * are inclusive. 02671 * 02672 *=============================================== 02673 */ 02674 static void 02675 cwh_stab_dump_FIELDS(FIELDS fp_table, INT32 from, INT32 to) 02676 { 02677 ST *st; 02678 INT32 i ; 02679 02680 for ( i = from; i <= to; i++ ) { 02681 02682 st = FIELDS_fp(i); 02683 02684 printf (" %d - ",i); 02685 02686 printf (" f_off: %16llx, l_off: %16llx, prev %4d,", 02687 FIELDS_first_offset(i), 02688 FIELDS_last_offset(i), 02689 FIELDS_prev_array_index(i)); 02690 if (st) 02691 printf (" ST: %x (%s)\n",st,ST_name(st)); 02692 else 02693 printf (" ST: <none>\n"); 02694 02695 } 02696 } 02697 02698 /*=============================================== 02699 * 02700 * cwh_stab_emit_split 02701 * 02702 * Emits a split COMMON ST, given a fields table, 02703 * and the first & last (inclusive) FIELDS of the split. 02704 * 02705 * Each element of the common has its base and offset 02706 * adjusted to a slot in the new common. The common 02707 * is ordered by offset in the FIELDS. 02708 * 02709 *=============================================== 02710 */ 02711 static void 02712 cwh_stab_emit_split(ST * c, FIELDS fp_table, INT32 from, INT32 to) 02713 { 02714 02715 INT32 i ; 02716 ST * e ; 02717 INT64 off; 02718 02719 off = FIELDS_first_offset(from); 02720 02721 for (i = from ; i <= to; i ++) { 02722 e = FIELDS_fp(i); 02723 Set_ST_ofst(e, (ST_ofst(e) - off)); 02724 Set_ST_base(e, c); 02725 cwh_auxst_add_item(c,e,l_COMLIST) ; 02726 } 02727 } 02728 02729 /*=============================================== 02730 * 02731 * cwh_stab_split_ST 02732 * 02733 * Create a new ST for the part of the common 02734 * that has been split. The name is derived 02735 * from the name of the original common and 02736 * the 'offset' of the first field in the 02737 * split section. The name should match mfef77's. 02738 * 02739 *=============================================== 02740 */ 02741 static ST * 02742 cwh_stab_split_ST(ST * c, INT64 low_off, INT64 high_off) 02743 { 02744 INT32 l ; 02745 INT64 off; 02746 char *name; 02747 ST * st; 02748 02749 l = strlen(ST_name(c)); 02750 02751 name = (char *) malloc(l + 128); 02752 02753 name[0] = '_'; 02754 name[1] = '_'; 02755 02756 (void) strcpy(&name[2],ST_name(c)); 02757 sprintf(&name[l+2], ".%lld", low_off ); 02758 02759 off = high_off-low_off+1; 02760 st = cwh_stab_common_ST(name,byte_to_bit(off),TY_align(ST_type(c))); 02761 02762 Set_ST_ofst(st, 0); 02763 Set_ST_base(st, c); 02764 02765 Set_ST_is_split_common(st) ; 02766 02767 if (ST_is_thread_private(c)) 02768 Set_ST_is_thread_private(st); 02769 02770 Set_TY_split(Ty_Table[ST_type(st)]); 02771 02772 free (name); 02773 return st ; 02774 } 02775 02776 /*=============================================== 02777 * 02778 * cwh_stab_common_ST 02779 * 02780 * Create a new ST for a common, given a name, 02781 * a size & alignment (or 0). 02782 * 02783 *=============================================== 02784 */ 02785 static ST * 02786 cwh_stab_common_ST(char *name,INT64 size, mUINT16 al) 02787 { 02788 02789 ST * st ; 02790 ST * st1; 02791 SYMTAB_IDX s=CURRENT_SYMTAB; 02792 st1 = Scope_tab[s].st; 02793 02794 st = New_ST(GLOBAL_SYMTAB); 02795 cwh_auxst_clear(st); 02796 ST_Init(st, Save_Str(name), CLASS_VAR, SCLASS_COMMON, EXPORT_PREEMPTIBLE, 02797 cwh_types_mk_common_TY(size,al)); 02798 02799 Set_ST_base(st, st1); 02800 Set_ST_ofst(st, 0); 02801 02802 if (CURRENT_SYMTAB != GLOBAL_SYMTAB) { 02803 cwh_stab_pu_has_globals = TRUE; 02804 ; 02805 } 02806 02807 return st; 02808 } 02809 /************************************************ 02810 * 02811 * cwh_stab_module_ST 02812 * 02813 * Follow cwh_stab_common_ST 02814 * Only difference is the type change from 02815 * SCLASS_COMMON to SCLASS_MODULE 02816 *************************************************/ 02817 02818 static ST * 02819 cwh_stab_module_ST(char *name,INT64 size, mUINT16 al) 02820 { 02821 02822 ST * st ; 02823 02824 st = New_ST(GLOBAL_SYMTAB); 02825 cwh_auxst_clear(st); 02826 ST_Init(st, Save_Str(name), CLASS_VAR, SCLASS_MODULE, EXPORT_PREEMPTIBLE, 02827 cwh_types_mk_module_TY(size,al)); 02828 02829 Set_ST_base(st, st); 02830 Set_ST_ofst(st, 0); 02831 02832 if (CURRENT_SYMTAB != GLOBAL_SYMTAB) { 02833 cwh_stab_pu_has_globals = TRUE; 02834 ; 02835 } 02836 02837 return st; 02838 } 02839 02840 02841 02842 /*=============================================== 02843 * 02844 * cwh_stab_altres_offset 02845 * 02846 * Given an ST which represents part of a 02847 * result variable for an alternate entry 02848 * point, figure out what the ST_ofst 02849 * should be. 02850 * 02851 * The offsets may have to be revamped, if as 02852 * the full size of the equivalence class isn't 02853 * known until all return temps are processed. 02854 * 02855 * characters and arrays don't get here, becuase 02856 * they are passed by address, so there isn't a 02857 * shared variable. 02858 * 02859 *=============================================== 02860 */ 02861 static void 02862 cwh_stab_altres_offset(ST *st, BOOL hosted) 02863 { 02864 ITEM * et; 02865 02866 BOOL change ; 02867 BOOL same ; 02868 BOOL allF4C4 ; 02869 BOOL isF8 ; 02870 BOOL isC4 ; 02871 TY_IDX ty ; 02872 02873 if (ST_has_nested_ref(st) && ! hosted) 02874 return; 02875 02876 ty = ST_type(st); 02877 02878 if (TY_kind(ty) == KIND_STRUCT) /* struct < 16B? */ 02879 return ; 02880 02881 DevAssert((TY_kind(ty) == KIND_SCALAR),("Only scalars")); 02882 02883 /* was a base introduced because CQ entry appeared first? */ 02884 /* if so, make all bases consistent - use CQ one */ 02885 02886 if (Altbase_ST == NULL) 02887 Altbase_ST = ST_base(st); 02888 else if (Altbase_ST != ST_base(st)) 02889 Set_ST_base(st, Altbase_ST); 02890 02891 02892 /* are all entry points same TY? or all C4s and F4s? */ 02893 02894 allF4C4 = (TY_mtype(ty) == MTYPE_C4) || 02895 (TY_mtype(ty) == MTYPE_F4) ; 02896 02897 isF8 = (TY_mtype(ty) == MTYPE_F8); 02898 isC4 = (TY_mtype(ty) == MTYPE_C4); 02899 02900 02901 /* look through the list of return types & decide if they */ 02902 /* are all the same, or consistent in an interesting way */ 02903 02904 et = NULL; 02905 same = TRUE ; 02906 02907 while ((et = cwh_auxst_next_element(ST_base(st),et,l_RETURN_TEMPS)) != NULL ) { 02908 02909 TY_IDX tyi = ST_type(I_element(et)); 02910 02911 allF4C4 = allF4C4 && 02912 ((TY_mtype(tyi) == MTYPE_C4) || 02913 (TY_mtype(tyi) == MTYPE_F4)) ; 02914 02915 isF8 = isF8 || 02916 (TY_mtype(tyi) == MTYPE_F8) ; 02917 02918 isC4 = isC4 || 02919 (TY_mtype(tyi) == MTYPE_C4) ; 02920 02921 same = same && (ty == tyi); 02922 } 02923 02924 Set_ST_auxst_altentry_shareTY(ST_base(st),same); 02925 02926 02927 /* ints always I8, C4s require 16 bytes, if not all C4 or C4 & F4 */ 02928 02929 change = FALSE ; 02930 02931 TYPE_ID bt = TY_mtype(ty); 02932 TY_IDX tb = ST_type(ST_base(st)); 02933 TY& t = Ty_Table[tb]; 02934 02935 if (MTYPE_is_integral(bt)) { 02936 if (TY_size(tb) < TY_size(Be_Type_Tbl(MTYPE_I8))) { 02937 02938 Set_TY_size(t, TY_size(Be_Type_Tbl(MTYPE_I8))); 02939 change = TRUE; 02940 } 02941 02942 } else if (!same) { 02943 if (!allF4C4) { 02944 if (isC4 && isF8) { 02945 if (TY_size(tb) < TY_size(Be_Type_Tbl(MTYPE_C8))) { 02946 02947 Set_TY_size(t, TY_size(Be_Type_Tbl(MTYPE_C8))); 02948 change = TRUE; 02949 } 02950 } 02951 } 02952 } 02953 02954 /* is equiv size, enough (FE has different understanding) */ 02955 02956 if (TY_size(tb) <= TY_size(ty)) { 02957 02958 Set_TY_size(t, TY_size(ty)); 02959 change = TRUE; 02960 } 02961 02962 cwh_stab_altres_offset_comp(st,allF4C4); 02963 cwh_auxst_add_item(ST_base(st),st,l_RETURN_TEMPS); 02964 02965 /* equivalence TY changed? recompute offsets of previous items */ 02966 02967 if (change) { 02968 02969 et = NULL ; 02970 while ((et = cwh_auxst_next_element(ST_base(st),et,l_RETURN_TEMPS)) != NULL ) { 02971 cwh_stab_altres_offset_comp(I_element(et),allF4C4); 02972 } 02973 } 02974 } 02975 02976 /*=============================================== 02977 * 02978 * cwh_stab_altres_offset_comp 02979 * 02980 * Utility for cwh_stab_altres_offset 02981 * 02982 * sets the offset for the given ST. 02983 * 02984 * The flag says all altreturn values are 02985 * either F4, or C4s 02986 * 02987 *=============================================== 02988 */ 02989 static void 02990 cwh_stab_altres_offset_comp(ST *st, BOOL allF4C4) 02991 { 02992 TY_IDX ty; 02993 TY_IDX tb; 02994 TYPE_ID bt ; 02995 02996 ty = ST_type(st); 02997 bt = TY_mtype(ty); 02998 tb = ST_type(ST_base(st)); 02999 03000 if (MTYPE_is_complex(bt)) { 03001 if (bt == MTYPE_C4) 03002 if (TY_size(tb) > 8) 03003 Set_ST_ofst(st, 8); 03004 03005 } else if (MTYPE_is_float(bt)) { 03006 if (bt == MTYPE_F4) 03007 if (TY_size(tb) > 4 && !allF4C4) 03008 Set_ST_ofst(st, 4); 03009 03010 } else 03011 Set_ST_ofst(st, TY_size(Be_Type_Tbl(MTYPE_I8)) - TY_size(ty)); 03012 } 03013 03014 /*=============================================== 03015 * 03016 * cwh_stab_altentry_TY 03017 * 03018 * Given a ST, find the size of altentry_temp 03019 * associated with its TY. The types of a result 03020 * variable reflects the register used for the results 03021 * in a composite TY: 03022 * 03023 * integers, logicals : I8 03024 * floats: F8 03025 * complex: C8 03026 * 03027 * if all entries have the same result type, then the 03028 * result varbl is of that type, except integers are 03029 * always I8. 03030 * 03031 * In an expression however, for floats we need to 03032 * store the same type as the ST really is, so 03033 * the 'expr' flag controls this. 03034 * 03035 *=============================================== 03036 */ 03037 extern TY_IDX 03038 cwh_stab_altentry_TY(ST *st, BOOL expr) 03039 { 03040 TY_IDX tr; 03041 TY_IDX ty; 03042 TY_IDX base; 03043 03044 TYPE_ID max; 03045 TYPE_ID bt ; 03046 03047 ty = ST_type(st); 03048 03049 DevAssert((TY_kind(ty) == KIND_SCALAR),("Only scalars")); 03050 03051 base = ST_type(ST_base(st)); 03052 bt = TY_mtype(ty); 03053 max = bt ; 03054 03055 if (MTYPE_is_complex(bt)) { 03056 if (!expr) { 03057 if (TY_size(base) == 8) 03058 max = MTYPE_C4; 03059 else 03060 max = MTYPE_FQ; 03061 } 03062 03063 } else if (MTYPE_is_float(bt)) { 03064 if (TY_size(base) == 4) 03065 max = MTYPE_F4; 03066 else if (TY_size(base) == 8) { 03067 max = MTYPE_F8; 03068 if (ST_ofst(st) == 0 && bt == MTYPE_F4) 03069 max = MTYPE_C4; 03070 } else 03071 max = MTYPE_FQ; 03072 } else 03073 max = MTYPE_I8; 03074 03075 tr = Be_Type_Tbl(max); 03076 03077 return tr; 03078 } 03079 03080 /*=============================================== 03081 * 03082 * cwh_stab_distrib_pragmas 03083 * 03084 * if an ST in fei_object is the subject of 03085 * distribute directives the ST may have to 03086 * be tacked on to the list of declaration pragmas. 03087 * 03088 * Set_ST_is_reshaped if a distribute_reshape 03089 * 03090 *=============================================== 03091 */ 03092 static void 03093 cwh_stab_distrib_pragmas(ST *st) 03094 { 03095 TY_IDX ty; 03096 WN_ITER *stmt_iter; 03097 WN *stmt, *wn; 03098 PREG_det preg; 03099 03100 ty = ST_type(st); 03101 03102 if (ST_sclass(st) == SCLASS_FORMAL) 03103 ty = TY_pointed(ty); 03104 03105 DevAssert((TY_kind(ty)==KIND_ARRAY),("distribute of non-array")); 03106 03107 stmt_iter = WN_WALK_StmtIter(decl_distribute_pragmas); 03108 while(stmt_iter != NULL) { 03109 stmt_iter = WN_WALK_StmtNext(stmt_iter); 03110 if (stmt_iter) { 03111 stmt= WN_ITER_wn(stmt_iter); 03112 if (stmt!=NULL) { 03113 switch(WN_opcode(stmt)) { 03114 case OPC_XPRAGMA: 03115 case OPC_PRAGMA: 03116 WN_st_idx(stmt) = ST_st_idx(st); 03117 if (WN_pragma(stmt)==WN_PRAGMA_DISTRIBUTE_RESHAPE) 03118 Set_ST_is_reshaped(st); 03119 break; 03120 default: 03121 DevAssert((0),("unexpected distribute pragma")); 03122 } 03123 } 03124 } 03125 } 03126 03127 /* attach the pragmas to the decl statement list */ 03128 03129 cwh_block_append_given_id(decl_distribute_pragmas,First_Block,FALSE); 03130 decl_distribute_pragmas = NULL; 03131 03132 /* associate a PREG with the distributed array and write to it */ 03133 03134 preg = cwh_auxst_distr_preg(st); 03135 wn = cwh_load_distribute_temp(); 03136 wn = WN_CreateStid( OPC_I4STID, preg.preg, preg.preg_st, preg.preg_ty, wn); 03137 cwh_block_append_given_id(wn,First_Block,FALSE); 03138 03139 /* create another write to the global preg for all distributed arrays */ 03140 03141 if (preg_for_distribute.preg==-1) { 03142 preg_for_distribute=cwh_preg_next_preg(MTYPE_I4, NULL, NULL); 03143 } 03144 wn = cwh_load_distribute_temp(); 03145 wn = WN_CreateStid( OPC_I4STID, preg_for_distribute.preg, 03146 preg_for_distribute.preg_st, preg_for_distribute.preg_ty, wn); 03147 cwh_block_append_given_id(wn,First_Block,FALSE); 03148 03149 /* set the needs LNO bits */ 03150 03151 Set_PU_mp_needs_lno (Get_Current_PU ()); 03152 Set_FILE_INFO_needs_lno (File_info); 03153 } 03154 /*=================================================== 03155 * 03156 * cwh_load_distribute_temp 03157 * 03158 * Creates a LDID of the temp allocated to store to 03159 * the PREGs associated with the distributed arrays 03160 * 03161 ==================================================== 03162 */ 03163 extern WN * 03164 cwh_load_distribute_temp(void) 03165 { 03166 TY_IDX ty; 03167 WN *rtrn; 03168 03169 ty = Be_Type_Tbl(MTYPE_I4); 03170 03171 if (st_for_distribute_temp == NULL) { 03172 st_for_distribute_temp = Gen_Temp_Symbol(ty,TY_name(ty)); 03173 cwh_auxst_clear(st_for_distribute_temp); 03174 } 03175 rtrn = WN_CreateLdid(OPC_I4I4LDID, 0, st_for_distribute_temp, ty); 03176 return rtrn; 03177 } 03178 03179 03180 /*=============================================== 03181 * 03182 * cwh_stab_altentry_temp 03183 * 03184 * Found a CQ entry point, without having seen 03185 * an ST for the shared result temp. Make the 03186 * shared result_temp's base, if it doesn't exist 03187 * and the temp itself. Don't enter the temp, but 03188 * leave it up to fei_object. 03189 * 03190 *=============================================== 03191 */ 03192 static ST * 03193 cwh_stab_altentry_temp(char * name, BOOL hosted) 03194 { 03195 ST * st; 03196 TY_IDX ty; 03197 03198 TYPE t ; 03199 INT32 size ; 03200 03201 size = byte_to_bit(TY_size(Be_Type_Tbl(MTYPE_CQ))); 03202 03203 if (Altbase_ST == NULL) { 03204 03205 ty = cwh_types_mk_equiv_TY(size); 03206 st = cwh_stab_address_temp_ST(".cq_base.",ty , FALSE); 03207 Set_ST_base(st, st); 03208 cwh_stab_to_list_of_equivs(st, hosted) ; 03209 Altbase_ST = st; 03210 } 03211 03212 t = fei_descriptor(0,Basic,size,C_omplex,0,0); 03213 st = New_ST(CURRENT_SYMTAB); 03214 cwh_auxst_clear(st); 03215 ST_Init (st, Save_Str(name), CLASS_VAR, SCLASS_AUTO, EXPORT_LOCAL, cast_to_TY(t_TY(t))); 03216 Set_ST_base(st, Altbase_ST); 03217 Set_ST_ofst(st, 0); 03218 03219 return st; 03220 } 03221 03222 /*=============================================== 03223 * 03224 * cwh_stab_to_list_equivs 03225 * 03226 * Add this equivalence group base to a list 03227 * of equivalences for this PU. 03228 * 03229 *=============================================== 03230 */ 03231 static void 03232 cwh_stab_to_list_of_equivs(ST *st, BOOL hosted) 03233 { 03234 LIST ** l = &Equivalences ; 03235 03236 if (hosted) 03237 l = &Hosted_Equivalences ; 03238 03239 cwh_auxst_add_to_list(l,st,FALSE); 03240 } 03241 03242 /*=================================================== 03243 * 03244 * cwh_stab_set_tylist_for_entries 03245 * 03246 * Create tylists for the procedure and all its 03247 * entry points. 03248 * 03249 ==================================================== 03250 */ 03251 void 03252 cwh_stab_set_tylist_for_entries(ST *proc) 03253 { 03254 03255 ITEM *en = NULL; 03256 03257 cwh_auxst_set_tylist(proc); 03258 while ((en = cwh_auxst_next_element(proc,en,l_ALTENTRY)) != NULL) { 03259 cwh_auxst_set_tylist(I_element(en)); 03260 } 03261 03262 } 03263 03264 03265 /*=================================================== 03266 * 03267 * cwh_stab_emit_commons_and_equivalences 03268 * 03269 * Make fld's for the members of all the common blocks 03270 * equivalences and entry points in this PU. Couldn't 03271 * do it earlier, because didn't know sizes of blocks 03272 * to emit. 03273 * 03274 ==================================================== 03275 */ 03276 extern void 03277 cwh_stab_emit_commons_and_equivalences(SYMTAB_IDX level) 03278 { 03279 03280 void (*fp) (ST *, enum list_name) = &cwh_stab_mk_flds; 03281 03282 if (FE_Full_Split) 03283 fp = &cwh_stab_full_split ; 03284 03285 if (level == GLOBAL_SYMTAB) 03286 cwh_stab_emit_list(&Commons_Already_Seen,l_COMLIST,fp); 03287 03288 else { 03289 03290 cwh_stab_emit_list(&Equivalences,l_EQVLIST,&cwh_stab_mk_flds); 03291 03292 /* Emit any equivalence blocks for alternate entry points */ 03293 /* or equivalence'd host variables */ 03294 /* Entry points can't appear in internal routines, and */ 03295 /* internal routines see just host results they reference */ 03296 03297 if (level == HOST_LEVEL) 03298 cwh_stab_emit_list(&Hosted_Equivalences,l_EQVLIST,&cwh_stab_mk_flds); 03299 03300 } 03301 } 03302 03303 /*=================================================== 03304 * 03305 * cwh_stab_emit_list 03306 * 03307 * walk over one of the lists of STs that want FLDS 03308 * generating from item (fld ST) associated with each 03309 * eg: a common and its elements. 03310 * 03311 ==================================================== 03312 */ 03313 static void 03314 cwh_stab_emit_list(LIST ** lp, enum list_name list, void (*fp) (ST *, enum list_name)) 03315 { 03316 ITEM * i; 03317 03318 if (*lp != NULL ) { 03319 i = L_first(*lp); 03320 03321 while (i != NULL) { 03322 fp (I_element(i),list) ; 03323 i = I_next(i); 03324 } 03325 03326 cwh_auxst_free_list(lp); 03327 } 03328 } 03329 03330 /*=================================================== 03331 * 03332 * cwh_stab_mk_flds 03333 * 03334 * Make fld's for all the members of common or 03335 * equivalence block passed in. 03336 * 03337 ==================================================== 03338 */ 03339 static void 03340 cwh_stab_mk_flds(ST * blk, enum list_name list) 03341 { 03342 ITEM * el; 03343 INT32 nf; 03344 INT32 i; 03345 LIST *l; 03346 03347 l = cwh_auxst_get_list(blk, list); 03348 if (l == NULL) 03349 return ; 03350 03351 nf = L_num(l); 03352 03353 if (nf == 0) 03354 return ; 03355 03356 // cwh_stab_dump_list(l,FALSE); 03357 03358 i = 0 ; 03359 el = NULL ; 03360 03361 while ((el = cwh_auxst_next_element(blk,el,list)) != NULL ) { 03362 cwh_types_mk_element(blk,I_element(el)); 03363 i ++ ; 03364 } 03365 03366 DevAssert((i == nf), (" can't count")); 03367 } 03368 03369 /*=================================================== 03370 * 03371 * cwh_stab_earlier_common 03372 * 03373 * Has this common been seen already? If so, use the 03374 * old ST. Module data can always share the same 03375 * COMMON st, as the definition is consistent between 03376 * PUs. For user commons the is_duplicate flag is set 03377 * by the FE if name and types match. Equivalences 03378 * cause the flag to be false. 03379 * 03380 ==================================================== 03381 */ 03382 static ST* 03383 cwh_stab_earlier_common(char *name_string, BOOL is_duplicate) 03384 { 03385 ITEM * i; 03386 03387 if (Commons_Already_Seen!= NULL ) { 03388 i = L_first(Commons_Already_Seen); 03389 03390 while (i != NULL) { 03391 ST *st = I_element(i) ; 03392 if (ST_auxst_is_module_data(st) || is_duplicate) 03393 if (strcmp(ST_name(st),name_string) == 0) { 03394 return st ; 03395 } 03396 i = I_next(i); 03397 } 03398 } 03399 03400 return NULL; 03401 } 03402 03403 /*=============================================== 03404 * 03405 * cwh_stab_seen_common_element 03406 * 03407 * Is this item an element of a Common that 03408 * we've already seen? If it's equivalenced 03409 * at the same offset, lookup on name too. 03410 * (there may be more than 1...) 03411 * 03412 * TODO make efficient... 03413 * 03414 *=============================================== 03415 */ 03416 static ST * 03417 cwh_stab_seen_common_element(ST *c, INT64 offset, char* name) 03418 { 03419 ITEM * el = NULL; 03420 ST * st ; 03421 03422 while ((el = cwh_auxst_next_element(c,el,l_COMLIST)) != NULL ) { 03423 st = I_element(el); 03424 if (ST_ofst(st) == offset) 03425 if (strcmp(ST_name(st),name) == 0) 03426 return st ; 03427 03428 } 03429 return NULL ; 03430 } 03431 03432 /*=================================================== 03433 *===================================================*/ 03434 ST * 03435 cwh_stab_seen_derived_type_or_imported_var(ST *c, char* name) 03436 { 03437 ITEM * el = NULL; 03438 ST * st ; 03439 03440 while ((el = cwh_auxst_next_element(c,el,l_TYMDLIST)) != NULL ) { 03441 st = I_element(el); 03442 if (ST_pu(c) == ST_pu(ST_base(st))) 03443 if (strcmp(ST_name(st),name) == 0) 03444 return st ; 03445 } 03446 return NULL ; 03447 } 03448 /*=================================================== 03449 * 03450 * cwh_stab_mk_fn_0args 03451 * 03452 * create a new extern function, with 0 args. 03453 * This does not assign a scope array so if any 03454 * tables are needed, fei_proc_def or fei_proc_parent 03455 * will need to associate the ST with a scope 03456 * 03457 ==================================================== 03458 */ 03459 extern ST * 03460 cwh_stab_mk_fn_0args(char *name, ST_EXPORT eclass,SYMTAB_IDX level,TY_IDX rty) 03461 { 03462 ST * st ; 03463 PU_IDX pu ; 03464 TY_IDX ty ; 03465 03466 ty = cwh_types_mk_procedure_TY(rty, 03467 0, 03468 TRUE, 03469 FALSE); 03470 03471 pu = cwh_stab_mk_pu(ty, level); 03472 st = New_ST(GLOBAL_SYMTAB); 03473 cwh_auxst_clear(st); 03474 Set_PU_need_unparsed(pu); 03475 03476 ST_Init (st, 03477 Save_Str(name), 03478 CLASS_FUNC, 03479 SCLASS_EXTERN, 03480 eclass, 03481 (TY_IDX)pu); 03482 03483 Set_ST_ofst(st, 0); 03484 return(st); 03485 } 03486 03487 /*=================================================== 03488 * 03489 * cwh_stab_mk_pu 03490 * 03491 * create a new PU for the given procedure TY at 03492 * level L. 03493 * 03494 ==================================================== 03495 */ 03496 static PU_IDX 03497 cwh_stab_mk_pu(TY_IDX pty, SYMTAB_IDX level) 03498 { 03499 PU_IDX pu_idx; 03500 PU& pu = New_PU (pu_idx); 03501 03502 PU_Init(pu, pty, level); 03503 03504 return (pu_idx); 03505 } 03506 03507 /*=================================================== 03508 * 03509 * fei_smt_parameter 03510 * 03511 * If debug symbol tables are being built, this sends 03512 * information for adding parameters (named constants) 03513 * to the DST. It adds the name and line number for 03514 * a specific named constant. The constant was sent 03515 * earlier with fei_arith_con or fei_pattern_con. 03516 * 03517 ==================================================== 03518 */ 03519 03520 INTPTR 03521 fei_smt_parameter(char * name_string, 03522 TYPE type, 03523 INTPTR con_idx, 03524 INT32 Class, 03525 INT32 lineno) 03526 03527 { 03528 INT32 len; 03529 char * name; 03530 char * name1; 03531 STB_pkt *p; 03532 ST * st; 03533 TY_IDX ty; 03534 WN * wn; 03535 03536 03537 ty = cast_to_TY(t_TY(type)); 03538 03539 if (TY_is_character(ty)) { /* Character */ 03540 st = cast_to_ST(con_idx); 03541 } 03542 else { 03543 p = cast_to_STB(con_idx); 03544 03545 if (p->form == is_ST) { 03546 st = cast_to_ST(p->item); 03547 } 03548 else if (p->form == is_WN) { 03549 wn = cast_to_WN(p->item); 03550 st = cwh_stab_const_ST(wn); 03551 } 03552 } 03553 03554 /* Store the name in the auxiliary name table for the symbol. */ 03555 03556 /* WN's share const entries, but the same constant value may have */ 03557 /* multiple names, so the names are concatenated with blank */ 03558 /* separation and held in stem name until cwh_dst_process_var is */ 03559 /* called. Then they are separated and an entry is made for each */ 03560 /* parameter in the DST. */ 03561 03562 name = NULL; 03563 name = cwh_auxst_stem_name(st, name); 03564 03565 if (name == NULL) { /* this is the first name for this ST */ 03566 len = strlen(name_string); 03567 name1 = (char *) malloc(len+1); 03568 strcpy(name1, name_string); 03569 cwh_auxst_stem_name(st, name1); 03570 cwh_auxst_add_item(Procedure_ST,st,l_DST_PARMLIST); 03571 } 03572 else { 03573 len = strlen(name_string); 03574 len += strlen(name); 03575 ++len; 03576 name1 = (char *) malloc(len+1); 03577 strcpy(name1, name_string); 03578 strcat(name1, " "); 03579 strcat(name1, name); 03580 free(name); 03581 cwh_auxst_stem_name(st, name1); 03582 } 03583 //made a local symtab entry for parameter ---fzhao 03584 ST * parast = New_ST(CURRENT_SYMTAB); 03585 ST_Init(parast, 03586 Save_Str(name_string), 03587 CLASS_PARAMETER, 03588 SCLASS_UNKNOWN, 03589 EXPORT_LOCAL, 03590 ty); 03591 Set_ST_base(parast,st); 03592 Set_ST_sclass(parast,ST_sclass(st)); 03593 03594 cwh_stab_set_linenum(st,lineno); 03595 03596 return(cast_to_int(st)); 03597 } 03598 03599 /*=================================================== 03600 * 03601 * fei_interface 03602 * 03603 * Introduces an interface block, and the associated 03604 * list of components (pu's). Put it in the 03605 * First_Block. 03606 * 03607 ==================================================== 03608 */ 03609 /*ARGSUSED*/ 03610 INTPTR 03611 fei_interface(char * name_string, 03612 INT32 nitems, 03613 INT32 kind_interface, 03614 INT32 is_imported) 03615 { 03616 ST * st; 03617 TY_IDX ty; 03618 STB_pkt *p; 03619 WN * wn; 03620 WN * wn1; 03621 OPCODE opc; 03622 WN * block; 03623 int i = 0; 03624 int k; 03625 03626 03627 st = New_ST(CURRENT_SYMTAB); 03628 03629 cwh_auxst_clear(st); 03630 03631 ty = 0; 03632 03633 ST_Init(st, Save_Str(name_string), CLASS_VAR, SCLASS_AUTO, EXPORT_LOCAL, ty); 03634 Set_ST_ofst(st, 0); 03635 03636 if (is_imported) 03637 Set_ST_is_external(st); 03638 03639 if (kind_interface == 1) 03640 Set_ST_is_assign_interface(st); 03641 else if (kind_interface == 2) 03642 Set_ST_is_operator_interface(st); 03643 else if (kind_interface == 3) 03644 Set_ST_is_u_operator_interface(st); 03645 03646 p = cwh_stab_packet(cast_to_void(st),is_ST) ; 03647 03648 03649 opc = OPCODE_make_op(OPR_INTERFACE,MTYPE_V,MTYPE_V); 03650 wn = WN_Create(opc,nitems); 03651 WN_st_idx(wn) = ST_st_idx(st); 03652 03653 if (nitems !=0) 03654 for (k = nitems -1 ; k >= 0 ; k --) { 03655 wn1 = cwh_stk_pop_WN(); 03656 WN_kid(wn,k) = wn1; 03657 } 03658 03659 cwh_block_append_given_id(wn,First_Block,FALSE); 03660 03661 return (cast_to_int(p)); 03662 } 03663 03664 03665 void fei_set_in_interface_processing() 03666 { 03667 interface_pu = 1; 03668 } 03669 03670 03671 void fei_reset_in_interface_processing() 03672 { 03673 interface_pu = 0; 03674 }