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 * 07-May-95 - Original Version 00042 * 00043 * Description: 00044 * 00045 * See st2f.h for a description of the exported functions and 00046 * variables. This module translates ST nodes into variable and 00047 * function declarations (ST2F_decl_translate), and gets the 00048 * lvalue for a variable or function when directly referenced in 00049 * an expression (ST2F_use_translate). We provide a special 00050 * interface to deal with pseudo registers (pregs), but some 00051 * symbols must be handled by the context in which they appear, 00052 * since this context uniquely determines the reference (e.g. 00053 * labels has label-numbers in the WN tree). 00054 * 00055 * Possibly necessary TODO: sym_consts are only partially 00056 * supported at the moment. 00057 * 00058 * Fortran pointers are represented by two declarations, where 00059 * one declares the pointer object (which is allocated memory) 00060 * and one denotes the pointer dereference which also serves to 00061 * specify the type of object to which is pointed: 00062 * 00063 * INTEGER*4 a(12) 00064 * POINTER(p, a) 00065 * 00066 * Only "p" occurs in the WHIRL symbol table. We have to derive 00067 * "a" from "p" (with a name derived from "p"). The w2cf_symtab.h 00068 * facilities coordinates this for us. 00069 * 00070 * It is crucial that names with external linkage are generated 00071 * with the same name between compilation units. For this reason 00072 * we give file-scope variables precedence in name-ownership (i.e. 00073 * they are entered first into the symbol-table). If, despite this 00074 * effort, there are clashes between names with static and external 00075 * linkage, the generated code may not be compilable or correctly 00076 * executable. TODO: Emit warning about this. 00077 * 00078 * ==================================================================== 00079 * ==================================================================== 00080 */ 00081 00082 #ifdef _KEEP_RCS_ID 00083 /*REFERENCED*/ 00084 #endif 00085 00086 #include <ctype.h> 00087 #include <alloca.h> 00088 #include <set> // STL 00089 #include <vector> // STL 00090 using std::set; 00091 using std::vector; 00092 #include <string> 00093 00094 #include "whirl2f_common.h" 00095 #include "PUinfo.h" 00096 #include "tcon2f.h" 00097 #include "wn2f.h" 00098 #include "ty2f.h" 00099 #include "st2f.h" 00100 #include "init2f.h" 00101 #include "cxx_memory.h" 00102 #include "be_symtab.h" 00103 #include "unparse_target.h" 00104 #include "ty_ftn.h" 00105 00106 typedef std::set<int> PARMSET; 00107 00108 /* Defined in ty2f.c; signifies special translation of adjustable and 00109 * assumed sized arrays. 00110 */ 00111 extern BOOL Use_Purple_Array_Bnds_Placeholder; 00112 extern WN* PU_Body; 00113 /*------- Fwd refs for miscellaneous utilities ------------------------*/ 00114 /*---------------------------------------------------------------------*/ 00115 00116 static BOOL ST2F_Is_Dummy_Procedure(ST *st) ; 00117 static void ST2F_Declare_Return_Type(TOKEN_BUFFER tokens,TY_IDX return_ty, const char* name) ; 00118 00119 /*------- Handlers for references to and declarations of symbols ------*/ 00120 /*---------------------------------------------------------------------*/ 00121 00122 static void ST2F_ignore(TOKEN_BUFFER tokens, ST *st); 00123 00124 static void ST2F_decl_error(TOKEN_BUFFER tokens, ST *st); 00125 static void ST2F_decl_var(TOKEN_BUFFER tokens, ST *st); 00126 static void ST2F_decl_func(TOKEN_BUFFER tokens, ST *st); 00127 static void ST2F_decl_const(TOKEN_BUFFER tokens, ST *st); 00128 static void ST2F_decl_type (TOKEN_BUFFER tokens, ST *st); 00129 static void ST2F_decl_parameter (TOKEN_BUFFER tokens, ST *st); 00130 00131 static void ST2F_use_error(TOKEN_BUFFER tokens, ST *st); 00132 static void ST2F_use_var(TOKEN_BUFFER tokens, ST *st); 00133 static void ST2F_use_func(TOKEN_BUFFER tokens, ST *st); 00134 static void ST2F_use_const(TOKEN_BUFFER tokens, ST *st); 00135 static void ST2F_use_block(TOKEN_BUFFER tokens, ST *st); 00136 00137 TOKEN_BUFFER param_tokens = New_Token_Buffer(); 00138 00139 /* The following maps every ST class to a function that can translate 00140 * it to C. 00141 */ 00142 typedef void (*ST2F_HANDLER_FUNC)(TOKEN_BUFFER, ST *); 00143 00144 static const ST2F_HANDLER_FUNC ST2F_Decl_Handler[CLASS_COUNT] = 00145 { 00146 &ST2F_ignore, /* CLASS_UNK == 0x00 */ 00147 &ST2F_decl_var, /* CLASS_VAR == 0x01 */ 00148 &ST2F_decl_func, /* CLASS_FUNC == 0x02 */ 00149 &ST2F_decl_const, /* CLASS_CONST == 0x03 */ 00150 &ST2F_decl_error, /* CLASS_PREG == 0x04 */ 00151 &ST2F_decl_error, /* CLASS_BLOCK == 0x05 */ 00152 &ST2F_decl_error, /* CLASS_NAME == 0x06 */ 00153 &ST2F_decl_error, /* CLASS_MODULE == 0x07*/ 00154 &ST2F_decl_type, /* CLASS_TYPE ==0x08 */ 00155 &ST2F_decl_parameter, /*CLASS_PARAMETER == 0x08 */ 00156 }; /* ST2F_Decl_Handler */ 00157 00158 static const ST2F_HANDLER_FUNC ST2F_Use_Handler[CLASS_COUNT] = 00159 { 00160 &ST2F_ignore, /* CLASS_UNK == 0x00 */ 00161 &ST2F_use_var, /* CLASS_VAR == 0x01 */ 00162 &ST2F_use_func, /* CLASS_FUNC == 0x02 */ 00163 &ST2F_use_const, /* CLASS_CONST == 0x03 */ 00164 &ST2F_use_error, /* CLASS_PREG == 0x04 */ 00165 &ST2F_use_block, /* CLASS_BLOCK == 0x05 */ 00166 &ST2F_use_error /* CLASS_NAME == 0x06 */ 00167 }; /* ST2F_Use_Handler */ 00168 00169 00170 /*----------- hidden routines to handle ST declarations ---------------*/ 00171 /*---------------------------------------------------------------------*/ 00172 static void 00173 ST2F_Define_Preg(const char *name, TY_IDX ty) 00174 { 00175 /* Declare a preg of the given type, name and offset as a local 00176 * (register) variable in the current context. 00177 */ 00178 TOKEN_BUFFER decl_tokens = New_Token_Buffer(); 00179 UINT current_indent = Current_Indentation(); 00180 00181 Set_Current_Indentation(PUinfo_local_decls_indent); 00182 Append_F77_Indented_Newline(PUinfo_local_decls, 1, NULL/*label*/); 00183 Append_Token_String(decl_tokens, name); 00184 TY2F_translate(decl_tokens, ty); 00185 Append_And_Reclaim_Token_List(PUinfo_local_decls, &decl_tokens); 00186 Set_Current_Indentation(current_indent); 00187 } /* ST2F_Define_Preg */ 00188 00189 00190 static void 00191 ST2F_ignore(TOKEN_BUFFER tokens, ST *st) 00192 { 00193 return; /* Just ignore it, i.e. do nothing! */ 00194 } /* ST2F_ignore */ 00195 00196 static void 00197 ST2F_decl_error(TOKEN_BUFFER tokens, ST *st) 00198 { 00199 ASSERT_DBG_FATAL(FALSE, 00200 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00201 ST_sym_class(st), "ST2F_decl_error")); 00202 } /* ST2F_decl_error */ 00203 00204 static void 00205 ST2F_decl_var(TOKEN_BUFFER tokens, ST *st) 00206 { 00207 INITO_IDX inito; 00208 const char *pointee_name; 00209 const char *st_name = W2CF_Symtab_Nameof_St(st); 00210 TOKEN_BUFFER decl_tokens = New_Token_Buffer(); 00211 TY_IDX ty_rt = ST_type(st); 00212 ST *base; 00213 00214 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_VAR, 00215 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00216 ST_sym_class(st), "ST2F_decl_var")); 00217 00218 if (Current_scope > GLOBAL_SYMTAB) 00219 { 00220 ASSERT_DBG_FATAL(!PUINFO_RETURN_TO_PARAM || st != PUINFO_RETURN_PARAM, 00221 (DIAG_W2F_DECLARE_RETURN_PARAM, "ST2F_decl_var")); 00222 } 00223 00224 base = ST_base(st); 00225 00226 00227 // if (ST_sclass(st)==SCLASS_DGLOBAL && Stab_Is_Common_Block(base)) 00228 // goto INITPRO; 00229 00230 /* Declare the variable */ 00231 00232 if (Stab_Is_Common_Block(st)) 00233 { 00234 /* Declare a common block */ 00235 TY2F_Translate_Common(decl_tokens, st_name, ST_type(st)); 00236 } 00237 else if (Stab_Is_Equivalence_Block(st)) 00238 { 00239 if (ST_is_return_var(st)) 00240 TY2F_Translate_Equivalence(decl_tokens, 00241 ST_type(st), 00242 TRUE /* alternate return point */); 00243 else 00244 TY2F_Translate_Equivalence(decl_tokens, 00245 ST_type(st), 00246 FALSE /* regular equivalence */); 00247 } 00248 else if (TY_Is_Pointer(ty_rt) && 00249 !TY_is_f90_pointer(ty_rt) && 00250 ST_sclass(st) != SCLASS_FORMAL) 00251 { 00252 /* Declare pointee with the name specified in the symbol table */ 00253 // pointee_name = W2CF_Symtab_Nameof_St_Pointee(st); 00254 Append_Token_String(decl_tokens, st_name); 00255 00256 if (TY_ptr_as_array(Ty_Table[ty_rt])) 00257 TY2F_translate(decl_tokens, 00258 Stab_Array_Of(TY_pointed(ty_rt), 0/*size*/)); 00259 else 00260 TY2F_translate(decl_tokens, TY_pointed(ty_rt)); 00261 00262 Append_F77_Indented_Newline(decl_tokens, 1, NULL/*label*/); 00263 00264 /* Declare the pointer object */ 00265 // Append_Token_String(decl_tokens, "POINTER"); 00266 // Append_Token_Special(decl_tokens, '('); 00267 // Append_Token_String(decl_tokens, st_name); 00268 // Append_Token_Special(decl_tokens, ','); 00269 // Append_Token_String(decl_tokens, pointee_name); 00270 // Append_Token_Special(decl_tokens, ')'); 00271 } 00272 else if (ST_sclass(st) == SCLASS_FORMAL && !ST_is_value_parm(st)) 00273 { 00274 /* ie, regular f77 dummy argument,expect pointer TY */ 00275 /* To counteract the Fortran call-by-reference semantics */ 00276 00277 ASSERT_DBG_FATAL(TY_Is_Pointer(ty_rt), 00278 (DIAG_W2F_UNEXPECTED_TYPE_KIND, 00279 TY_kind(ty_rt), "ST2F_decl_var")); 00280 Append_Token_String(decl_tokens, st_name); 00281 if (TY_kind(TY_pointed(ST_type(st))) == KIND_FUNCTION) 00282 { 00283 Prepend_Token_String(decl_tokens, "EXTERNAL"); 00284 } 00285 else 00286 { 00287 TY_IDX ty; 00288 TY_IDX ty1 = TY_pointed(ty_rt); 00289 00290 if (TY_Is_Pointer(ty1) && TY_ptr_as_array(Ty_Table[ty1])) 00291 { 00292 /* Handle ptr as array parameters 00293 */ 00294 ty = Stab_Array_Of(TY_pointed(ty1), 0/*size*/); 00295 } 00296 else 00297 { 00298 ty = TY_pointed(ty_rt); 00299 } 00300 if (Use_Purple_Array_Bnds_Placeholder && TY_Is_Array(ty)) 00301 TY2F_Translate_Purple_Array(decl_tokens, st, ty); 00302 else { 00303 TY2F_translate(decl_tokens, ty); 00304 } 00305 } 00306 } 00307 else if (ST2F_Is_Dummy_Procedure(st)) 00308 { 00309 TYLIST tylist_idx = TY_tylist(TY_pointed(ST_type(st))); 00310 TY_IDX rt = TY_IDX_ZERO; 00311 if (tylist_idx != (TYLIST) 0) 00312 rt = TYLIST_type(Tylist_Table[tylist_idx]); 00313 00314 ST2F_Declare_Return_Type(tokens,rt,ST_name(st)); 00315 } 00316 else if (ST_sclass(st) == SCLASS_EXTERN && 00317 (strcmp(ST_name(st), "__mp_cur_numthreads") == 0 || 00318 strcmp(ST_name(st), "__mp_sug_numthreads") == 0)) 00319 { 00320 /* Special case */ 00321 st_name = Concat3_Strings(ST_name(st), "_func", "$"); 00322 Append_Token_String(decl_tokens, st_name); 00323 TY2F_translate(decl_tokens, ST_type(st)); 00324 Append_F77_Indented_Newline(decl_tokens, 1, NULL/*label*/); 00325 Append_Token_String(decl_tokens, "EXTERNAL "); 00326 Append_Token_String(decl_tokens, st_name); 00327 } 00328 else 00329 { 00330 /* Declare as specified in the symbol table */ 00331 Append_Token_String(decl_tokens, st_name); 00332 if (Use_Purple_Array_Bnds_Placeholder && TY_Is_Array(ST_type(st))) 00333 TY2F_Translate_Purple_Array(decl_tokens, st, ST_type(st)); 00334 else { 00335 TY2F_translate(decl_tokens, ST_type(st)); 00336 } 00337 } 00338 TY2F_Prepend_Structures(decl_tokens); 00339 Append_And_Reclaim_Token_List(tokens, &decl_tokens); 00340 00341 if (ST_is_allocatable(st)) { 00342 TOKEN_BUFFER decl_tokens=New_Token_Buffer(); 00343 Append_Token_String(decl_tokens,"ALLOCATABLE"); 00344 Append_Token_String(decl_tokens,ST_name(st)); 00345 Append_Token_Special(tokens, '\n'); 00346 Append_F77_Indented_Newline(tokens, 0, NULL); 00347 Append_And_Reclaim_Token_List(tokens,&decl_tokens); } 00348 00349 00350 if (ST_is_private(st)) { 00351 TOKEN_BUFFER decl_tokens=New_Token_Buffer(); 00352 Append_Token_String(decl_tokens,"PRIVATE"); 00353 Append_Token_String(decl_tokens,ST_name(st)); 00354 Append_Token_Special(tokens, '\n'); 00355 Append_F77_Indented_Newline(tokens, 0, NULL); 00356 Append_And_Reclaim_Token_List(tokens,&decl_tokens); } 00357 00358 if (ST_is_my_pointer(st)) { 00359 TOKEN_BUFFER decl_tokens=New_Token_Buffer(); 00360 Append_Token_String(decl_tokens,"POINTER"); 00361 Append_Token_String(decl_tokens,ST_name(st)); 00362 Append_Token_Special(tokens, '\n'); 00363 Append_F77_Indented_Newline(tokens, 0, NULL); 00364 Append_And_Reclaim_Token_List(tokens,&decl_tokens); } 00365 00366 if (ST_is_f90_target(st)) { 00367 TOKEN_BUFFER decl_tokens=New_Token_Buffer(); 00368 Append_Token_String(decl_tokens,"TARGET"); 00369 Append_Token_String(decl_tokens,ST_name(st)); 00370 Append_Token_Special(tokens, '\n'); 00371 Append_F77_Indented_Newline(tokens, 0, NULL); 00372 Append_And_Reclaim_Token_List(tokens,&decl_tokens); } 00373 00374 00375 /* Save it's value between calls, if so specified, unless it is 00376 * an equivalence, in which case it is implicitly SAVE. 00377 */ 00378 if (!Stab_Is_Equivalence_Block(st) && 00379 !ST_is_parameter(st) && 00380 (ST_sclass(st) == SCLASS_FSTATIC || 00381 ST_sclass(st) == SCLASS_PSTATIC)) 00382 { 00383 Append_F77_Indented_Newline(tokens, 1, NULL/*label*/); 00384 Append_Token_String(tokens, "SAVE"); 00385 Append_Token_String(tokens, st_name); 00386 } 00387 00388 INITPRO: 00389 /* Generate a DATA statement for initializers */ 00390 if (ST_is_parameter(st)){ 00391 inito = Find_INITO_For_Symbol(st); 00392 if (inito != (INITO_IDX) 0) { 00393 TOKEN_BUFFER decl_tokens=New_Token_Buffer(); 00394 PARAMETER2F_translate(decl_tokens,inito); 00395 Append_F77_Indented_Newline(tokens, 1, NULL); 00396 Append_And_Reclaim_Token_List(tokens,&decl_tokens); } 00397 } 00398 else { 00399 if (ST_is_initialized(st) && 00400 !Stab_No_Linkage(st) ) 00401 // (!TY_Is_Structured(ST_type(st)) || /*structure can be initialized--FMZ*/ 00402 // (Stab_Is_Common_Block(st) || 00403 // Stab_Is_Equivalence_Block(st))) 00404 { 00405 inito = Find_INITO_For_Symbol(st); 00406 if (inito != (INITO_IDX) 0) 00407 INITO2F_translate(Data_Stmt_Tokens, inito); 00408 } 00409 } 00410 } /* ST2F_decl_var */ 00411 00412 static void 00413 ST2F_decl_type(TOKEN_BUFFER tokens, ST *st) 00414 { 00415 const char *st_name = W2CF_Symtab_Nameof_St(st); 00416 TOKEN_BUFFER decl_tokens = New_Token_Buffer(); 00417 TY_IDX ty_rt = ST_type(st); 00418 00419 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_TYPE, 00420 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00421 ST_sym_class(st), "ST2F_decl_type")); 00422 00423 if (Current_scope > GLOBAL_SYMTAB) 00424 ASSERT_DBG_FATAL(!PUINFO_RETURN_TO_PARAM || st != PUINFO_RETURN_PARAM, 00425 (DIAG_W2F_DECLARE_RETURN_PARAM, "ST2F_decl_var")); 00426 00427 if (Use_Purple_Array_Bnds_Placeholder && TY_Is_Array(ST_type(st))) 00428 TY2F_Translate_Purple_Array(decl_tokens, st, ST_type(st)); 00429 else { 00430 TY2F_translate(decl_tokens, ST_type(st),1); 00431 } 00432 TY2F_Prepend_Structures(decl_tokens); 00433 Append_And_Reclaim_Token_List(tokens, &decl_tokens); 00434 00435 } /* ST2F_decl_type */ 00436 00437 static void 00438 ST2F_decl_parameter(TOKEN_BUFFER tokens, ST *st) 00439 { 00440 const char *st_name = W2CF_Symtab_Nameof_St(st); 00441 TOKEN_BUFFER decl_tokens = New_Token_Buffer(); 00442 TY_IDX ty_rt = ST_type(st); 00443 ST *base = ST_base(st); 00444 00445 00446 Append_Token_String(decl_tokens,st_name); 00447 if (Use_Purple_Array_Bnds_Placeholder && TY_Is_Array(ST_type(st))) 00448 TY2F_Translate_Purple_Array(decl_tokens, st, ST_type(st)); 00449 else 00450 TY2F_translate(decl_tokens, ST_type(st)); 00451 TY2F_Prepend_Structures(decl_tokens); 00452 Append_And_Reclaim_Token_List(tokens, &decl_tokens); 00453 /*other attributes that are allowed with the PARAMETER attribute are: 00454 * DIMENSION 00455 * PRIVATE 00456 * PUBLIC 00457 * SAVE 00458 */ 00459 00460 if (ST_is_private(st)) { 00461 decl_tokens=New_Token_Buffer(); 00462 Append_Token_String(decl_tokens,"PRIVATE"); 00463 Append_Token_String(decl_tokens,ST_name(st)); 00464 Append_Token_Special(tokens, '\n'); 00465 Append_F77_Indented_Newline(tokens, 0, NULL); 00466 Append_And_Reclaim_Token_List(tokens,&decl_tokens); } 00467 00468 /* print out para_name = (value) */ 00469 00470 decl_tokens=New_Token_Buffer(); 00471 Append_Token_String(decl_tokens,"PARAMETER ("); 00472 Append_Token_String(decl_tokens,st_name); 00473 Append_Token_Special(decl_tokens, '=' ); 00474 TCON2F_translate(decl_tokens,STC_val(base),TY_is_logical(ST_type(st))); 00475 Append_Token_Special(decl_tokens, ')'); 00476 00477 Append_Token_Special(tokens, '\n'); 00478 Append_F77_Indented_Newline(tokens, 0, NULL); 00479 Append_And_Reclaim_Token_List(tokens,&decl_tokens); 00480 00481 } /* ST_decl_parameter */ 00482 00483 static void 00484 ST2F_decl_func(TOKEN_BUFFER tokens, ST *st) 00485 { 00486 /* This only makes sense for "external" functions in Fortran, 00487 * while we should not do anything for other functions. 00488 */ 00489 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_FUNC, 00490 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00491 ST_sym_class(st), "ST2F_decl_func")); 00492 00493 /* if f90 internal procedure, don't declare it */ 00494 00495 if (ST_export(st) == EXPORT_LOCAL_INTERNAL) 00496 return ; 00497 00498 const char *func_name = W2CF_Symtab_Nameof_St(st); 00499 TY_IDX return_ty; 00500 00501 00502 /* Specify whether or not the function is EXTERNAL */ 00503 00504 if ((ST_sclass(st) == SCLASS_EXTERN) && 00505 (strcmp(ST_name(st),"_ALLOCATE")!=0) && 00506 (strcmp(ST_name(st),"_END")!=0) && 00507 (strcmp(ST_name(st),"_DEALLOCATE") !=0)&& 00508 (strcmp(ST_name(st),"_CLOSE") !=0 ) && 00509 (strcmp(ST_name(st),"_OPEN")!=0 )) 00510 { 00511 if(strncmp("_",func_name,1)!=0) { /*don't declare function name begin with "_" as external*/ 00512 Append_Token_String(tokens, "EXTERNAL"); 00513 Append_Token_String(tokens, func_name); 00514 } 00515 } 00516 00517 /* Specify the function return type, unless it is void */ 00518 00519 return_ty = W2X_Unparse_Target->Func_Return_Type(ST_pu_type(st)); 00520 if (strncmp("_",func_name,1)!=0) 00521 ST2F_Declare_Return_Type(tokens,return_ty,func_name); 00522 00523 } /* ST2F_decl_func */ 00524 00525 static void 00526 ST2F_decl_const(TOKEN_BUFFER tokens, ST *st) 00527 { 00528 /* A CLASS_CONST symbol never has a name, and as such cannot be 00529 * declared! 00530 */ 00531 ASSERT_DBG_FATAL(FALSE, 00532 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00533 ST_sym_class(st), "ST2F_decl_const")); 00534 } /* ST2F_decl_const */ 00535 00536 00537 /*---------------- hidden routines to handle ST uses ------------------*/ 00538 /*---------------------------------------------------------------------*/ 00539 00540 static void 00541 ST2F_use_error(TOKEN_BUFFER tokens, ST *st) 00542 { 00543 ASSERT_DBG_FATAL(FALSE, 00544 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00545 ST_sym_class(st), "ST2F_use_error")); 00546 } /* ST2F_use_error */ 00547 00548 bool haveCommonBlockName(ST *st) { 00549 static set<std::string> nameSet; 00550 if (st==NULL) { 00551 nameSet.clear(); 00552 return false; 00553 } 00554 for (set<std::string>::iterator it=nameSet.begin(); it!=nameSet.end(); ++it){ 00555 if (*it==ST_name(st)) { 00556 return true; 00557 } 00558 } 00559 nameSet.insert(ST_name(st)); 00560 return false; 00561 } 00562 00563 static void 00564 ST2F_use_var(TOKEN_BUFFER tokens, ST *st) 00565 { 00566 TY_IDX return_ty; 00567 00568 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_VAR, 00569 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00570 ST_sym_class(st), "ST2F_use_var")); 00571 00572 /* Note that we do not trust the ST_is_return_var() flag, 00573 * unless the return_ty is non-void. This is due to purple, 00574 * which may change a function into a subroutine. 00575 */ 00576 return_ty = PUINFO_RETURN_TY; 00577 if ((return_ty != (TY_IDX) 0 && 00578 TY_kind(return_ty) == KIND_SCALAR && 00579 ST_is_return_var(st)) || 00580 (PUINFO_RETURN_TO_PARAM && st == PUINFO_RETURN_PARAM)) 00581 { 00582 /* If we have a reference to the implicit return-variable, then 00583 * refer to the function return value. 00584 */ 00585 Append_Token_String(tokens, PUINFO_FUNC_NAME); 00586 } 00587 else if (ST_keep_name_w2f(st)) 00588 { 00589 /* Use the name as it is (after making it a legal fortran name) 00590 * and do not mark this variable as having been referenced. 00591 * Assume this a special symbol not to be declared. 00592 */ 00593 Append_Token_String(tokens, 00594 WHIRL2F_make_valid_name(ST_name(st),WN2F_F90_pu && !ST_is_temp_var(st))); 00595 if (Stab_Is_Based_At_Common_Or_Equivalence(st)) { 00596 if (!haveCommonBlockName((ST *)ST_base(st))) { 00597 Set_BE_ST_w2fc_referenced((ST *)ST_base(st)); 00598 } 00599 } 00600 else 00601 Set_BE_ST_w2fc_referenced(st); //June 00602 } 00603 else if (Stab_Is_Based_At_Common_Or_Equivalence(st)) 00604 { 00605 /* Reference the corresponding field in the common block (we do this 00606 * only to ensure that the name referenced matches the one used for 00607 * the member of the common-block at the place of declaration). Note 00608 * that will full splitting, the original common block can be found 00609 * at ST_full(ST_base(st)). 00610 */ 00611 WN2F_CONTEXT context = INIT_WN2F_CONTEXT; 00612 00613 WN2F_Offset_Symref(tokens, 00614 ST_base(st), /* base-symbol */ 00615 Stab_Pointer_To(ST_type(ST_base(st))), /* base-type */ 00616 ST_type(st), /* object-type */ 00617 ST_ofst(st), /* object-ofst */ 00618 context); 00619 Set_BE_ST_w2fc_referenced((ST *)ST_base(st)); 00620 } 00621 else if (ST_sclass(st) == SCLASS_EXTERN && 00622 (strcmp(ST_name(st), "__mp_cur_numthreads") == 0 || 00623 strcmp(ST_name(st), "__mp_sug_numthreads") == 0)) 00624 { 00625 /* Special case */ 00626 Append_Token_String(tokens, Concat3_Strings(ST_name(st), "_func", "$")); 00627 Append_Token_Special(tokens, '('); 00628 Append_Token_Special(tokens, ')'); 00629 Set_BE_ST_w2fc_referenced(st); 00630 } 00631 else 00632 { 00633 Append_Token_String(tokens, W2CF_Symtab_Nameof_St(st)); 00634 00635 if (strcmp(TY_name(ST_type(st)),".Namelist.")) 00636 00637 Set_BE_ST_w2fc_referenced(st); 00638 } 00639 } /* ST2F_use_var */ 00640 00641 00642 static void 00643 ST2F_use_func(TOKEN_BUFFER tokens, ST *st) 00644 { 00645 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_FUNC, 00646 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00647 ST_sym_class(st), "ST2F_use_func")); 00648 00649 Append_Token_String(tokens, W2CF_Symtab_Nameof_St(st)); 00650 Set_BE_ST_w2fc_referenced(st); 00651 } 00652 00653 static void 00654 ST2F_use_const(TOKEN_BUFFER tokens, ST *st) 00655 { 00656 TY_IDX ty_idx = ST_type(st); 00657 TY& ty = Ty_Table[ty_idx]; 00658 00659 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_CONST, 00660 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00661 ST_sym_class(st), "ST2F_use_const")); 00662 00663 /* A CLASS_CONST symbol never has a name, so just emit the value. 00664 */ 00665 00666 if (TY_mtype(ty) == MTYPE_STR && TY_align(ty_idx) > 1) 00667 { 00668 /* This must be a hollerith constant */ 00669 TCON2F_hollerith(tokens, STC_val(st)); 00670 } 00671 else 00672 { 00673 TCON2F_translate(tokens, STC_val(st), TY_is_logical(ty)); 00674 } 00675 } /* ST2F_use_const */ 00676 00677 00678 static void 00679 ST2F_use_block(TOKEN_BUFFER tokens, ST *st) 00680 { 00681 /* with f90 at -O2, CLASS_BLOCK can appear on LDAs etc. in IO */ 00682 /* put out something, so whirlbrowser doesn't fall over */ 00683 00684 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_BLOCK, 00685 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00686 ST_sym_class(st), "ST2F_use_block")); 00687 00688 00689 Append_Token_String(tokens, ST_name(st)); 00690 } 00691 00692 /*------------------------ exported routines --------------------------*/ 00693 /*---------------------------------------------------------------------*/ 00694 00695 00696 void 00697 ST2F_initialize() 00698 { 00699 00700 return; 00701 } /* ST2F_initialize */ 00702 00703 void 00704 ST2F_finalize() 00705 { 00706 return; 00707 } 00708 00709 void 00710 ST2F_use_translate(TOKEN_BUFFER tokens, ST *st) 00711 { 00712 ST2F_Use_Handler[ST_sym_class(st)](tokens, st); 00713 } 00714 00715 void 00716 ST2F_deref_translate(TOKEN_BUFFER tokens, ST *st) 00717 { 00718 ASSERT_DBG_FATAL(ST_sym_class(st)==CLASS_VAR && 00719 TY_Is_Pointer(ST_type(st)) && 00720 !Stab_Is_Based_At_Common_Or_Equivalence(st), 00721 (DIAG_W2F_UNEXPECTED_SYMCLASS, 00722 ST_sym_class(st), "ST2F_deref_translate")); 00723 00724 /* Consider this a reference to the pointer value */ 00725 Append_Token_String(tokens, W2CF_Symtab_Nameof_St_Pointee(st)); 00726 Set_BE_ST_w2fc_referenced(st); 00727 00728 } /* ST2F_deref_translate */ 00729 00730 00731 // dispatch handler for declarations.. 00732 void 00733 ST2F_decl_translate(TOKEN_BUFFER tokens, const ST *st) 00734 { 00735 ST2F_Decl_Handler[ST_sym_class(st)](tokens, (ST *) st); 00736 } 00737 00738 static void 00739 collectst(WN *wn,PARMSET &tempset) 00740 { 00741 00742 if (!wn) return; 00743 00744 if (WN_opc_operator(wn) == OPR_LDID || 00745 WN_opc_operator(wn) == OPR_LDA) 00746 tempset.insert(WN_st_idx(wn)); 00747 else 00748 for (INT32 kidnum = 0; kidnum < WN_kid_count(wn); kidnum++) 00749 collectst(WN_kid(wn, kidnum),tempset); 00750 return; 00751 } 00752 00753 00754 static void GetStSet(ST_IDX bnd,PARMSET &tempset) 00755 { 00756 WN * stmt; 00757 WN *first_stmt = WN_first(PU_Body); 00758 WN kid; 00759 00760 stmt = first_stmt; 00761 while ((stmt !=NULL)&&((WN_operator(stmt)!=OPR_STID) 00762 ||(WN_operator(stmt) ==OPR_STID) 00763 &&strcmp(ST_name(WN_st(stmt)),ST_name(ST_ptr(bnd))))) 00764 00765 stmt = WN_next(stmt); 00766 00767 if (stmt && WN_kid(stmt,0)) 00768 collectst(WN_kid(stmt,0),tempset); 00769 } 00770 00771 void ReorderParms(ST **parms,INT32 num_params) 00772 { 00773 INT32 i; 00774 ST **reorder_parms; 00775 ST_IDX bdindex; 00776 TY_IDX ty_index; 00777 ST_IDX real_index; 00778 PARMSET::iterator runner; 00779 00780 vector<PARMSET> dependset(num_params); 00781 map<ST_IDX,int> st_idx_to_parms; 00782 PARMSET workset, tempst; 00783 00784 workset.clear(); 00785 reorder_parms = (ST **)alloca((num_params + 1) * sizeof(ST *)); 00786 for (i=0; i<num_params; i++) 00787 st_idx_to_parms[(ST_IDX)(parms[i]->st_idx)] = i; 00788 00789 for (i=0; i<num_params; i++) 00790 if (TY_kind(ST_type(parms[i])) == KIND_POINTER ){ 00791 ty_index = TY_pointed(ST_type(parms[i])); 00792 00793 if ((TY_kind(ty_index) == KIND_ARRAY) && 00794 !TY_is_character(ty_index) && 00795 !TY_is_f90_deferred_shape(ty_index)){ 00796 00797 TY& ty = Ty_Table[ty_index]; 00798 ARB_HANDLE arb_base = TY_arb(ty); 00799 ARB_HANDLE arb; 00800 INT32 dim = ARB_dimension(arb_base) ; 00801 while (dim > 0){ 00802 arb = arb_base[dim-1]; 00803 if (ARB_const_lbnd(arb)&& ARB_const_ubnd(arb)) 00804 ; 00805 else { 00806 workset.insert(i); 00807 if (!ARB_const_lbnd(arb) && !ARB_empty_lbnd(arb)){ 00808 bdindex = ARB_lbnd_var(arb); 00809 if (ST_is_temp_var(St_Table[bdindex])){ 00810 GetStSet(bdindex,tempst); 00811 runner = tempst.begin(); 00812 while (runner != tempst.end()){ 00813 if (st_idx_to_parms[*runner]!=i) 00814 dependset[i].insert(st_idx_to_parms[*runner]); 00815 ++runner; 00816 } 00817 } 00818 } 00819 00820 if (!ARB_const_ubnd(arb) && !ARB_empty_ubnd(arb)){ 00821 bdindex = ARB_ubnd_var(arb); 00822 if (ST_is_temp_var(St_Table[bdindex])){ 00823 GetStSet(bdindex,tempst); 00824 runner = tempst.begin(); 00825 while (runner != tempst.end()){ 00826 if (st_idx_to_parms[*runner]!=i) 00827 dependset[i].insert(st_idx_to_parms[*runner]); 00828 ++runner; 00829 } 00830 } 00831 } 00832 } 00833 dim--; 00834 }/*while*/ 00835 } 00836 } 00837 INT32 keep = 0; 00838 00839 for (i = 0; i<num_params; i++){ 00840 if (dependset[i].empty()){ 00841 workset.erase(i); 00842 reorder_parms[keep] = parms[i]; 00843 keep++; 00844 for (INT32 j=0; j<num_params; j++){ 00845 dependset[j].erase(i); 00846 } 00847 } 00848 } 00849 00850 PARMSET::iterator cleaner; 00851 vector<int> elems; 00852 00853 if (!workset.empty()) 00854 { 00855 runner = workset.begin(); 00856 while (runner != workset.end()) { 00857 if (dependset[*runner].empty()){ 00858 reorder_parms[keep] = parms[*runner]; 00859 keep++; 00860 cleaner = workset.begin(); 00861 while(cleaner !=workset.end()){ 00862 dependset[*cleaner].erase(*runner); 00863 ++cleaner; 00864 } 00865 elems.push_back(*runner); 00866 } 00867 ++runner; 00868 } 00869 } 00870 00871 while (!elems.empty()) 00872 { 00873 INT32 i = elems.back(); 00874 workset.erase(i); 00875 elems.pop_back(); 00876 } 00877 00878 //tempory for interface has temp variable but there is no assginment 00879 // statement kept in the interface block 00880 if (!workset.empty()){ 00881 runner = workset.begin(); 00882 while (runner != workset.end()){ 00883 reorder_parms[keep] = parms[*runner]; 00884 runner++; 00885 keep++; 00886 } 00887 } 00888 00889 for(INT32 k=0; k<num_params; k++) 00890 parms[k] = reorder_parms[k]; 00891 return; 00892 } 00893 00894 void 00895 ST2F_func_header(TOKEN_BUFFER tokens, 00896 ST *st, /* Function ST entry */ 00897 ST **params, /* Array of parameters */ 00898 INT32 num_params, /* # of parms in array */ 00899 BOOL is_altentry) /* Alternate entry point */ 00900 { 00901 /* Emit the header for a function definition or an alternate entry 00902 * point. Note that the resultant token buffer will not have 00903 * appended a newline after the function header. 00904 */ 00905 TOKEN_BUFFER header_tokens = New_Token_Buffer(); 00906 INT param, first_param, implicit_parms = 0; 00907 TY_IDX funtype = ST_pu_type(st); 00908 TY_IDX return_ty; 00909 WN *wn; 00910 WN *stmt; 00911 ST *rslt = NULL; 00912 BOOL needcom=1; 00913 BOOL has_result = 0; 00914 BOOL add_rsl_type = 0; 00915 BOOL is_module_program_unit = FALSE; 00916 00917 const char * func_n_name= W2CF_Symtab_Nameof_St(st); 00918 00919 ASSERT_DBG_FATAL(TY_kind(funtype) == KIND_FUNCTION, 00920 (DIAG_W2F_UNEXPECTED_SYMBOL, "ST2F_func_header")); 00921 00922 return_ty = W2X_Unparse_Target->Func_Return_Type(funtype); 00923 00924 /* Append the function name */ 00925 00926 Append_Token_String(header_tokens, W2CF_Symtab_Nameof_St(st)); 00927 00928 /* Emit the parameter name-list, if one is present, and skip any 00929 * implicit "length" parameters associated with character strings. 00930 * Such implicit parameters should be at the end of the parameter list. 00931 */ 00932 00933 first_param = ST2F_FIRST_PARAM_IDX(funtype); 00934 00935 if (params[first_param] != NULL) 00936 { 00937 Append_Token_Special(header_tokens, '('); 00938 for (param = first_param; 00939 param < num_params - implicit_parms; 00940 param++) 00941 { 00942 if (!ST_is_return_var(params[param])) 00943 Append_Token_String(header_tokens, 00944 W2CF_Symtab_Nameof_St(params[param])); 00945 else { 00946 rslt = params[param]; 00947 needcom = 0; 00948 } 00949 00950 if (STAB_PARAM_HAS_IMPLICIT_LENGTH(params[param])) 00951 { 00952 implicit_parms++; 00953 00954 /* is function returning character_TY? if length follows */ 00955 /* address - skip over it, but account for ',' in arg list */ 00956 00957 if ((param == first_param) && (params[param+1] != NULL)) 00958 { 00959 if (ST_is_value_parm(params[param]) && ST_is_value_parm(params[param+1])) 00960 { 00961 if (return_ty != (TY_IDX) 0 && TY_kind(return_ty) == KIND_VOID ) 00962 { 00963 param ++ ; 00964 params[param] = NULL; 00965 implicit_parms--; 00966 } 00967 } 00968 } 00969 } 00970 00971 if (param+implicit_parms+1 < num_params && needcom) 00972 Append_Token_Special(header_tokens, ','); 00973 needcom = 1; 00974 } 00975 Append_Token_Special(header_tokens, ')'); 00976 } 00977 else if (!PU_is_mainpu(Get_Current_PU()) && 00978 !ST_is_in_module(st) && 00979 !ST_is_block_data(st) || 00980 TY_kind(return_ty) != KIND_VOID) // module&&block data cannot have "()" 00981 00982 { 00983 /* Use the "()" notation for "no parameters", except for 00984 * the main program definition. 00985 */ 00986 Append_Token_Special(header_tokens, '('); 00987 Append_Token_Special(header_tokens, ')'); 00988 } 00989 00990 /* need to see if the result variable has same name with the function's 00991 * name,if it does,don't declare the result variable 00992 */ 00993 00994 if (rslt !=NULL && 00995 strcasecmp(W2CF_Symtab_Nameof_St(rslt),W2CF_Symtab_Nameof_St(st))) { 00996 has_result = 1; 00997 Append_Token_String(header_tokens,"result("); 00998 Append_Token_String(header_tokens, 00999 W2CF_Symtab_Nameof_St(rslt)); 01000 Append_Token_Special(header_tokens, ')'); 01001 } 01002 01003 /* Prepend one of the keywords ENTRY, PROGRAM, FUNCTION, or 01004 * SUBROUTINE to the function name, as is appropriate. 01005 */ 01006 01007 if (PU_is_mainpu(Get_Current_PU())) 01008 { 01009 Prepend_Token_String(header_tokens, "PROGRAM"); 01010 } 01011 else if (return_ty != (TY_IDX) 0 && TY_kind(return_ty) != KIND_VOID) 01012 { 01013 if (is_altentry) 01014 Prepend_Token_String(header_tokens, "ENTRY"); 01015 else 01016 { 01017 Prepend_Token_String(header_tokens, "Function"); 01018 01019 if (PU_recursive(Get_Current_PU())) 01020 Prepend_Token_String(header_tokens, "RECURSIVE"); 01021 01022 if (!has_result && (TY_kind(return_ty)!= KIND_ARRAY || 01023 !TY_is_character(TY_AR_etype(return_ty)))) 01024 add_rsl_type=1; 01025 } 01026 } 01027 else /* subroutine */ 01028 { 01029 if (is_altentry) 01030 Prepend_Token_String(header_tokens, "ENTRY"); 01031 else 01032 if (ST_is_in_module(st) && !PU_is_nested_func(Pu_Table[ST_pu(st)])){ 01033 Prepend_Token_String(header_tokens, "MODULE"); 01034 is_module_program_unit = TRUE; 01035 } 01036 else 01037 if (ST_is_block_data(st)) 01038 Prepend_Token_String(header_tokens, "BLOCK DATA"); 01039 else { 01040 Prepend_Token_String(header_tokens, "SUBROUTINE"); 01041 if (PU_recursive(Get_Current_PU())) 01042 Prepend_Token_String(header_tokens, "RECURSIVE"); 01043 } 01044 } 01045 01046 01047 wn=PU_Body; 01048 stmt = WN_first(wn); 01049 int k; 01050 const char *st_name; 01051 const char *st_name1; 01052 01053 /* add a use stmt corresponding to an added module in *.w2f.f 01054 * to solve the real kind problems 01055 * if the block is alter entry,do nothing. 01056 *--------fzhao 01057 */ 01058 if (!is_altentry) { 01059 Append_F77_Indented_Newline(header_tokens, 1/*empty-lines*/, NULL/*label*/); 01060 Append_Token_String(header_tokens, "use w2f__types"); 01061 } 01062 01063 while (stmt) { 01064 if (WN_operator(stmt)==OPR_USE){ 01065 st_name = W2CF_Symtab_Nameof_St(WN_st(stmt)); 01066 Append_F77_Indented_Newline(header_tokens, 1/*empty-lines*/, NULL/*label*/); 01067 Append_Token_String(header_tokens, "use"); 01068 Append_Token_String(header_tokens, st_name); 01069 if (WN_rtype(stmt) == MTYPE_B) // signals presence of the ONLY predicate 01070 Append_Token_String(header_tokens, ",only:"); 01071 else { 01072 if ( WN_kid_count(stmt) ) { 01073 Append_Token_String(header_tokens, ","); 01074 } 01075 } 01076 01077 for(k=0;k< WN_kid_count(stmt);k=k+2 ) { 01078 01079 st_name = W2CF_Symtab_Nameof_St(WN_st(WN_kid(stmt,k))); 01080 st_name1= W2CF_Symtab_Nameof_St(WN_st(WN_kid(stmt,k+1))); 01081 if (k==0) 01082 ; 01083 else 01084 Append_Token_String(header_tokens,","); 01085 if (strcmp(st_name,st_name1)) { 01086 Append_Token_String(header_tokens,st_name); 01087 Append_Token_String(header_tokens,"=>"); 01088 Append_Token_String(header_tokens, st_name1); 01089 } 01090 else 01091 Append_Token_String(header_tokens,st_name); 01092 } 01093 } 01094 stmt = WN_next(stmt); 01095 } /*while*/ 01096 01097 if (num_params) 01098 ReorderParms(params,num_params-implicit_parms); 01099 param_tokens = New_Token_Buffer(); 01100 01101 if (!is_altentry) 01102 { 01103 /* Emit parameter declarations, indented and on a new line */ 01104 Append_F77_Indented_Newline(header_tokens, 1, NULL/*label*/); 01105 Append_Token_String(header_tokens, "IMPLICIT NONE"); 01106 01107 if (is_module_program_unit){ 01108 Append_F77_Indented_Newline(header_tokens, 1, NULL/*label*/); 01109 Append_Token_String(header_tokens, "SAVE"); 01110 is_module_program_unit = FALSE; 01111 } 01112 01113 for (param = first_param; param < num_params -implicit_parms; param++) { 01114 01115 Append_F77_Indented_Newline(param_tokens, 1, NULL/*label*/); 01116 if (params[param] ) { 01117 if (strcasecmp(W2CF_Symtab_Nameof_St(params[param]),W2CF_Symtab_Nameof_St(st))) { 01118 01119 ST2F_decl_translate(param_tokens, params[param]); 01120 01121 if (ST_is_optional_argument( params[param])) { 01122 Append_F77_Indented_Newline(param_tokens, 1, NULL/*label*/); 01123 Append_Token_String(param_tokens,"OPTIONAL "); 01124 Append_Token_String(param_tokens, 01125 W2CF_Symtab_Nameof_St(params[param])); 01126 } 01127 if (ST_is_intent_in_argument( params[param])) { 01128 TOKEN_BUFFER temp_tokens = New_Token_Buffer(); 01129 Append_F77_Indented_Newline(temp_tokens, 1, NULL/*label*/); 01130 Append_Token_String(temp_tokens,"INTENT(IN) "); 01131 Append_Token_String(temp_tokens, 01132 W2CF_Symtab_Nameof_St(params[param])); 01133 Append_And_Reclaim_Token_List(param_tokens, &temp_tokens); 01134 01135 } 01136 if (ST_is_intent_out_argument( params[param])) { 01137 Append_F77_Indented_Newline(param_tokens, 1, NULL/*label*/); 01138 Append_Token_String(param_tokens,"INTENT(OUT) "); 01139 Append_Token_String(param_tokens, 01140 W2CF_Symtab_Nameof_St(params[param])); 01141 } 01142 01143 } 01144 else 01145 if (!strcasecmp(W2CF_Symtab_Nameof_St(rslt),W2CF_Symtab_Nameof_St(st))) 01146 ST2F_decl_translate(param_tokens, params[param]); 01147 } 01148 } 01149 01150 } 01151 01152 if (add_rsl_type){ 01153 TOKEN_BUFFER temp_tokens = New_Token_Buffer(); 01154 Append_F77_Indented_Newline(param_tokens, 1, NULL/*label*/); 01155 if (TY_Is_Pointer(return_ty)) 01156 TY2F_translate(temp_tokens, Stab_Mtype_To_Ty(TY_mtype(return_ty))); 01157 else { 01158 if (TY_kind(return_ty)==KIND_ARRAY) { 01159 if (TY_is_character(TY_AR_etype(return_ty))) 01160 ; 01161 else 01162 TY2F_translate(temp_tokens,TY_AR_etype(return_ty)); 01163 } 01164 else 01165 TY2F_translate(temp_tokens, return_ty); 01166 } 01167 Append_Token_String(temp_tokens, W2CF_Symtab_Nameof_St(st)); 01168 Append_And_Reclaim_Token_List(param_tokens, &temp_tokens); 01169 } 01170 01171 Append_Token_Special(tokens, '\n'); 01172 Append_F77_Indented_Newline(tokens, 0, NULL); 01173 Append_And_Reclaim_Token_List(tokens, &header_tokens); 01174 01175 } /* ST2F_func_header */ 01176 01177 void 01178 ST2F_Use_Preg(TOKEN_BUFFER tokens, 01179 TY_IDX preg_ty, 01180 PREG_IDX preg_idx) 01181 { 01182 /* Append the name of the preg to the token-list and declare the 01183 * preg in the current PU context unless it is already declared. 01184 */ 01185 const char *preg_name; 01186 01187 preg_ty = PUinfo_Preg_Type(preg_ty, preg_idx); 01188 preg_name = W2CF_Symtab_Nameof_Preg(preg_ty, preg_idx); 01189 01190 /* Declare the preg, if it has not already been declared */ 01191 if (!PUinfo_Is_Preg_Declared(preg_ty, preg_idx)) 01192 { 01193 ST2F_Define_Preg(preg_name, preg_ty); 01194 PUinfo_Set_Preg_Declared(preg_ty, preg_idx); 01195 } 01196 01197 Append_Token_String(tokens, preg_name); 01198 } /* ST2F_Use_Preg */ 01199 01200 void 01201 ST2F_Declare_Tempvar(TY_IDX ty, UINT idx) 01202 { 01203 TOKEN_BUFFER tmp_tokens = New_Token_Buffer(); 01204 UINT current_indent = Current_Indentation(); 01205 01206 Set_Current_Indentation(PUinfo_local_decls_indent); 01207 Append_F77_Indented_Newline(PUinfo_local_decls, 1, NULL/*label*/); 01208 if (TY_Is_Pointer(ty)) 01209 { 01210 /* Assume we never need to dereference the pointer, or else we 01211 * need to maintain a map from tmp_idx->pointee_idx (new temporary 01212 * for pointee_idx), so declare this temporary variable to be of 01213 * an integral type suitable for a pointer value. 01214 */ 01215 ty = Stab_Mtype_To_Ty(Pointer_Mtype); 01216 } 01217 Append_Token_String(tmp_tokens, W2CF_Symtab_Nameof_Tempvar(idx)); /* name */ 01218 TY2F_translate(tmp_tokens, ty); /* type */ 01219 if (ST_is_in_module(Scope_tab[Current_scope].st) && 01220 !PU_is_nested_func(Pu_Table[ST_pu(Scope_tab[Current_scope].st)])) 01221 { 01222 Append_F77_Indented_Newline(tmp_tokens, 1, NULL/*label*/); 01223 Append_Token_String(tmp_tokens,"PRIVATE "); 01224 Append_Token_String(tmp_tokens, W2CF_Symtab_Nameof_Tempvar(idx)); 01225 } 01226 01227 Append_And_Reclaim_Token_List(PUinfo_local_decls, &tmp_tokens); 01228 Set_Current_Indentation(current_indent); 01229 } /* ST2F_Declare_Tempvar */ 01230 01231 01232 static BOOL 01233 ST2F_Is_Dummy_Procedure(ST *st) 01234 { 01235 /* Does this ST represent a dummy procedure ? */ 01236 01237 BOOL dummy = FALSE; 01238 01239 if (ST_sclass(st) == SCLASS_FORMAL && ST_is_value_parm(st)) 01240 { 01241 TY_IDX ty = ST_type(st); 01242 01243 if (TY_kind(ty) == KIND_POINTER) 01244 if (TY_kind(TY_pointed(ty)) == KIND_FUNCTION) 01245 dummy = TRUE ; 01246 } 01247 return dummy ; 01248 } 01249 01250 01251 static void 01252 ST2F_Declare_Return_Type(TOKEN_BUFFER tokens,TY_IDX return_ty, const char *name) 01253 { 01254 /* The TY represents a dummy procedure or a function return type */ 01255 01256 if (return_ty != (TY_IDX) 0) 01257 { 01258 if (TY_kind(return_ty) != KIND_VOID) 01259 { 01260 TOKEN_BUFFER decl_tokens = New_Token_Buffer(); 01261 01262 Append_F77_Indented_Newline(tokens, 1, NULL/*label*/); 01263 Append_Token_String(decl_tokens, name); 01264 01265 /* Use integral type for pointer returns */ 01266 01267 if (TY_Is_Pointer(return_ty)) 01268 TY2F_translate(decl_tokens, Stab_Mtype_To_Ty(TY_mtype(return_ty))); 01269 else { 01270 TY2F_translate(decl_tokens, return_ty); 01271 } 01272 TY2F_Prepend_Structures(decl_tokens); 01273 Append_And_Reclaim_Token_List(tokens, &decl_tokens); 01274 } 01275 } 01276 } 01277 01278 void 01279 ST2F_output_keyword(TOKEN_BUFFER tokens, ST * st) 01280 { 01281 TCON strcon = STC_val(st); 01282 INT32 strlen ; 01283 INT32 stridx ; 01284 const char *strbase; 01285 char *keyword; 01286 01287 strlen = Targ_String_Length(strcon); 01288 strbase = Targ_String_Address(strcon); 01289 keyword = (char *) alloca(strlen +1); 01290 for (stridx = 0; stridx<strlen;stridx++) 01291 keyword[stridx] = strbase[stridx]; 01292 keyword[stridx] = '\0'; 01293 Append_Token_String(tokens,keyword); 01294 #if 0 01295 TCON2F_trans_to_keyword(tokens, STC_val(st)); 01296 #endif 01297 01298 } 01299