00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041
00042
00043
00044
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
00058
00059
00060
00061
00062
00063
00064
00065
00066 static char *source_file = __FILE__;
00067
00068 #ifdef _KEEP_RCS_ID
00069 #endif
00070
00071
00072
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
00090
00091 #include "i_cvrt.h"
00092
00093
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
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
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;
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
00175
00176
00177
00178
00179
00180
00181
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
00271
00272
00273
00274
00275
00276
00277
00278
00279
00280
00281
00282
00283
00284
00285
00286
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
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
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
00359
00360
00361
00362
00363 PU_IDX pu_idx = ST_pu(st);
00364 PU& pu = Pu_Table[pu_idx];
00365 pu.lexical_level =CURRENT_SYMTAB;
00366
00367
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
00380
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
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
00430
00431
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
00456
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
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
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
00534
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
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
00590
00591
00592
00593
00594
00595
00596
00597
00598
00599
00600
00601
00602
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:
00632 case PDGCS_Proc_Intern_Ref:
00633 case PDGCS_Proc_SrcIntrin:
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
00645
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)
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);
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
00731
00732
00733
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
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
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
00830
00831
00832
00833
00834
00835
00836
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
00856
00857
00858
00859
00860
00861
00862
00863
00864
00865
00866
00867
00868
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
00905
00906
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
00921
00922
00923
00924
00925
00926
00927
00928
00929
00930
00931
00932
00933
00934
00935
00936
00937
00938
00939
00940
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
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
01000
01001
01002
01003
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
01014
01015 if (test_flag(flag_bits,FEI_OBJECT_SF_DARG))
01016 return(0);
01017
01018
01019
01020
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
01033
01034
01035
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
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))
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
01066
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
01081
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
01089
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
01118
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
01135
01136
01137 if (in_common || (sym_class == Name)||
01138 (test_flag(flag_bits, FEI_OBJECT_IN_MODULE))) {
01139
01140
01141
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
01186
01187
01188
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
01200
01201
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
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
01245
01246
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
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
01276
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
01285
01286
01287
01288
01289 if (ST_level(st) == HOST_LEVEL) {
01290
01291
01292
01293
01294 }
01295
01296 } else if (TY_mtype(ty) == MTYPE_CQ) {
01297
01298
01299
01300
01301
01302 if (PU_has_altentry(Get_Current_PU())) {
01303
01304 ST * rt = st ;
01305
01306
01307
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 }
01347 }
01348
01349 if (formal)
01350 cwh_stab_formal_ref(st,hosted);
01351
01352 }
01353
01354
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
01367
01368
01369
01370
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
01400
01401 if (!hosted)
01402 cwh_stab_adjust_base_name(st);
01403 }
01404
01405
01406
01407
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
01422
01423
01424
01425
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
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
01445
01446
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
01464
01465
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
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
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) {
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
01539
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
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
01575
01576
01577
01578
01579
01580
01581
01582
01583
01584
01585
01586
01587
01588
01589
01590
01591
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 {
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
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
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))
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 {
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
01712
01713
01714
01715
01716
01717
01718
01719
01720
01721
01722
01723
01724
01725
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
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
01788
01789
01790
01791
01792
01793
01794
01795
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);
01820
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
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
01848
01849 }
01850 cwh_block_append_given_id(wn,First_Block,FALSE);
01851
01852 return (cast_to_int(p));
01853 }
01854
01855
01856
01857
01858
01859
01860
01861
01862
01863
01864
01865
01866
01867
01868
01869
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 {
01891 LABEL& int_lbl = New_LABEL (CURRENT_SYMTAB, l_idx);
01892 LABEL_Init(int_lbl, 0, LKIND_DEFAULT);
01893 }
01894 break ;
01895
01896 default:
01897 DevAssert((0),(" Unexpected Label"));
01898
01899 }
01900 return(cast_to_int(l_idx));
01901 }
01902
01903
01904
01905
01906
01907
01908
01909
01910
01911
01912
01913
01914
01915
01916
01917 extern void
01918 cwh_stab_set_symtab(ST *st)
01919 {
01920 Current_scope = PU_lexical_level(st);
01921 }
01922
01923
01924
01925
01926
01927
01928
01929
01930
01931 extern ST *
01932 cwh_stab_const_ST(WN *wn)
01933 {
01934 TCON tcon;
01935 ST *st ;
01936
01937 if (WNOPR(wn) == OPR_CONST)
01938 st = WN_st(wn);
01939
01940 else if (WNOPR(wn) == OPR_INTCONST) {
01941 tcon = Host_To_Targ (WNRTY(wn),WN_const_val(wn));
01942 st = New_Const_Sym(Enter_tcon (tcon), Be_Type_Tbl(WNRTY(wn)));
01943
01944 } else {
01945 DevAssert((0),("unexpected WN"));
01946 }
01947 return st;
01948 }
01949
01950
01951
01952
01953
01954
01955
01956
01957
01958 extern WN *
01959 cwh_stab_const(ST *st)
01960 {
01961 WN *wn ;
01962 TYPE_ID bt;
01963
01964 bt = TY_mtype(ST_type(st));
01965 wn = WN_CreateConst (Const_Opcode [bt],st);
01966
01967 return(wn);
01968 }
01969
01970
01971
01972
01973
01974
01975
01976
01977
01978
01979
01980
01981
01982
01983
01984 extern ST *
01985 cwh_stab_address_temp_ST(char * name, TY_IDX ty , BOOL uniq)
01986 {
01987 ST * st ;
01988
01989 st = New_ST(CURRENT_SYMTAB);
01990 cwh_auxst_clear(st);
01991 ST_Init (st,
01992 Save_Str(cwh_types_mk_anon_name(name)),
01993 CLASS_VAR,
01994 SCLASS_AUTO,
01995 EXPORT_LOCAL,
01996 ty);
01997
01998 Set_ST_is_temp_var(st);
01999
02000 if (uniq)
02001 Set_ST_pt_to_unique_mem(st);
02002
02003 cwh_expr_temp_set_pragma(st);
02004 return st ;
02005 }
02006
02007
02008
02009
02010
02011
02012
02013
02014
02015 extern ST *
02016 cwh_stab_temp_ST(TY_IDX ty,char * name)
02017 {
02018 ST * st;
02019
02020 st = Gen_Temp_Symbol(ty,name);
02021 cwh_auxst_clear(st);
02022 cwh_expr_temp_set_pragma(st) ;
02023
02024 return st;
02025 }
02026
02027
02028
02029
02030
02031
02032
02033
02034
02035
02036
02037
02038
02039
02040
02041 extern void
02042 cwh_stab_add_pragma(ST *st, WN_PRAGMA_ACCESSED_FLAGS flag )
02043 {
02044 WN * wn ;
02045 enum site block = block_ca ;
02046
02047 wn = cwh_auxst_pragma(st);
02048
02049 if (wn == NULL) {
02050
02051 wn = WN_CreatePragma (WN_PRAGMA_ACCESSED_ID,st,0,flag);
02052
02053 if (cwh_stmt_add_to_preamble(wn, block))
02054 (void) cwh_auxst_pragma(st,wn);
02055 else
02056 WN_DELETE_Tree(wn);
02057
02058 } else
02059 WN_pragma_arg2(wn) = WN_pragma_arg2(wn) | flag ;
02060 }
02061
02062
02063
02064
02065
02066
02067
02068
02069
02070
02071
02072 extern STB_pkt *
02073 cwh_stab_packet(void * thing, enum is_form fm)
02074 {
02075 STB_pkt *p ;
02076
02077 p = cwh_stab_packet_typed(thing,fm, 0) ;
02078 return (p) ;
02079 }
02080
02081
02082
02083
02084
02085
02086
02087
02088
02089
02090
02091
02092 extern STB_pkt *
02093 cwh_stab_packet_typed(void * thing, enum is_form fm, TY_IDX ty)
02094 {
02095 STB_pkt *p ;
02096
02097 p = (STB_pkt *) malloc(sizeof(STB_pkt)) ;
02098
02099 p->item = thing ;
02100 p->form = fm ;
02101 p->ty = ty ;
02102 p->next = STB_list;
02103
02104 STB_list = p ;
02105
02106 return (p) ;
02107 }
02108
02109
02110
02111
02112
02113
02114
02115
02116
02117 static void
02118 cwh_stab_free_packet(void)
02119 {
02120
02121 STB_pkt *p ;
02122 STB_pkt *q ;
02123
02124 p = STB_list ;
02125
02126 while (p != NULL) {
02127 q = p->next ;
02128 free(p);
02129 p = q ;
02130 }
02131
02132 STB_list = NULL ;
02133
02134 }
02135
02136
02137
02138
02139
02140
02141
02142
02143
02144
02145
02146
02147 extern void
02148 cwh_stab_end_procs(void)
02149 {
02150 cwh_stab_free_packet();
02151 cwh_auxst_free() ;
02152
02153 if (! IN_NESTED_PU)
02154 Has_nested_proc = FALSE ;
02155
02156 cwh_auxst_un_register_table() ;
02157 Delete_Scope(CURRENT_SYMTAB);
02158
02159 Current_scope -= 1;
02160 cwh_auxst_clear_per_PU();
02161 entry_point_count = 0 ;
02162 }
02163
02164
02165
02166
02167
02168
02169
02170
02171
02172
02173
02174
02175
02176
02177
02178
02179 static ST *
02180 cwh_stab_earlier_hosted(const char * name)
02181 {
02182 ST * sl ;
02183 INT32 i ;
02184
02185 for(i = 0 ; i <= Host_Top ; i ++) {
02186 sl = Host_STs[i];
02187 if (ST_class(sl) == CLASS_VAR)
02188 if (strcmp(name,ST_name(sl)) == 0)
02189 return (sl);
02190 }
02191 return (NULL);
02192 }
02193
02194
02195
02196
02197
02198
02199
02200
02201
02202
02203
02204
02205 static void
02206 cwh_stab_enter_hosted(ST * st)
02207 {
02208 Host_Top ++ ;
02209
02210 if (Host_Top >= Host_Current_Size) {
02211 Host_Current_Size += HOST_ST_SIZE_CHANGE;
02212 Host_STs = (ST **) realloc(Host_STs,sizeof(ST *)*Host_Current_Size);
02213 }
02214
02215 Host_STs[Host_Top] = st;
02216 }
02217
02218
02219
02220
02221
02222
02223
02224
02225
02226
02227
02228
02229
02230
02231
02232
02233
02234
02235
02236
02237
02238
02239
02240
02241 static void
02242 cwh_stab_adjust_name(ST * st)
02243 {
02244 char *p;
02245 char *s;
02246 char c;
02247 INT32 n;
02248
02249 s = ST_name(st);
02250
02251 PU& pu = Pu_Table[ST_pu(st)];
02252 if (PU_is_mainpu(pu)) {
02253
02254
02255
02256
02257
02258
02259 n = strlen(s);
02260 p = (char *) malloc(n+1);
02261 (void) cwh_auxst_stem_name(st,strcpy(p,s));
02262 p[n-1] = '\0';
02263
02264 } else {
02265
02266 c = '.' ;
02267 p = strchr(s,c);
02268
02269 if (p != NULL) {
02270
02271 n = p-s+1;
02272 p = (char *) malloc(n);
02273 p = strncpy(p,s,n-1);
02274 p[n-1] = '\0';
02275
02276 cwh_auxst_stem_name(st,p);
02277 }
02278 }
02279 }
02280
02281
02282
02283
02284
02285
02286
02287
02288
02289
02290
02291
02292
02293
02294
02295
02296
02297 static void
02298 cwh_stab_adjust_base_name(ST * st)
02299 {
02300
02301 if (Has_Base_Block(st)) {
02302 ST * base = ST_base(st);
02303 if (ST_is_temp_var(base))
02304 if (ST_sclass(base) == SCLASS_AUTO)
02305 if (!ST_is_return_var(base))
02306 if (!ST_has_nested_ref(st) ||
02307 (ST_has_nested_ref(st) && CURRENT_SYMTAB == HOST_LEVEL))
02308 Set_ST_name(base,Save_Str2("p_",ST_name(st)));
02309 }
02310 }
02311
02312
02313
02314
02315
02316
02317
02318
02319
02320
02321 extern ST *
02322 cwh_stab_main_ST(void)
02323 {
02324 return Main_ST;
02325 }
02326
02327
02328
02329
02330
02331
02332
02333
02334
02335
02336 extern void
02337 cwh_stab_set_linenum(ST *st, INT32 lineno)
02338 {
02339 USRCPOS *pos;
02340 char *file_name;
02341 static char *last_file_name = NULL;
02342 static INT32 last_file_num = 0 ;
02343 INT32 local_line_num;
02344
02345 pos = cwh_auxst_srcpos_addr(st);
02346 file_name = global_to_local_file(lineno);
02347 local_line_num = global_to_local_line_number(lineno);
02348 if (last_file_name != file_name)
02349 last_file_num = cwh_dst_enter_path(file_name);
02350
02351 USRCPOS_filenum(*pos) = last_file_num ;
02352 USRCPOS_linenum(*pos) = local_line_num;
02353
02354 last_file_name = file_name ;
02355 }
02356
02357
02358
02359
02360
02361
02362
02363
02364
02365
02366
02367 static void
02368 cwh_stab_formal_ref(ST * st, BOOL host)
02369 {
02370
02371 TY_IDX ty ;
02372
02373 if (!ST_is_value_parm(st)) {
02374
02375 ty = ST_type(st);
02376
02377 if (TY_kind(ty) == KIND_SCALAR || TY_kind(ty) == KIND_STRUCT)
02378 Set_ST_sclass(st, SCLASS_FORMAL_REF);
02379 else
02380 Set_ST_type(st, cwh_types_mk_pointer_TY(ty, host));
02381 }
02382 }
02383
02384
02385
02386
02387
02388
02389
02390
02391
02392
02393
02394
02395
02396
02397
02398 static void
02399 cwh_stab_full_split(ST *c, enum list_name list)
02400 {
02401 ITEM * el;
02402 INT32 nf;
02403 INT32 i;
02404 LIST *l;
02405 FIELDS fp_table ;
02406
02407 l = cwh_auxst_get_list(c,l_COMLIST);
02408 if ( l == NULL)
02409 return;
02410
02411 nf = L_num(l);
02412 if (nf == 0)
02413 return ;
02414
02415 if (ST_is_initialized(c) || TY_is_volatile(ST_type(c))) {
02416 cwh_stab_mk_flds(c,list);
02417 return ;
02418 }
02419
02420 fp_table = (FIELDS) malloc ( sizeof(FIELD_ITEM) * nf) ;
02421
02422 i = 0 ;
02423 el = NULL ;
02424
02425 while ((el = cwh_auxst_next_element(c,el,list)) != NULL ) {
02426
02427 ST *st = I_element(el);
02428 FIELDS_fp(i) = st;
02429 FIELDS_first_offset(i) = ST_ofst(st);
02430 FIELDS_last_offset(i) = ST_ofst(st) + TY_size(ST_type(st)) - 1;
02431 i ++ ;
02432 }
02433
02434 DevAssert((i==nf),(" cant count"));
02435
02436
02437
02438 cwh_stab_find_overlaps(fp_table,nf);
02439
02440
02441
02442
02443
02444
02445 if (cwh_stab_split_common(c,fp_table,nf)) {
02446
02447 el = NULL ;
02448 while ((el = cwh_auxst_next_element(c,el,l_SPLITLIST)) != NULL ) {
02449
02450 cwh_stab_mk_flds(I_element(el),l_COMLIST);
02451 }
02452
02453 cwh_stab_mk_flds(c,l_SPLITLIST);
02454
02455 L_num(l) = 0 ;
02456 L_first(l) = NULL ;
02457 L_last(l) = NULL ;
02458
02459 } else
02460 cwh_stab_mk_flds(c,list);
02461
02462 free(fp_table);
02463
02464 }
02465
02466
02467
02468
02469
02470
02471
02472
02473
02474
02475
02476
02477
02478 static void
02479 cwh_stab_find_overlaps(FIELDS fp_table, INT32 nf)
02480 {
02481 INT32 i,j,first;
02482 INT64 last_offset;
02483 INT64 first_offset;
02484
02485 first = 0;
02486 first_offset = FIELDS_first_offset(0);
02487 last_offset = FIELDS_last_offset(0);
02488
02489 for ( i = 1; i < nf; i++ ) {
02490
02491 if ( FIELDS_first_offset(i) > last_offset ) {
02492
02493 for ( j = first; j < i; j++ ) {
02494
02495 FIELDS_first_offset(j) = first_offset;
02496 FIELDS_last_offset(j) = last_offset;
02497 }
02498
02499 first = i;
02500 first_offset = FIELDS_first_offset(i);
02501 last_offset = FIELDS_last_offset(i);
02502
02503 } else if ( FIELDS_last_offset(i) > last_offset )
02504 last_offset = FIELDS_last_offset(i);
02505 }
02506
02507 for ( j = first; j < i; j++ ) {
02508
02509 FIELDS_first_offset(j) = first_offset;
02510 FIELDS_last_offset(j) = last_offset;
02511 }
02512 }
02513
02514
02515
02516
02517
02518
02519
02520
02521
02522
02523
02524
02525
02526
02527
02528
02529
02530
02531
02532 static BOOL
02533 cwh_stab_split_common(ST * c, FIELDS fp_table, INT32 nf)
02534 {
02535 ST * e ;
02536 ST * nc ;
02537 TY_IDX ty ;
02538 TY_IDX tc ;
02539
02540 INT32 i,j,k ;
02541 INT32 first ;
02542 INT32 full_split_last_array = -1;
02543 INT64 first_offset;
02544 INT64 last_offset;
02545 BOOL seen_a_split = FALSE ;
02546
02547
02548 tc = ST_type(c);
02549 first = 0;
02550 first_offset = FIELDS_first_offset(0);
02551 last_offset = FIELDS_last_offset(0);
02552 full_split_last_array = -1;
02553
02554
02555 for ( i = 1; i < nf; i++ ) {
02556
02557 if ( FIELDS_last_offset(i) > last_offset ) {
02558
02559 e = FIELDS_fp(i);
02560 ty = ST_type(e);
02561
02562 if ((TY_kind(ty) == KIND_ARRAY) &&
02563 (FIELDS_first_offset(i) % TY_align(tc) == 0)) {
02564
02565 if ( TY_size(ty) >= FE_Full_Split_Array_Limit ) {
02566
02567 BOOL split = FALSE;
02568
02569 for ( j = 0; j < FE_Full_Split_Limits_Count; j++ ) {
02570
02571 if ( FIELDS_first_offset(i) - first_offset
02572 < FE_Full_Split_Limits [j].rel_offset
02573 - FE_Full_Split_Limits [j].delta )
02574 break;
02575
02576 if ( need_to_split ( FIELDS_first_offset(i),
02577 first_offset,
02578 FE_Full_Split_Limits [j].rel_offset,
02579 FE_Full_Split_Limits [j].delta ) ) {
02580 split = TRUE;
02581 seen_a_split = TRUE;
02582 break;
02583 }
02584
02585 for (k = full_split_last_array;
02586 k >= 0;
02587 k = FIELDS_prev_array_index(k) ) {
02588
02589 if ( need_to_split (FIELDS_first_offset(i),
02590 FIELDS_first_offset(k),
02591 FE_Full_Split_Limits [j].rel_offset,
02592 FE_Full_Split_Limits [j].delta ) ) {
02593 split = TRUE;
02594 seen_a_split = TRUE;
02595 break;
02596 }
02597 }
02598 if ( split )
02599 break;
02600 }
02601
02602 if ( split ) {
02603
02604 nc = cwh_stab_split_ST(c,
02605 FIELDS_first_offset(first),
02606 FIELDS_last_offset(i-1));
02607 cwh_stab_emit_split(nc,fp_table,first, i-1);
02608 cwh_auxst_add_item(c,nc, l_SPLITLIST);
02609 if (ST_is_thread_private(c)) Set_ST_is_thread_private(nc);
02610 first = i;
02611 first_offset = FIELDS_first_offset(i);
02612 full_split_last_array = -1;
02613 }
02614
02615 FIELDS_prev_array_index(i) = full_split_last_array;
02616 full_split_last_array = i;
02617 }
02618 }
02619 last_offset = FIELDS_last_offset(i);
02620 }
02621 }
02622
02623 if (seen_a_split) {
02624 nc = cwh_stab_split_ST(c,
02625 FIELDS_first_offset(first),
02626 FIELDS_last_offset(i-1));
02627 cwh_stab_emit_split(nc,fp_table,first, i-1);
02628 cwh_auxst_add_item(c,nc, l_SPLITLIST);
02629 }
02630
02631 return seen_a_split ;
02632 }
02633
02634
02635
02636
02637
02638
02639
02640
02641
02642
02643
02644 static BOOL
02645 need_to_split (INT64 cur_offset,
02646 INT64 base_offset,
02647 INT64 rel_offset,
02648 int delta )
02649 {
02650 BOOL split;
02651 INT64 offset;
02652
02653 offset = cur_offset - base_offset;
02654 offset = offset % rel_offset;
02655
02656 split = ( offset < delta ) || ( offset > ( rel_offset - delta ) );
02657
02658 return split;
02659 }
02660
02661
02662
02663
02664
02665
02666
02667
02668
02669
02670 static void
02671 cwh_stab_dump_FIELDS(FIELDS fp_table, INT32 from, INT32 to)
02672 {
02673 ST *st;
02674 INT32 i ;
02675
02676 for ( i = from; i <= to; i++ ) {
02677
02678 st = FIELDS_fp(i);
02679
02680 printf (" %d - ",i);
02681
02682 printf (" f_off: %16llx, l_off: %16llx, prev %4d,",
02683 FIELDS_first_offset(i),
02684 FIELDS_last_offset(i),
02685 FIELDS_prev_array_index(i));
02686 if (st)
02687 printf (" ST: %x (%s)\n",st,ST_name(st));
02688 else
02689 printf (" ST: <none>\n");
02690
02691 }
02692 }
02693
02694
02695
02696
02697
02698
02699
02700
02701
02702
02703
02704
02705
02706
02707 static void
02708 cwh_stab_emit_split(ST * c, FIELDS fp_table, INT32 from, INT32 to)
02709 {
02710
02711 INT32 i ;
02712 ST * e ;
02713 INT64 off;
02714
02715 off = FIELDS_first_offset(from);
02716
02717 for (i = from ; i <= to; i ++) {
02718 e = FIELDS_fp(i);
02719 Set_ST_ofst(e, (ST_ofst(e) - off));
02720 Set_ST_base(e, c);
02721 cwh_auxst_add_item(c,e,l_COMLIST) ;
02722 }
02723 }
02724
02725
02726
02727
02728
02729
02730
02731
02732
02733
02734
02735
02736
02737 static ST *
02738 cwh_stab_split_ST(ST * c, INT64 low_off, INT64 high_off)
02739 {
02740 INT32 l ;
02741 INT64 off;
02742 char *name;
02743 ST * st;
02744
02745 l = strlen(ST_name(c));
02746
02747 name = (char *) malloc(l + 128);
02748
02749 name[0] = '_';
02750 name[1] = '_';
02751
02752 (void) strcpy(&name[2],ST_name(c));
02753 sprintf(&name[l+2], ".%lld", low_off );
02754
02755 off = high_off-low_off+1;
02756 st = cwh_stab_common_ST(name,byte_to_bit(off),TY_align(ST_type(c)));
02757
02758 Set_ST_ofst(st, 0);
02759 Set_ST_base(st, c);
02760
02761 Set_ST_is_split_common(st) ;
02762
02763 if (ST_is_thread_private(c))
02764 Set_ST_is_thread_private(st);
02765
02766 Set_TY_split(Ty_Table[ST_type(st)]);
02767
02768 free (name);
02769 return st ;
02770 }
02771
02772
02773
02774
02775
02776
02777
02778
02779
02780
02781 static ST *
02782 cwh_stab_common_ST(char *name,INT64 size, mUINT16 al)
02783 {
02784
02785 ST * st ;
02786 ST * st1;
02787 SYMTAB_IDX s=CURRENT_SYMTAB;
02788 st1 = Scope_tab[s].st;
02789
02790 st = New_ST(GLOBAL_SYMTAB);
02791 cwh_auxst_clear(st);
02792 ST_Init(st, Save_Str(name), CLASS_VAR, SCLASS_COMMON, EXPORT_PREEMPTIBLE,
02793 cwh_types_mk_common_TY(size,al));
02794
02795 Set_ST_base(st, st1);
02796 Set_ST_ofst(st, 0);
02797
02798 if (CURRENT_SYMTAB != GLOBAL_SYMTAB) {
02799 cwh_stab_pu_has_globals = TRUE;
02800 ;
02801 }
02802
02803 return st;
02804 }
02805
02806
02807
02808
02809
02810
02811
02812
02813
02814 static ST *
02815 cwh_stab_module_ST(char *name,INT64 size, mUINT16 al)
02816 {
02817
02818 ST * st ;
02819
02820 st = New_ST(GLOBAL_SYMTAB);
02821 cwh_auxst_clear(st);
02822 ST_Init(st, Save_Str(name), CLASS_VAR, SCLASS_MODULE, EXPORT_PREEMPTIBLE,
02823 cwh_types_mk_module_TY(size,al));
02824
02825 Set_ST_base(st, st);
02826 Set_ST_ofst(st, 0);
02827
02828 if (CURRENT_SYMTAB != GLOBAL_SYMTAB) {
02829 cwh_stab_pu_has_globals = TRUE;
02830 ;
02831 }
02832
02833 return st;
02834 }
02835
02836
02837
02838
02839
02840
02841
02842
02843
02844
02845
02846
02847
02848
02849
02850
02851
02852
02853
02854
02855
02856
02857 static void
02858 cwh_stab_altres_offset(ST *st, BOOL hosted)
02859 {
02860 ITEM * et;
02861
02862 BOOL change ;
02863 BOOL same ;
02864 BOOL allF4C4 ;
02865 BOOL isF8 ;
02866 BOOL isC4 ;
02867 TY_IDX ty ;
02868
02869 if (ST_has_nested_ref(st) && ! hosted)
02870 return;
02871
02872 ty = ST_type(st);
02873
02874 if (TY_kind(ty) == KIND_STRUCT)
02875 return ;
02876
02877 DevAssert((TY_kind(ty) == KIND_SCALAR),("Only scalars"));
02878
02879
02880
02881
02882 if (Altbase_ST == NULL)
02883 Altbase_ST = ST_base(st);
02884 else if (Altbase_ST != ST_base(st))
02885 Set_ST_base(st, Altbase_ST);
02886
02887
02888
02889
02890 allF4C4 = (TY_mtype(ty) == MTYPE_C4) ||
02891 (TY_mtype(ty) == MTYPE_F4) ;
02892
02893 isF8 = (TY_mtype(ty) == MTYPE_F8);
02894 isC4 = (TY_mtype(ty) == MTYPE_C4);
02895
02896
02897
02898
02899
02900 et = NULL;
02901 same = TRUE ;
02902
02903 while ((et = cwh_auxst_next_element(ST_base(st),et,l_RETURN_TEMPS)) != NULL ) {
02904
02905 TY_IDX tyi = ST_type(I_element(et));
02906
02907 allF4C4 = allF4C4 &&
02908 ((TY_mtype(tyi) == MTYPE_C4) ||
02909 (TY_mtype(tyi) == MTYPE_F4)) ;
02910
02911 isF8 = isF8 ||
02912 (TY_mtype(tyi) == MTYPE_F8) ;
02913
02914 isC4 = isC4 ||
02915 (TY_mtype(tyi) == MTYPE_C4) ;
02916
02917 same = same && (ty == tyi);
02918 }
02919
02920 Set_ST_auxst_altentry_shareTY(ST_base(st),same);
02921
02922
02923
02924
02925 change = FALSE ;
02926
02927 TYPE_ID bt = TY_mtype(ty);
02928 TY_IDX tb = ST_type(ST_base(st));
02929 TY& t = Ty_Table[tb];
02930
02931 if (MTYPE_is_integral(bt)) {
02932 if (TY_size(tb) < TY_size(Be_Type_Tbl(MTYPE_I8))) {
02933
02934 Set_TY_size(t, TY_size(Be_Type_Tbl(MTYPE_I8)));
02935 change = TRUE;
02936 }
02937
02938 } else if (!same) {
02939 if (!allF4C4) {
02940 if (isC4 && isF8) {
02941 if (TY_size(tb) < TY_size(Be_Type_Tbl(MTYPE_C8))) {
02942
02943 Set_TY_size(t, TY_size(Be_Type_Tbl(MTYPE_C8)));
02944 change = TRUE;
02945 }
02946 }
02947 }
02948 }
02949
02950
02951
02952 if (TY_size(tb) <= TY_size(ty)) {
02953
02954 Set_TY_size(t, TY_size(ty));
02955 change = TRUE;
02956 }
02957
02958 cwh_stab_altres_offset_comp(st,allF4C4);
02959 cwh_auxst_add_item(ST_base(st),st,l_RETURN_TEMPS);
02960
02961
02962
02963 if (change) {
02964
02965 et = NULL ;
02966 while ((et = cwh_auxst_next_element(ST_base(st),et,l_RETURN_TEMPS)) != NULL ) {
02967 cwh_stab_altres_offset_comp(I_element(et),allF4C4);
02968 }
02969 }
02970 }
02971
02972
02973
02974
02975
02976
02977
02978
02979
02980
02981
02982
02983
02984
02985 static void
02986 cwh_stab_altres_offset_comp(ST *st, BOOL allF4C4)
02987 {
02988 TY_IDX ty;
02989 TY_IDX tb;
02990 TYPE_ID bt ;
02991
02992 ty = ST_type(st);
02993 bt = TY_mtype(ty);
02994 tb = ST_type(ST_base(st));
02995
02996 if (MTYPE_is_complex(bt)) {
02997 if (bt == MTYPE_C4)
02998 if (TY_size(tb) > 8)
02999 Set_ST_ofst(st, 8);
03000
03001 } else if (MTYPE_is_float(bt)) {
03002 if (bt == MTYPE_F4)
03003 if (TY_size(tb) > 4 && !allF4C4)
03004 Set_ST_ofst(st, 4);
03005
03006 } else
03007 Set_ST_ofst(st, TY_size(Be_Type_Tbl(MTYPE_I8)) - TY_size(ty));
03008 }
03009
03010
03011
03012
03013
03014
03015
03016
03017
03018
03019
03020
03021
03022
03023
03024
03025
03026
03027
03028
03029
03030
03031
03032
03033 extern TY_IDX
03034 cwh_stab_altentry_TY(ST *st, BOOL expr)
03035 {
03036 TY_IDX tr;
03037 TY_IDX ty;
03038 TY_IDX base;
03039
03040 TYPE_ID max;
03041 TYPE_ID bt ;
03042
03043 ty = ST_type(st);
03044
03045 DevAssert((TY_kind(ty) == KIND_SCALAR),("Only scalars"));
03046
03047 base = ST_type(ST_base(st));
03048 bt = TY_mtype(ty);
03049 max = bt ;
03050
03051 if (MTYPE_is_complex(bt)) {
03052 if (!expr) {
03053 if (TY_size(base) == 8)
03054 max = MTYPE_C4;
03055 else
03056 max = MTYPE_FQ;
03057 }
03058
03059 } else if (MTYPE_is_float(bt)) {
03060 if (TY_size(base) == 4)
03061 max = MTYPE_F4;
03062 else if (TY_size(base) == 8) {
03063 max = MTYPE_F8;
03064 if (ST_ofst(st) == 0 && bt == MTYPE_F4)
03065 max = MTYPE_C4;
03066 } else
03067 max = MTYPE_FQ;
03068 } else
03069 max = MTYPE_I8;
03070
03071 tr = Be_Type_Tbl(max);
03072
03073 return tr;
03074 }
03075
03076
03077
03078
03079
03080
03081
03082
03083
03084
03085
03086
03087
03088 static void
03089 cwh_stab_distrib_pragmas(ST *st)
03090 {
03091 TY_IDX ty;
03092 WN_ITER *stmt_iter;
03093 WN *stmt, *wn;
03094 PREG_det preg;
03095
03096 ty = ST_type(st);
03097
03098 if (ST_sclass(st) == SCLASS_FORMAL)
03099 ty = TY_pointed(ty);
03100
03101 DevAssert((TY_kind(ty)==KIND_ARRAY),("distribute of non-array"));
03102
03103 stmt_iter = WN_WALK_StmtIter(decl_distribute_pragmas);
03104 while(stmt_iter != NULL) {
03105 stmt_iter = WN_WALK_StmtNext(stmt_iter);
03106 if (stmt_iter) {
03107 stmt= WN_ITER_wn(stmt_iter);
03108 if (stmt!=NULL) {
03109 switch(WN_opcode(stmt)) {
03110 case OPC_XPRAGMA:
03111 case OPC_PRAGMA:
03112 WN_st_idx(stmt) = ST_st_idx(st);
03113 if (WN_pragma(stmt)==WN_PRAGMA_DISTRIBUTE_RESHAPE)
03114 Set_ST_is_reshaped(st);
03115 break;
03116 default:
03117 DevAssert((0),("unexpected distribute pragma"));
03118 }
03119 }
03120 }
03121 }
03122
03123
03124
03125 cwh_block_append_given_id(decl_distribute_pragmas,First_Block,FALSE);
03126 decl_distribute_pragmas = NULL;
03127
03128
03129
03130 preg = cwh_auxst_distr_preg(st);
03131 wn = cwh_load_distribute_temp();
03132 wn = WN_CreateStid( OPC_I4STID, preg.preg, preg.preg_st, preg.preg_ty, wn);
03133 cwh_block_append_given_id(wn,First_Block,FALSE);
03134
03135
03136
03137 if (preg_for_distribute.preg==-1) {
03138 preg_for_distribute=cwh_preg_next_preg(MTYPE_I4, NULL, NULL);
03139 }
03140 wn = cwh_load_distribute_temp();
03141 wn = WN_CreateStid( OPC_I4STID, preg_for_distribute.preg,
03142 preg_for_distribute.preg_st, preg_for_distribute.preg_ty, wn);
03143 cwh_block_append_given_id(wn,First_Block,FALSE);
03144
03145
03146
03147 Set_PU_mp_needs_lno (Get_Current_PU ());
03148 Set_FILE_INFO_needs_lno (File_info);
03149 }
03150
03151
03152
03153
03154
03155
03156
03157
03158
03159 extern WN *
03160 cwh_load_distribute_temp(void)
03161 {
03162 TY_IDX ty;
03163 WN *rtrn;
03164
03165 ty = Be_Type_Tbl(MTYPE_I4);
03166
03167 if (st_for_distribute_temp == NULL) {
03168 st_for_distribute_temp = Gen_Temp_Symbol(ty,TY_name(ty));
03169 cwh_auxst_clear(st_for_distribute_temp);
03170 }
03171 rtrn = WN_CreateLdid(OPC_I4I4LDID, 0, st_for_distribute_temp, ty);
03172 return rtrn;
03173 }
03174
03175
03176
03177
03178
03179
03180
03181
03182
03183
03184
03185
03186
03187
03188 static ST *
03189 cwh_stab_altentry_temp(char * name, BOOL hosted)
03190 {
03191 ST * st;
03192 TY_IDX ty;
03193
03194 TYPE t ;
03195 INT32 size ;
03196
03197 size = byte_to_bit(TY_size(Be_Type_Tbl(MTYPE_CQ)));
03198
03199 if (Altbase_ST == NULL) {
03200
03201 ty = cwh_types_mk_equiv_TY(size);
03202 st = cwh_stab_address_temp_ST(".cq_base.",ty , FALSE);
03203 Set_ST_base(st, st);
03204 cwh_stab_to_list_of_equivs(st, hosted) ;
03205 Altbase_ST = st;
03206 }
03207
03208 t = fei_descriptor(0,Basic,size,C_omplex,0,0);
03209 st = New_ST(CURRENT_SYMTAB);
03210 cwh_auxst_clear(st);
03211 ST_Init (st, Save_Str(name), CLASS_VAR, SCLASS_AUTO, EXPORT_LOCAL, cast_to_TY(t_TY(t)));
03212 Set_ST_base(st, Altbase_ST);
03213 Set_ST_ofst(st, 0);
03214
03215 return st;
03216 }
03217
03218
03219
03220
03221
03222
03223
03224
03225
03226
03227 static void
03228 cwh_stab_to_list_of_equivs(ST *st, BOOL hosted)
03229 {
03230 LIST ** l = &Equivalences ;
03231
03232 if (hosted)
03233 l = &Hosted_Equivalences ;
03234
03235 cwh_auxst_add_to_list(l,st,FALSE);
03236 }
03237
03238
03239
03240
03241
03242
03243
03244
03245
03246
03247 void
03248 cwh_stab_set_tylist_for_entries(ST *proc)
03249 {
03250
03251 ITEM *en = NULL;
03252
03253 cwh_auxst_set_tylist(proc);
03254 while ((en = cwh_auxst_next_element(proc,en,l_ALTENTRY)) != NULL) {
03255 cwh_auxst_set_tylist(I_element(en));
03256 }
03257
03258 }
03259
03260
03261
03262
03263
03264
03265
03266
03267
03268
03269
03270
03271
03272 extern void
03273 cwh_stab_emit_commons_and_equivalences(SYMTAB_IDX level)
03274 {
03275
03276 void (*fp) (ST *, enum list_name) = &cwh_stab_mk_flds;
03277
03278 if (FE_Full_Split)
03279 fp = &cwh_stab_full_split ;
03280
03281 if (level == GLOBAL_SYMTAB)
03282 cwh_stab_emit_list(&Commons_Already_Seen,l_COMLIST,fp);
03283
03284 else {
03285
03286 cwh_stab_emit_list(&Equivalences,l_EQVLIST,&cwh_stab_mk_flds);
03287
03288
03289
03290
03291
03292
03293 if (level == HOST_LEVEL)
03294 cwh_stab_emit_list(&Hosted_Equivalences,l_EQVLIST,&cwh_stab_mk_flds);
03295
03296 }
03297 }
03298
03299
03300
03301
03302
03303
03304
03305
03306
03307
03308
03309 static void
03310 cwh_stab_emit_list(LIST ** lp, enum list_name list, void (*fp) (ST *, enum list_name))
03311 {
03312 ITEM * i;
03313
03314 if (*lp != NULL ) {
03315 i = L_first(*lp);
03316
03317 while (i != NULL) {
03318 fp (I_element(i),list) ;
03319 i = I_next(i);
03320 }
03321
03322 cwh_auxst_free_list(lp);
03323 }
03324 }
03325
03326
03327
03328
03329
03330
03331
03332
03333
03334
03335 static void
03336 cwh_stab_mk_flds(ST * blk, enum list_name list)
03337 {
03338 ITEM * el;
03339 INT32 nf;
03340 INT32 i;
03341 LIST *l;
03342
03343 l = cwh_auxst_get_list(blk, list);
03344 if (l == NULL)
03345 return ;
03346
03347 nf = L_num(l);
03348
03349 if (nf == 0)
03350 return ;
03351
03352
03353
03354 i = 0 ;
03355 el = NULL ;
03356
03357 while ((el = cwh_auxst_next_element(blk,el,list)) != NULL ) {
03358 cwh_types_mk_element(blk,I_element(el));
03359 i ++ ;
03360 }
03361
03362 DevAssert((i == nf), (" can't count"));
03363 }
03364
03365
03366
03367
03368
03369
03370
03371
03372
03373
03374
03375
03376
03377
03378 static ST*
03379 cwh_stab_earlier_common(char *name_string, BOOL is_duplicate)
03380 {
03381 ITEM * i;
03382
03383 if (Commons_Already_Seen!= NULL ) {
03384 i = L_first(Commons_Already_Seen);
03385
03386 while (i != NULL) {
03387 ST *st = I_element(i) ;
03388 if (ST_auxst_is_module_data(st) || is_duplicate)
03389 if (strcmp(ST_name(st),name_string) == 0) {
03390 return st ;
03391 }
03392 i = I_next(i);
03393 }
03394 }
03395
03396 return NULL;
03397 }
03398
03399
03400
03401
03402
03403
03404
03405
03406
03407
03408
03409
03410
03411
03412 static ST *
03413 cwh_stab_seen_common_element(ST *c, INT64 offset, char* name)
03414 {
03415 ITEM * el = NULL;
03416 ST * st ;
03417
03418 while ((el = cwh_auxst_next_element(c,el,l_COMLIST)) != NULL ) {
03419 st = I_element(el);
03420 if (ST_ofst(st) == offset)
03421 if (strcmp(ST_name(st),name) == 0)
03422 return st ;
03423
03424 }
03425 return NULL ;
03426 }
03427
03428
03429
03430 ST *
03431 cwh_stab_seen_derived_type_or_imported_var(ST *c, char* name)
03432 {
03433 ITEM * el = NULL;
03434 ST * st ;
03435
03436 while ((el = cwh_auxst_next_element(c,el,l_TYMDLIST)) != NULL ) {
03437 st = I_element(el);
03438 if (ST_pu(c) == ST_pu(ST_base(st)))
03439 if (strcmp(ST_name(st),name) == 0)
03440 return st ;
03441 }
03442 return NULL ;
03443 }
03444
03445
03446
03447
03448
03449
03450
03451
03452
03453
03454
03455 extern ST *
03456 cwh_stab_mk_fn_0args(char *name, ST_EXPORT eclass,SYMTAB_IDX level,TY_IDX rty)
03457 {
03458 ST * st ;
03459 PU_IDX pu ;
03460 TY_IDX ty ;
03461
03462 ty = cwh_types_mk_procedure_TY(rty,
03463 0,
03464 TRUE,
03465 FALSE);
03466
03467 pu = cwh_stab_mk_pu(ty, level);
03468 st = New_ST(GLOBAL_SYMTAB);
03469 cwh_auxst_clear(st);
03470 Set_PU_need_unparsed(pu);
03471
03472 ST_Init (st,
03473 Save_Str(name),
03474 CLASS_FUNC,
03475 SCLASS_EXTERN,
03476 eclass,
03477 (TY_IDX)pu);
03478
03479 Set_ST_ofst(st, 0);
03480 return(st);
03481 }
03482
03483
03484
03485
03486
03487
03488
03489
03490
03491
03492 static PU_IDX
03493 cwh_stab_mk_pu(TY_IDX pty, SYMTAB_IDX level)
03494 {
03495 PU_IDX pu_idx;
03496 PU& pu = New_PU (pu_idx);
03497
03498 PU_Init(pu, pty, level);
03499
03500 return (pu_idx);
03501 }
03502
03503
03504
03505
03506
03507
03508
03509
03510
03511
03512
03513
03514
03515
03516 INTPTR
03517 fei_smt_parameter(char * name_string,
03518 TYPE type,
03519 INTPTR con_idx,
03520 INT32 Class,
03521 INT32 lineno)
03522
03523 {
03524 INT32 len;
03525 char * name;
03526 char * name1;
03527 STB_pkt *p;
03528 ST * st;
03529 TY_IDX ty;
03530 WN * wn;
03531
03532
03533 ty = cast_to_TY(t_TY(type));
03534
03535 if (TY_is_character(ty)) {
03536 st = cast_to_ST(con_idx);
03537 }
03538 else {
03539 p = cast_to_STB(con_idx);
03540
03541 if (p->form == is_ST) {
03542 st = cast_to_ST(p->item);
03543 }
03544 else if (p->form == is_WN) {
03545 wn = cast_to_WN(p->item);
03546 st = cwh_stab_const_ST(wn);
03547 }
03548 }
03549
03550
03551
03552
03553
03554
03555
03556
03557
03558 name = NULL;
03559 name = cwh_auxst_stem_name(st, name);
03560
03561 if (name == NULL) {
03562 len = strlen(name_string);
03563 name1 = (char *) malloc(len+1);
03564 strcpy(name1, name_string);
03565 cwh_auxst_stem_name(st, name1);
03566 cwh_auxst_add_item(Procedure_ST,st,l_DST_PARMLIST);
03567 }
03568 else {
03569 len = strlen(name_string);
03570 len += strlen(name);
03571 ++len;
03572 name1 = (char *) malloc(len+1);
03573 strcpy(name1, name_string);
03574 strcat(name1, " ");
03575 strcat(name1, name);
03576 free(name);
03577 cwh_auxst_stem_name(st, name1);
03578 }
03579
03580 ST * parast = New_ST(CURRENT_SYMTAB);
03581 ST_Init(parast,
03582 Save_Str(name_string),
03583 CLASS_PARAMETER,
03584 SCLASS_UNKNOWN,
03585 EXPORT_LOCAL,
03586 ty);
03587 Set_ST_base(parast,st);
03588 Set_ST_sclass(parast,ST_sclass(st));
03589
03590 cwh_stab_set_linenum(st,lineno);
03591
03592 return(cast_to_int(st));
03593 }
03594
03595
03596
03597
03598
03599
03600
03601
03602
03603
03604
03605
03606 INTPTR
03607 fei_interface(char * name_string,
03608 INT32 nitems,
03609 INT32 kind_interface,
03610 INT32 is_imported)
03611 {
03612 ST * st;
03613 TY_IDX ty;
03614 STB_pkt *p;
03615 WN * wn;
03616 WN * wn1;
03617 OPCODE opc;
03618 WN * block;
03619 int i = 0;
03620 int k;
03621
03622
03623 st = New_ST(CURRENT_SYMTAB);
03624
03625 cwh_auxst_clear(st);
03626
03627 ty = 0;
03628
03629 ST_Init(st, Save_Str(name_string), CLASS_VAR, SCLASS_AUTO, EXPORT_LOCAL, ty);
03630 Set_ST_ofst(st, 0);
03631
03632 if (is_imported)
03633 Set_ST_is_external(st);
03634
03635 if (kind_interface == 1)
03636 Set_ST_is_assign_interface(st);
03637 else if (kind_interface == 2)
03638 Set_ST_is_operator_interface(st);
03639 else if (kind_interface == 3)
03640 Set_ST_is_u_operator_interface(st);
03641
03642 p = cwh_stab_packet(cast_to_void(st),is_ST) ;
03643
03644
03645 opc = OPCODE_make_op(OPR_INTERFACE,MTYPE_V,MTYPE_V);
03646 wn = WN_Create(opc,nitems);
03647 WN_st_idx(wn) = ST_st_idx(st);
03648
03649 if (nitems !=0)
03650 for (k = nitems -1 ; k >= 0 ; k --) {
03651 wn1 = cwh_stk_pop_WN();
03652 WN_kid(wn,k) = wn1;
03653 }
03654
03655 cwh_block_append_given_id(wn,First_Block,FALSE);
03656
03657 return (cast_to_int(p));
03658 }
03659
03660
03661 void fei_set_in_interface_processing()
03662 {
03663 interface_pu = 1;
03664 }
03665
03666
03667 void fei_reset_in_interface_processing()
03668 {
03669 interface_pu = 0;
03670 }