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 * 12-Apr-95 - Original Version 00042 * 00043 * Description: 00044 * 00045 * Translate a WN statement subtree to Fortran by means of an inorder 00046 * recursive descent traversal of the WHIRL IR. Note that the routines 00047 * handle expressions and loads/stores are in separate source files. 00048 * Recursive translation of WN nodes should only use WN2F_Translate()! 00049 * 00050 * Conventions: 00051 * 00052 * + Newline characters or comments are prepended to a stmt in 00053 * the translation of that stmt. 00054 * 00055 * 00056 * ==================================================================== 00057 * ==================================================================== 00058 */ 00059 00060 #ifdef _KEEP_RCS_ID 00061 /*REFERENCED*/ 00062 #endif 00063 00064 #include <iostream> 00065 00066 #include <alloca.h> 00067 #include "whirl2f_common.h" 00068 #include "const.h" /* For FOR_ALL_CONSTANTS */ 00069 #include "pf_cg.h" 00070 #include "w2cf_parentize.h" 00071 #include "PUinfo.h" /* In be/whirl2c directory */ 00072 #include "wn2f.h" 00073 #include "st2f.h" 00074 #include "ty2f.h" 00075 #include "tcon2f.h" 00076 #include "wn2f_stmt.h" 00077 #include "wn2f_load_store.h" 00078 #include "wn2f_io.h" 00079 #include "wn2f_pragma.h" 00080 #include "init2f.h" 00081 #include "be_symtab.h" 00082 #include "intrn_info.h" /* INTR macros */ 00083 #include "unparse_target.h" 00084 #include "ty_ftn.h" 00085 00086 extern WN_MAP W2F_Frequency_Map; /* Defined in w2f_driver.c */ 00087 extern WN_MAP *W2F_Construct_Map; /* Defined in w2f_driver.c */ 00088 extern BOOL W2F_Prompf_Emission; /* Defined in w2f_driver.c */ 00089 extern BOOL W2F_Emit_Cgtag; /* Defined in w2f_driver.c */ 00090 00091 extern TOKEN_BUFFER param_tokens; 00092 00093 static const char WN2F_Purple_Region_Name[] = "prp___region"; 00094 static const char unnamed_interface[] = "unnamed interface"; 00095 00096 #define WN_pragma_nest(wn) WN_pragma_arg1(wn) 00097 00098 00099 /*----------------- Call and return site utilities --------------------*/ 00100 /*---------------------------------------------------------------------*/ 00101 00102 /* Lists of return and call sites for the current PU, 00103 * initialized by means of "PUinfo.h" facilities. 00104 */ 00105 static RETURNSITE *WN2F_Next_ReturnSite = NULL; 00106 static CALLSITE *WN2F_Prev_CallSite = NULL; 00107 00108 00109 static void 00110 WN2F_Load_Return_Reg(TOKEN_BUFFER tokens, 00111 TY_IDX return_ty, 00112 const char * var_name, 00113 STAB_OFFSET var_offset, 00114 MTYPE preg_mtype, 00115 PREG_IDX preg_offset, 00116 WN2F_CONTEXT context) 00117 { 00118 /* Load a preg value from the given variable at the given offset 00119 * from the base-address of the variable. 00120 */ 00121 const TY_IDX preg_ty = Stab_Mtype_To_Ty(preg_mtype); 00122 TOKEN_BUFFER tmp_tokens = New_Token_Buffer(); 00123 FLD_PATH_INFO *path ; 00124 00125 /* Cast the rhs to the type of the preg, and dereference the 00126 * resultant address. 00127 */ 00128 Append_Token_String(tmp_tokens, var_name); 00129 Append_Token_Special(tmp_tokens, WN2F_F90_pu ? '%' : '.'); 00130 path = TY2F_Get_Fld_Path(return_ty,preg_ty,var_offset); 00131 TY2F_Translate_Fld_Path(tmp_tokens,path,FALSE,FALSE,FALSE,context); 00132 (void)TY2F_Free_Fld_Path(path); 00133 00134 /* Assign the variable to the preg */ 00135 ST2F_Use_Preg(tokens, preg_ty, preg_offset); 00136 Append_Token_Special(tokens, '='); 00137 Append_And_Reclaim_Token_List(tokens, &tmp_tokens); 00138 00139 } /* WN2F_Load_Return_Reg */ 00140 00141 static void 00142 WN2F_Callsite_Directives(TOKEN_BUFFER tokens, 00143 WN *call_wn, 00144 ST *func_st) 00145 { 00146 if (WN_Call_Inline(call_wn)) 00147 { 00148 Append_F77_Directive_Newline(tokens, "C*$*"); 00149 Append_Token_String(tokens, "inline"); 00150 Append_Token_Special(tokens, '('); 00151 ST2F_use_translate(tokens, func_st); 00152 Append_Token_Special(tokens, ')'); 00153 } 00154 else if (WN_Call_Dont_Inline(call_wn)) 00155 { 00156 Append_F77_Directive_Newline(tokens, "C*$*"); 00157 Append_Token_String(tokens, "noinline"); 00158 Append_Token_Special(tokens, '('); 00159 ST2F_use_translate(tokens, func_st); 00160 Append_Token_Special(tokens, ')'); 00161 } 00162 } /* WN2F_Callsite_Directives */ 00163 00164 00165 static void 00166 WN2F_Function_Call_Lhs(TOKEN_BUFFER rhs_tokens, /* The function call */ 00167 TY_IDX return_ty, /* The function return type */ 00168 WN2F_CONTEXT context) 00169 { 00170 /* PRECONDITION: return_ty != Void_Type and the function does not 00171 * return its value to an address given as an implicit argument. 00172 * 00173 * Prepend to the rhs_tokens the assignments necessary to store 00174 * the function-call return value into a variable or registers. 00175 * If the return-value is not used anywhere, then assign it to 00176 * a (dummy) temporary variable. 00177 */ 00178 TOKEN_BUFFER lhs_tokens = New_Token_Buffer(); 00179 BOOL return_value_is_used = TRUE; 00180 UINT tmpvar_idx; 00181 00182 /* Information pertaining to the return registers used for this 00183 * return type. 00184 */ 00185 const RETURN_PREG return_info = PUinfo_Get_ReturnPreg(return_ty); 00186 const MTYPE preg_mtype = RETURN_PREG_mtype(&return_info, 0); 00187 TY_IDX const preg_ty = Stab_Mtype_To_Ty(preg_mtype); 00188 const PREG_IDX preg_num = RETURN_PREG_offset(&return_info, 0); 00189 const INT num_pregs = RETURN_PREG_num_pregs(&return_info); 00190 00191 /* Information pertaining to what location (other than return regs) 00192 * the return value should eventually be stored into, as was 00193 * determined in the PUinfo.c analysis. 00194 */ 00195 ST *result_var = (ST *)CALLSITE_return_var(WN2F_Prev_CallSite); 00196 const WN *result_store = CALLSITE_store1(WN2F_Prev_CallSite); 00197 STAB_OFFSET var_offset = CALLSITE_var_offset(WN2F_Prev_CallSite); 00198 BOOL need_result_in_regs = CALLSITE_in_regs(WN2F_Prev_CallSite); 00199 00200 need_result_in_regs = FALSE; 00201 00202 if (preg_mtype == MTYPE_V) 00203 { 00204 /* Does this ever occur without a VCALL? */ 00205 return_value_is_used = FALSE; 00206 } 00207 else if (result_var != NULL ) 00208 { 00209 /* Should not have unexpected uses of return registers */ 00210 ASSERT_WARN(!need_result_in_regs, 00211 (DIAG_W2F_UNEXPEXTED_RETURNREG_USE, 00212 "WN2F_Function_Call_Lhs")); 00213 00214 /* Assign the value directly to the variable/register, without 00215 * referencing the return registers. 00216 */ 00217 if (ST_class(result_var) == CLASS_PREG) 00218 ST2F_Use_Preg(lhs_tokens, ST_type(result_var), var_offset); 00219 00220 else if (TY_kind(ST_type(result_var)) == KIND_STRUCT) /* avoid FLD selection of Offset_Symref */ 00221 ST2F_use_translate(lhs_tokens,result_var); 00222 00223 else 00224 WN2F_Offset_Symref(lhs_tokens, 00225 result_var, /* base variable */ 00226 Stab_Pointer_To(ST_type(result_var)), /* addr */ 00227 return_ty, /* type of rhs */ 00228 var_offset, /* base offset */ 00229 context); 00230 } 00231 else if (result_store != NULL) 00232 { 00233 /* We have a store into an lvalue that is not a variable, so 00234 * it must be an OPR_ISTORE node with the rhs being an LDID 00235 * of the return register. Do the exact same thing as would 00236 * be done in translating the ISTORE, but substitute the rhs 00237 * with the call expression. 00238 */ 00239 ASSERT_DBG_FATAL(WN_operator(result_store) == OPR_ISTORE && 00240 WN_operator(WN_kid0(result_store)) == OPR_LDID, 00241 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_Function_Call_Lhs()")); 00242 00243 /* Should not have unexpected uses of return registers */ 00244 ASSERT_WARN(!need_result_in_regs, 00245 (DIAG_W2F_UNEXPEXTED_RETURNREG_USE, 00246 "WN2F_Function_Call_Lhs")); 00247 00248 /* Should have matching types in the assignment we are about 00249 * to generate. 00250 */ 00251 ASSERT_WARN(WN2F_Can_Assign_Types(TY_pointed(WN_ty(result_store)), 00252 return_ty), 00253 (DIAG_W2F_INCOMPATIBLE_TYS, "WN2F_Function_Call_Lhs")); 00254 00255 fld_type_z = 0; 00256 WN2F_Offset_Memref(lhs_tokens, 00257 WN_kid1(result_store), /* lhs of ISTORE */ 00258 WN_Tree_Type(WN_kid1(result_store)), /* base addr */ 00259 TY_pointed(WN_ty(result_store)),/* object to store */ 00260 WN_store_offset(result_store), /* base offset */ 00261 context); 00262 } 00263 else if (!need_result_in_regs) 00264 { 00265 /* The return registers are not referenced, so do not bother 00266 * assigning the return value to the return registers. 00267 */ 00268 return_value_is_used = FALSE; 00269 } 00270 else if (num_pregs == 1 && TY_Is_Preg_Type(return_ty)) 00271 { 00272 /* There is a single return register holding the return value, 00273 * so return the rhs into this register, after casting the rhs 00274 * to the appropriate type. Note that preg_mtype and preg_num 00275 * holds the attributes of the single return register. 00276 */ 00277 ASSERT_WARN(WN2F_Can_Assign_Types(preg_ty, return_ty), 00278 (DIAG_W2F_INCOMPATIBLE_TYS, "WN2F_Function_Call_Lhs")); 00279 ST2F_Use_Preg(lhs_tokens, preg_ty, preg_num); 00280 } 00281 else /* Our most difficult case */ 00282 { 00283 /* We need to store the call-result into a temporary variable, 00284 * then save the temporary variable into the return registers. 00285 */ 00286 00287 const UINT tmp_idx = Stab_Lock_Tmpvar(return_ty, 00288 ST2F_Declare_Tempvar); 00289 const char *tmpvar_name = W2CF_Symtab_Nameof_Tempvar(tmp_idx); 00290 00291 /* The lhs is simply the tmpvar */ 00292 Append_Token_String(lhs_tokens, tmpvar_name); 00293 00294 /* rhs to the lhs */ 00295 00296 WN2F_Stmt_Newline(rhs_tokens, (char*) NULL, (SRCPOS) NULL , context); 00297 WN2F_Load_Return_Reg(rhs_tokens, 00298 return_ty, /* Type of tmpvar_name */ 00299 tmpvar_name, 00300 0, 00301 preg_mtype, 00302 preg_num, 00303 context); 00304 00305 if (num_pregs > 1) 00306 { 00307 /* Get the offset into the value from which the second preg 00308 * needs to be loaded. 00309 */ 00310 STAB_OFFSET value_offset = TY_size(Stab_Mtype_To_Ty(preg_mtype)); 00311 00312 /* Load the second register */ 00313 WN2F_Stmt_Newline(rhs_tokens, (char*) NULL, (SRCPOS) NULL , context); 00314 const PREG_IDX preg_num2 = RETURN_PREG_offset(&return_info, 1); 00315 const MTYPE preg_mtype2 = RETURN_PREG_mtype(&return_info, 1); 00316 00317 WN2F_Load_Return_Reg(rhs_tokens, 00318 return_ty, /* Type of tmpvar_name */ 00319 tmpvar_name, 00320 value_offset, /* Offset in tmpvar_name */ 00321 preg_mtype2, 00322 preg_num2, 00323 context); 00324 } /* if save call-value into both return pregs */ 00325 00326 Stab_Unlock_Tmpvar(tmp_idx); 00327 00328 } /* if (various return cases) */ 00329 00330 /* If the return value is not referenced, we need to create a (dummy) 00331 * temporary variable to generate valid Fortran code. 00332 */ 00333 if (!return_value_is_used) 00334 { 00335 tmpvar_idx = Stab_Lock_Tmpvar(return_ty, &ST2F_Declare_Tempvar); 00336 Append_Token_String(lhs_tokens, W2CF_Symtab_Nameof_Tempvar(tmpvar_idx)); 00337 Stab_Unlock_Tmpvar(tmpvar_idx); 00338 } 00339 00340 Prepend_Token_Special(rhs_tokens, '='); 00341 Prepend_And_Reclaim_Token_List(rhs_tokens, &lhs_tokens); 00342 00343 } /* WN2F_Function_Call_Lhs */ 00344 00345 00346 /*----------------------- do_loop translation -------------------------*/ 00347 /*---------------------------------------------------------------------*/ 00348 00349 /* The maximum number of (partial) operations available to manipulate 00350 * a do-loop termination-test expression. 00351 */ 00352 #define MAX_TEST_OPERATIONS 16 00353 00354 00355 typedef struct Partial_Op 00356 { 00357 OPERATOR opr; /* Operation "opnd0 opr opnd1" or "opr(opnd0)" */ 00358 INTRINSIC intr; /* Operation "opnd0 opr opnd1" or "opr(opnd0)" */ 00359 WN *opnd1; /* Second operand (opnd1), if applicable */ 00360 BOOL switch_opnds; /* Switch opnds for binary opr: "opnd1 opr opnd0" */ 00361 } PARTIAL_OP; 00362 00363 00364 /* Data-structure representing operations (PARTIAL_OP) to be carried 00365 * out on both sides of a do-loop termination-test expression, such 00366 * that the side referring to the index-variable is simplified to a 00367 * simple LDID of the index-variable, and the other side 00368 * (DO_LOOP_BOUND.opnd0) is transformed to a suitable bound for a 00369 * Fortran DO loop. The bound expression will be expressed as: 00370 * 00371 * (op[n].opnd1 op[n].opr (....(op[0].opnd1 op[0].opr opnd0))) 00372 * 00373 * after which the original loop termination test has been transformed 00374 * into: 00375 * 00376 * (idx_var comparison_opr bound) 00377 */ 00378 typedef struct Do_Loop_Bound 00379 { 00380 OPERATOR comparison_opr; /* Resultant comparison operator */ 00381 WN *opnd0; /* Last operand in sequence of ops */ 00382 INT const0; /* Constant to be added to opnd0 */ 00383 UINT num_ops; /* Number of ops to be applied to opnd0 */ 00384 PARTIAL_OP *op; /* Sequence of ops to be applied to opnd0 */ 00385 } DO_LOOP_BOUND; 00386 00387 00388 /* Conceptually, we may have to reverse the loop-termination comparison 00389 * to account for a negative multiplicative operand when reducing one 00390 * side of the comparison to an LDID of the index-variable. 00391 */ 00392 #define WN2F_Reverse_Bounds_Comparison(comparison_opr) \ 00393 (comparison_opr == OPR_GE? OPR_LE : \ 00394 comparison_opr == OPR_LE? OPR_GE : \ 00395 comparison_opr == OPR_GT? OPR_LT : \ 00396 OPR_GT) 00397 00398 00399 static INTRINSIC 00400 WN2F_Get_Divfloor_Intr(MTYPE mtype) 00401 { 00402 INTRINSIC intr; 00403 switch (mtype) 00404 { 00405 case MTYPE_I4: 00406 intr = INTRN_I4DIVFLOOR; 00407 break; 00408 case MTYPE_U4: 00409 intr = INTRN_U4DIVFLOOR; 00410 break; 00411 case MTYPE_I8: 00412 intr = INTRN_I8DIVFLOOR; 00413 break; 00414 case MTYPE_U8: 00415 intr = INTRN_U8DIVFLOOR; 00416 break; 00417 default: 00418 intr = INTRINSIC_NONE; 00419 break; 00420 } 00421 return intr; 00422 } /* WN2F_Get_Divfloor_Intr */ 00423 00424 00425 static INTRINSIC 00426 WN2F_Get_Divceil_Intr(MTYPE mtype) 00427 { 00428 INTRINSIC intr; 00429 switch (mtype) 00430 { 00431 case MTYPE_I4: 00432 intr = INTRN_I4DIVCEIL; 00433 break; 00434 case MTYPE_U4: 00435 intr = INTRN_U4DIVCEIL; 00436 break; 00437 case MTYPE_I8: 00438 intr = INTRN_I8DIVCEIL; 00439 break; 00440 case MTYPE_U8: 00441 intr = INTRN_U8DIVCEIL; 00442 break; 00443 default: 00444 intr = INTRINSIC_NONE; 00445 break; 00446 } 00447 return intr; 00448 } /* WN2F_Get_Divceil_Intr */ 00449 00450 00451 static WN * 00452 WN2F_Get_DoLoop_StepSize(WN *step, ST *idx_var, STAB_OFFSET idx_ofst) 00453 { 00454 /* We require this to be an STID, but only warn about the cases 00455 * when we do not have an ADD with one operand being an LDID 00456 * of the idx_var. Return the step-size, if the induction step 00457 * matches our pattern: (STID idx (ADD (LDID idx) stepsize)); 00458 * otherwise return NULL. 00459 */ 00460 WN *add; 00461 WN *step_size = NULL; 00462 00463 ASSERT_DBG_FATAL(WN_operator(step) == OPR_STID && 00464 WN_st(step) == idx_var && WN_offset(step) == idx_ofst, 00465 (DIAG_W2F_UNEXPECTED_OPC, "WN_Get_DoLoop_StepSize")); 00466 00467 if (WN_operator(WN_kid0(step)) == OPR_ADD) 00468 { 00469 add = WN_kid0(step); 00470 if (WN_operator(WN_kid0(add)) == OPR_LDID && 00471 WN_st(WN_kid0(add)) == idx_var) 00472 { 00473 step_size = WN_kid1(add); 00474 } 00475 else if (WN_operator(WN_kid1(add)) == OPR_LDID && 00476 WN_st(WN_kid1(add)) == idx_var) 00477 { 00478 step_size = WN_kid0(add); 00479 } 00480 else 00481 ASSERT_DBG_WARN(FALSE, 00482 (DIAG_W2F_UNEXPECTED_OPC, "WN_Get_DoLoop_StepSize")); 00483 } 00484 else 00485 ASSERT_DBG_WARN(FALSE, 00486 (DIAG_W2F_UNEXPECTED_OPC, "WN_Get_DoLoop_StepSize")); 00487 00488 return step_size; 00489 } /* WN2F_Get_DoLoop_StepSize */ 00490 00491 00492 static UINT 00493 WN2F_LoopBound_VarRef(WN *wn, /* in parameter */ 00494 ST *st, /* in parameter */ 00495 STAB_OFFSET st_ofst, /* in parameter */ 00496 INT *ldid_in_kid, /* out parameter */ 00497 UINT level) /* in parameter */ 00498 { 00499 /* Returns the number of references to the given ST within 00500 * the given WN. Returns a large number (0xfffffff0) to indicate 00501 * an unkown number of references. If there is exactly one such 00502 * reference, and it is an LDID, then we also return a valid path 00503 * through the given wn subtree (as a child-number sequence) in 00504 * "ldid_in_kid"; The end-of-path indicator is a child number of 00505 * "-1". 00506 * 00507 * Note that we also restrict the form of the path to only handle 00508 * a predetermined set of operations (NEG, ADD, SUB, MPY, DIV), 00509 * and when other operations are encountered then the ldid_in_kid 00510 * sequence will be prematurely terminated (-1). Similarly, 00511 * the path cannot be longer than (MAX_TEST_OPERATIONS - level), 00512 * where "level" is "0" (zero) for the outermost loop-bound 00513 * comparison expression, and represents the depth of the path 00514 * down to the level of the wn passed into this routine path. When 00515 * the depth-level exceeds the limit, the top element of the 00516 * ldid_in_kid sequence will become -1, and an unknown number of 00517 * references (0xfffffff0) will be assumed. 00518 * 00519 * Hence, the number of references returned is correct when smaller 00520 * than 0xfffffff0. The path is correct when it leads to an LDID 00521 * of the given ST before containing a -1 value. The last element 00522 * on the ldid_in_kid path will always be set to -1. 00523 */ 00524 UINT counter; 00525 00526 if (level >= MAX_TEST_OPERATIONS) 00527 { 00528 /* Path overflowed, so give up and assume unknown number of 00529 * references. No element available in the ldid_in_kid sequence. 00530 */ 00531 counter = 0xfffffff0; 00532 } 00533 else 00534 { 00535 *ldid_in_kid = -1; /* Reset this to the appropriate kid once known */ 00536 00537 if (WN_operator(wn) == OPR_LDID && 00538 WN_st(wn) == st && WN_offset(wn) == st_ofst) 00539 { 00540 /* Found an LDID reference to the given st. Terminate 00541 * the ldid_in_kid sequence with a -1 value. 00542 */ 00543 counter = 1; 00544 } 00545 else switch (WN_operator(wn)) 00546 { 00547 case OPR_NEG: 00548 counter = WN2F_LoopBound_VarRef(WN_kid0(wn), 00549 st, 00550 st_ofst, 00551 ldid_in_kid+1, 00552 level++); 00553 if (counter == 1) 00554 *ldid_in_kid = 0; /* A single reference found in kid0 */ 00555 break; 00556 00557 case OPR_ADD: 00558 case OPR_SUB: 00559 case OPR_MPY: 00560 case OPR_DIV: 00561 counter = WN2F_LoopBound_VarRef(WN_kid0(wn), 00562 st, 00563 st_ofst, 00564 ldid_in_kid+1, 00565 level++); 00566 if (counter == 1) 00567 { 00568 counter += WN_num_var_refs(WN_kid1(wn), st, st_ofst); 00569 if (counter == 1) 00570 *ldid_in_kid = 0; /* A single reference found in kid0 */ 00571 } 00572 else if (counter == 0) 00573 { 00574 counter = WN2F_LoopBound_VarRef(WN_kid1(wn), 00575 st, 00576 st_ofst, 00577 ldid_in_kid+1, 00578 level++); 00579 if (counter == 1) 00580 *ldid_in_kid = 1; /* A single reference found in kid1 */ 00581 } 00582 else /* zero, more than one, or unknown number of references */ 00583 { 00584 counter += WN_num_var_refs(WN_kid1(wn), st, st_ofst); 00585 } 00586 break; 00587 00588 default: 00589 /* Encountered unexpected form of expression along this path */ 00590 counter = WN_num_var_refs(wn, st, st_ofst); 00591 break; 00592 } /*switch*/ 00593 } 00594 00595 return counter; 00596 } /* WN2F_LoopBound_VarRef */ 00597 00598 00599 static void 00600 WN2F_Get_Next_LoopBoundOp(PARTIAL_OP *op, /* out */ 00601 OPERATOR *comp_opr, /* in/out */ 00602 BOOL *ok, /* out */ 00603 WN *wn, /* in */ 00604 INT idx_kid) /* in */ 00605 { 00606 /* Given an expression (wn) occurring on the lhs of a comparison 00607 * operator (comp_opr), determine and record the operation (op) 00608 * which will undo the effect of the expression with respect to 00609 * the subexpression representing the index-expression (idx_kid). 00610 * 00611 * The end-result should be that: op(wn) == WN_kid(wn, idx_kid). 00612 */ 00613 ASSERT_DBG_WARN(*comp_opr == OPR_LE || *comp_opr == OPR_GE, 00614 (DIAG_W2F_UNEXPECTED_OPC, "WN_Get_DoLoop_Bound")); 00615 00616 if (idx_kid < 0) 00617 { 00618 /* Invalid path element */ 00619 *ok = FALSE; 00620 } 00621 else 00622 { 00623 *ok = TRUE; /* until proven otherwise */ 00624 switch (WN_operator(wn)) 00625 { 00626 case OPR_NEG: 00627 /* -idx <= e0 --> idx >= -e0 */ 00628 /* -idx < e0 --> idx > -e0 */ 00629 op->intr = INTRINSIC_NONE; 00630 op->opr = OPR_NEG; 00631 op->opnd1 = NULL; 00632 op->switch_opnds = FALSE; 00633 *comp_opr = WN2F_Reverse_Bounds_Comparison(*comp_opr); 00634 break; 00635 00636 case OPR_ADD: 00637 /* idx+e1 <= e0 --> idx <= e0-e1 */ 00638 op->intr = INTRINSIC_NONE; 00639 op->opr = OPR_SUB; 00640 op->opnd1 = WN_kid(wn, (idx_kid == 0)? 1 : 0); 00641 op->switch_opnds = FALSE; 00642 break; 00643 00644 case OPR_SUB: 00645 op->intr = INTRINSIC_NONE; 00646 if (idx_kid == 0) 00647 { 00648 /* idx-e1 <= e0 --> idx <= e0+e1 */ 00649 op->opr = OPR_ADD; 00650 op->opnd1 = WN_kid1(wn); 00651 op->switch_opnds = FALSE; 00652 } 00653 else /* (idx_kid == 1) */ 00654 { 00655 /* e1-idx <= e0 --> idx >= e1-e0 */ 00656 op->opr = OPR_SUB; 00657 op->opnd1 = WN_kid0(wn); 00658 op->switch_opnds = TRUE; 00659 *comp_opr = WN2F_Reverse_Bounds_Comparison(*comp_opr); 00660 } 00661 break; 00662 00663 case OPR_MPY: 00664 /* While a regular division may be used in real arithmetics, 00665 * we operate with integral numbers and we must round to 00666 * the closest number that still makes the inequality hold. 00667 * 00668 * Since the lhs will always be an integer, a "<=" operator 00669 * which holds for a real rhs will also hold for the rhs 00670 * rounded down (DIVFLOOR). Similarly, for a ">=" operator 00671 * the inequality will always hold for a rhs rounded up (DIVCEIL). 00672 * 00673 * Hence we get: 00674 * 00675 * idx*e1 <= e0 ---(e1>=0)---> idx <= DIVFLOOR(e0, e1) 00676 * idx*e1 <= e0 ---(e1< 0)---> idx >= DIVCEIL(e0, e1) 00677 * idx*e1 >= e0 ---(e1>=0)---> idx >= DIVCEIL(e0, e1) 00678 * idx*e1 >= e0 ---(e1< 0)---> idx <= DIVFLOOR(e0, e1) 00679 */ 00680 op->opnd1 = WN_kid(wn, (idx_kid == 0)? 1 : 0); 00681 op->switch_opnds = FALSE; 00682 if (WN_operator(op->opnd1) != OPR_INTCONST || 00683 WN_const_val(op->opnd1) == 0) 00684 { 00685 *ok = FALSE; 00686 } 00687 else 00688 { 00689 /* Update the inequality operator to what it should be after 00690 * the transformation. 00691 */ 00692 if (WN_const_val(op->opnd1) < 0) 00693 *comp_opr = WN2F_Reverse_Bounds_Comparison(*comp_opr); 00694 00695 /* Get the operator kind 00696 */ 00697 op->opr = OPR_INTRINSIC_OP; 00698 op->intr = INTRINSIC_NONE; 00699 if (*comp_opr == OPR_LE) 00700 op->intr = WN2F_Get_Divfloor_Intr(WN_opc_rtype(wn)); 00701 else /* (*comp_opr == OPR_GE) */ 00702 op->intr = WN2F_Get_Divceil_Intr(WN_opc_rtype(wn)); 00703 } 00704 break; 00705 00706 case OPR_DIV: 00707 if (idx_kid == 0) 00708 { 00709 /* idx/e1 <= e0 --> idx <= e0*e1 WHERE e1 >= 0 */ 00710 op->opr = OPR_MPY; 00711 op->opnd1 = WN_kid1(wn); 00712 op->switch_opnds = FALSE; 00713 } 00714 else /* (idx_kid == 1) */ 00715 { 00716 /* e1/idx <= e0 --> idx <= e1/e0 WHERE e1 >= 0 */ 00717 op->opr = OPR_DIV; 00718 op->opnd1 = WN_kid0(wn); 00719 op->switch_opnds = TRUE; 00720 } 00721 if (WN_operator(op->opnd1) != OPR_INTCONST || 00722 WN_const_val(op->opnd1) == 0) 00723 { 00724 *ok = FALSE; 00725 } 00726 else if (WN_const_val(op->opnd1) < 0) 00727 { 00728 /* idx/e1 <= e0 --> idx >= e0*e1 WHERE e1 < 0 */ 00729 *comp_opr = WN2F_Reverse_Bounds_Comparison(*comp_opr); 00730 } 00731 break; 00732 00733 default: 00734 *ok = FALSE; 00735 break; 00736 } 00737 } /* if (idx_kid >= 0) */ 00738 } /* WN2F_Get_Next_LoopBoundOp */ 00739 00740 00741 static DO_LOOP_BOUND * 00742 WN2F_Get_DoLoop_Bound(WN *end_test, 00743 ST *idx_var, 00744 STAB_OFFSET idx_ofst, 00745 WN *step_size) 00746 { 00747 /* We expect a non-NULL step_size expression and try to transform 00748 * the loop-termination test (end_test) into a form with an LDID 00749 * of the index (idx_var) on the lhs of the test, the rhs of 00750 * correspondingly transformed by means of a DO_LOOP_BOUND. 00751 * 00752 * If the loop-termination test with the LDID as the lhs is 00753 * of a form which permits the rhs (DO_LOOP_BOUND) to be used 00754 * as a bound in a Fortran do-loop, then return a ptr to the 00755 * DO_LOOP_BOUND; otherwise we return a NULL ptr. 00756 */ 00757 static PARTIAL_OP partial_op[MAX_TEST_OPERATIONS]; 00758 00759 static DO_LOOP_BOUND bound = {(OPERATOR) 0, /*comparison_opr: set every call*/ 00760 NULL, /*opnd0: set every call*/ 00761 0, /*const0: set every call*/ 00762 0, /*num_ops: set every call*/ 00763 partial_op}; /*op: set here, once only */ 00764 00765 DO_LOOP_BOUND *boundp = NULL; 00766 OPERATOR comparison_opr = WN_operator(end_test); 00767 INT path_to_idx0[MAX_TEST_OPERATIONS]; 00768 INT path_to_idx1[MAX_TEST_OPERATIONS]; 00769 INT *path_to_idx; /* Pointer to path_to_idx0 or path_to_idx1 */ 00770 INT path_level; /* Index into path_to_idx sequence */ 00771 INT idx_refs0; /* Number of references to "idx_var" in kid0 */ 00772 INT idx_refs1; /* Number of references to "idx_var" in kid1 */ 00773 WN *idx_expr; /* Kid of "end_test" referring to "idx_var" */ 00774 BOOL bound_ok; /* Bounds calculation thus far is fine? */ 00775 00776 if (step_size == NULL) 00777 { 00778 /* We can only deal with well-formed step-sizes */ 00779 } 00780 else if (comparison_opr == OPR_LE || 00781 comparison_opr == OPR_GE || 00782 comparison_opr == OPR_LT || 00783 comparison_opr == OPR_GT || 00784 comparison_opr == OPR_NE ) 00785 { 00786 /* We only handle LE, GE, LT, and GT loop termination tests. 00787 * Find a path in end_test to an only LDID reference to the 00788 * idx_var, and check to make sure this is the only reference 00789 * to the idx_var in the end_test. 00790 */ 00791 idx_refs0 = WN2F_LoopBound_VarRef(WN_kid0(end_test), 00792 idx_var, 00793 idx_ofst, 00794 path_to_idx0, 00795 1); 00796 if (idx_refs0 <= 1) 00797 { 00798 idx_refs1 = WN2F_LoopBound_VarRef(WN_kid1(end_test), 00799 idx_var, 00800 idx_ofst, 00801 path_to_idx1, 00802 1); 00803 00804 if ((idx_refs0 + idx_refs1) == 1) 00805 { 00806 /* Set bound.opnd0 to the base expression for loop bound 00807 * calculation, where idx_expr will be the other side of 00808 * the "end_test" expression. Convert the comparison_opr 00809 * such that "idx_expr opr bound.opnd0" is equivalent to 00810 * the original end_test. 00811 */ 00812 if (idx_refs0 == 1) 00813 { 00814 /* Idx reference in the lhs of the end-test */ 00815 bound.opnd0 = WN_kid1(end_test); 00816 idx_expr = WN_kid0(end_test); 00817 path_to_idx = path_to_idx0; 00818 } 00819 else /* (idx_refs1 == 1) */ 00820 { 00821 /* Idx reference in the rhs of the end-test */ 00822 bound.opnd0 = WN_kid0(end_test); 00823 idx_expr = WN_kid1(end_test); 00824 path_to_idx = path_to_idx1; 00825 comparison_opr = WN2F_Reverse_Bounds_Comparison(comparison_opr); 00826 } 00827 00828 /* The comparison_opr has been converted such that the 00829 * bound expression can be viewed as having the idx on the 00830 * lhs. Next, convert a '<' or '>' operator, with respect 00831 * to the idx_expr, into a '<=' or '>=' repectively. 00832 */ 00833 if (comparison_opr == OPR_LT) 00834 { 00835 /* Convert "i<n" into "i<=(n-1)" */ 00836 bound.const0 = -1; 00837 comparison_opr = OPR_LE; 00838 } 00839 else if (comparison_opr == OPR_GT) 00840 { 00841 /* Convert "i>n" into "i>=(n+1)" */ 00842 bound.const0 = 1; 00843 comparison_opr = OPR_GE; 00844 } 00845 else 00846 bound.const0 = 0; 00847 00848 /* Traverse the idx_expr, collecting the sequence of operations 00849 * necessary to reduce it to an LDID of the the idx_var. 00850 */ 00851 for (bound_ok = TRUE, path_level = 0; 00852 bound_ok && path_to_idx[path_level] >= 0; 00853 path_level++) 00854 { 00855 WN2F_Get_Next_LoopBoundOp(&bound.op[path_level], 00856 &comparison_opr, 00857 &bound_ok, 00858 idx_expr, 00859 path_to_idx[path_level]); 00860 idx_expr = WN_kid(idx_expr, path_to_idx[path_level]); 00861 } 00862 00863 /* We can only generate a Fortran do-loop bound when the test 00864 * has been simplified to have an LDID of the index variable 00865 * as the lhs (idx_expr), and we have one of the following 00866 * two forms of loop (assuming the step-size is well-formed, 00867 * i.e. positive for the first case and negative for the second 00868 * case): 00869 * 00870 * step_size >= 0: 00871 * --------------- 00872 * for (i=init; i<=bound; i+=step_size) 00873 * 00874 * step_size <= 0: 00875 * --------------- 00876 * for (i=init; i>=bound; i+=step_size) 00877 */ 00878 if (bound_ok && 00879 WN_operator(idx_expr) == OPR_LDID && 00880 WN_st(idx_expr) == idx_var && 00881 WN_offset(idx_expr) == idx_ofst && 00882 (WN_operator(step_size) != OPR_INTCONST || 00883 (WN_const_val(step_size) <= 0 && comparison_opr == OPR_GE) || 00884 (WN_const_val(step_size) >= 0 && comparison_opr == OPR_LE))) 00885 { 00886 /* All is well, so return the calculated bound! */ 00887 boundp = &bound; 00888 bound.comparison_opr = comparison_opr; 00889 bound.num_ops = path_level; 00890 } 00891 } /* if exactly one ref to idx_var in lhs and rhs combined */ 00892 } /* if no more than one lhs ref to idx_var */ 00893 } /* if LE/GE/LT/GE loop termination test */ 00894 else 00895 ASSERT_DBG_WARN(FALSE, (DIAG_W2F_UNEXPECTED_OPC, "WN_Get_DoLoop_Bound")); 00896 00897 return boundp; 00898 } /* WN2F_Get_DoLoop_Bound */ 00899 00900 00901 static WN2F_STATUS 00902 WN2F_Translate_DoLoop_Bound(TOKEN_BUFFER tokens, 00903 DO_LOOP_BOUND *bound, 00904 WN2F_CONTEXT context) 00905 { 00906 /* Note: Michael Wolf has a similar routine */ 00907 TOKEN_BUFFER bound_expr = New_Token_Buffer(); 00908 TOKEN_BUFFER opnd1_expr; 00909 UINT op_idx; 00910 BOOL is_intrinsic; 00911 char *intrname; 00912 char opname; 00913 00914 WN2F_translate(bound_expr, bound->opnd0, context); 00915 if (bound->const0 != 0) 00916 { 00917 Append_Token_Special(bound_expr, '+'); 00918 if (bound->const0<0) { 00919 Append_Token_Special(bound_expr,'('); 00920 Append_Token_String(bound_expr, Number_as_String(bound->const0, "%lld")); 00921 Append_Token_Special(bound_expr,')'); 00922 } 00923 else 00924 Append_Token_String(bound_expr, Number_as_String(bound->const0, "%lld")); 00925 } 00926 for (op_idx = 0; op_idx < bound->num_ops; op_idx++) 00927 { 00928 is_intrinsic = FALSE; 00929 00930 /* Get the operator */ 00931 switch (bound->op[op_idx].opr) 00932 { 00933 case OPR_NEG: 00934 opname = '-'; 00935 break; 00936 case OPR_ADD: 00937 opname = '+'; 00938 break; 00939 case OPR_SUB: 00940 opname = '-'; 00941 break; 00942 case OPR_MPY: 00943 opname = '*'; 00944 break; 00945 case OPR_DIV: 00946 opname = '/'; 00947 break; 00948 case OPR_INTRINSIC_OP: 00949 is_intrinsic = TRUE; 00950 switch (bound->op[op_idx].intr) 00951 { 00952 case INTRN_I4DIVFLOOR: 00953 intrname = "INTRN_I4DIVFLOOR"; 00954 break; 00955 case INTRN_I8DIVFLOOR: 00956 intrname = "INTRN_I8DIVFLOOR"; 00957 break; 00958 case INTRN_U4DIVFLOOR: 00959 intrname = "INTRN_U4DIVFLOOR"; 00960 break; 00961 case INTRN_U8DIVFLOOR: 00962 intrname = "INTRN_U8DIVFLOOR"; 00963 break; 00964 case INTRN_I4DIVCEIL: 00965 intrname = "INTRN_I4DIVCEIL"; 00966 break; 00967 case INTRN_I8DIVCEIL: 00968 intrname = "INTRN_I8DIVCEIL"; 00969 break; 00970 case INTRN_U4DIVCEIL: 00971 intrname = "INTRN_U4DIVCEIL"; 00972 break; 00973 case INTRN_U8DIVCEIL: 00974 intrname = "INTRN_U8DIVCEIL"; 00975 break; 00976 default: 00977 ASSERT_FATAL(FALSE, (DIAG_W2F_UNEXPECTED_DOLOOP_BOUNDOP, 00978 "WN2F_Translate_DoLoop_Bound", 00979 OPERATOR_name(bound->op[op_idx].opr))); 00980 } 00981 break; 00982 default: 00983 ASSERT_FATAL(FALSE, (DIAG_W2F_UNEXPECTED_DOLOOP_BOUNDOP, 00984 "WN2F_Translate_DoLoop_Bound", 00985 OPERATOR_name(bound->op[op_idx].opr))); 00986 break; 00987 } 00988 00989 if (!is_intrinsic && bound->op[op_idx].opnd1 == NULL) 00990 { 00991 WHIRL2F_Parenthesize(bound_expr); 00992 Prepend_Token_Special(bound_expr, opname); /* Unary operation */ 00993 } 00994 else /* Binary operation (all intrinsics we deal with are binary) */ 00995 { 00996 /* Translate the second operand */ 00997 opnd1_expr = New_Token_Buffer(); 00998 (void)WN2F_translate(opnd1_expr, bound->op[op_idx].opnd1, context); 00999 01000 /* Apply the second operand to the first one */ 01001 if (is_intrinsic) 01002 { 01003 if (bound->op[op_idx].switch_opnds) 01004 { 01005 Prepend_Token_Special(bound_expr, ','); 01006 Prepend_And_Reclaim_Token_List(bound_expr, &opnd1_expr); 01007 } 01008 else 01009 { 01010 Append_Token_Special(bound_expr, ','); 01011 Append_And_Reclaim_Token_List(bound_expr, &opnd1_expr); 01012 } 01013 Prepend_Token_Special(bound_expr, '('); 01014 Append_Token_Special(bound_expr, ')'); 01015 Prepend_Token_String(bound_expr, intrname); 01016 } 01017 else 01018 { 01019 WHIRL2F_Parenthesize(bound_expr); 01020 WHIRL2F_Parenthesize(opnd1_expr); 01021 if (bound->op[op_idx].switch_opnds) 01022 { 01023 Prepend_Token_Special(bound_expr, opname); 01024 Prepend_And_Reclaim_Token_List(bound_expr, &opnd1_expr); 01025 } 01026 else 01027 { 01028 Append_Token_Special(bound_expr, opname); 01029 Append_And_Reclaim_Token_List(bound_expr, &opnd1_expr); 01030 } 01031 } 01032 } /* if */ 01033 } /* for */ 01034 01035 Append_And_Reclaim_Token_List(tokens, &bound_expr); 01036 return EMPTY_WN2F_STATUS; 01037 } /* WN2F_Translate_DoLoop_Bound */ 01038 01039 01040 /*--------------------- prompf processing utilities -------------------*/ 01041 /*---------------------------------------------------------------------*/ 01042 01043 static BOOL 01044 WN2F_Is_Loop_Region(const WN *region, WN2F_CONTEXT context) 01045 { 01046 /* Return TRUE if the given region is either a DOACROSS, 01047 * PARALLEL_DO, or a PDO region; otherwise, return FALSE. 01048 */ 01049 BOOL predicate = (WN_operator(region) == OPR_REGION); 01050 01051 if (predicate) 01052 { 01053 WN *pragma = WN_first(WN_region_pragmas(region)); 01054 01055 predicate = (pragma != NULL && 01056 (WN_pragma(pragma) == WN_PRAGMA_DOACROSS || 01057 WN_pragma(pragma) == WN_PRAGMA_PARALLEL_DO || 01058 WN_pragma(pragma) == WN_PRAGMA_PDO_BEGIN) && 01059 WN_pragma_nest(pragma) <= 0 && 01060 !Ignore_Synchronized_Construct(pragma, context)); 01061 } 01062 return predicate; 01063 } /* WN2F_Is_Loop_Region */ 01064 01065 01066 /* 01067 * See if this is a region construct. ie: a pragma in the list 01068 * below. The end of the region is the implicit end of the construct. 01069 */ 01070 01071 static BOOL 01072 WN2F_Is_Parallel_Region(WN *region, WN2F_CONTEXT context) 01073 { 01074 BOOL predicate = (region != NULL && WN_operator(region) == OPR_REGION); 01075 01076 if (predicate) 01077 { 01078 WN *pragma = WN_first(WN_region_pragmas(region)); 01079 01080 predicate = (pragma != NULL) && 01081 (WN_pragma(pragma) == WN_PRAGMA_PARALLEL_BEGIN || 01082 WN_pragma(pragma) == WN_PRAGMA_MASTER_BEGIN || 01083 WN_pragma(pragma) == WN_PRAGMA_SINGLE_PROCESS_BEGIN || 01084 WN_pragma(pragma) == WN_PRAGMA_PSECTION_BEGIN || 01085 WN_pragma(pragma) == WN_PRAGMA_PARALLEL_SECTIONS || 01086 WN_pragma(pragma) == WN_PRAGMA_PARALLEL_WORKSHARE) && 01087 !Ignore_Synchronized_Construct(pragma, context); 01088 } 01089 return predicate; 01090 01091 } /* WN2F_Is_Parallel_Region */ 01092 01093 01094 static void 01095 WN2F_Prompf_Construct_Start(TOKEN_BUFFER tokens, WN *construct) 01096 { 01097 INT32 construct_id = WN_MAP32_Get(*W2F_Construct_Map, construct); 01098 01099 if (construct_id != 0) 01100 { 01101 Append_F77_Directive_Newline(tokens,sgi_comment_str); 01102 Append_Token_String(tokens, "start"); 01103 Append_Token_String(tokens, Number_as_String(construct_id, "%llu")); 01104 } 01105 } /* WN2F_Prompf_Construct_Start */ 01106 01107 01108 static void 01109 WN2F_Prompf_Construct_End(TOKEN_BUFFER tokens, WN *construct) 01110 { 01111 INT32 construct_id = WN_MAP32_Get(*W2F_Construct_Map, construct); 01112 01113 if (construct_id != 0) 01114 { 01115 Append_F77_Directive_Newline(tokens, sgi_comment_str); 01116 Append_Token_String(tokens, "end"); 01117 Append_Token_String(tokens, Number_as_String(construct_id, "%llu")); 01118 } 01119 } /* WN2F_Prompf_Construct_End */ 01120 01121 01122 static void 01123 WN2F_Start_Prompf_Transformed_Loop(TOKEN_BUFFER tokens, 01124 WN *loop, 01125 WN2F_CONTEXT context) 01126 { 01127 /* We if this is a DOACROSS, PDO or PARALLEL DO loop, then it will 01128 * already have been handled by the surrounding region, so we need 01129 * not emit anything here. Otherwise, emit the prompf flags. 01130 */ 01131 if (!WN2F_Is_Loop_Region(W2CF_Get_Parent(W2CF_Get_Parent(loop)), context)) 01132 WN2F_Prompf_Construct_Start(tokens, loop); 01133 } /* WN2F_Start_Prompf_Transformed_Loop */ 01134 01135 01136 static void 01137 WN2F_End_Prompf_Transformed_Loop(TOKEN_BUFFER tokens, 01138 WN *loop, 01139 WN2F_CONTEXT context) 01140 { 01141 /* We if this is a DOACROSS, PDO or PARALLEL DO loop, then it will 01142 * already have been handled by the surrounding region, so we need 01143 * not emit anything here. Otherwise, emit the prompf flags. 01144 */ 01145 if (!WN2F_Is_Loop_Region(W2CF_Get_Parent(W2CF_Get_Parent(loop)), context)) 01146 WN2F_Prompf_Construct_End(tokens, loop); 01147 } /* WN2F_End_Prompf_Transformed_Loop */ 01148 01149 01150 static void 01151 WN2F_Start_Prompf_Transformed_Region(TOKEN_BUFFER tokens, 01152 WN *region, 01153 WN2F_CONTEXT context) 01154 { 01155 /* Handle a PARALLEL, PSECTION, SINGLE MASTER region, 01156 * or a DOACROSS, PDO or PARALLEL DO loop enclosed in a region. 01157 * ie: print - "start" <n> 01158 */ 01159 01160 if (WN2F_Is_Loop_Region(region, context) || 01161 WN2F_Is_Parallel_Region(region, context)) 01162 WN2F_Prompf_Construct_Start(tokens, region); 01163 01164 } /* WN2F_Begin_Prompf_Transformed_Region */ 01165 01166 01167 static void 01168 WN2F_End_Prompf_Transformed_Region(TOKEN_BUFFER tokens, 01169 WN *region, 01170 WN2F_CONTEXT context) 01171 { 01172 /* Finish up a PARALLEL, PSECTION, SINGLE MASTER region, 01173 * or a DOACROSS, PDO or PARALLEL DO loop enclosed in a region. 01174 * ie: print - "end" <n> 01175 */ 01176 01177 if (WN2F_Is_Loop_Region(region, context) || 01178 WN2F_Is_Parallel_Region(region, context)) 01179 WN2F_Prompf_Construct_End(tokens, region); 01180 01181 } /* WN2F_End_Prompf_Transformed_Region */ 01182 01183 01184 /*--------------------- block processing utilities --------------------*/ 01185 /*---------------------------------------------------------------------*/ 01186 01187 01188 static void 01189 WN2F_Append_Symtab_Consts(TOKEN_BUFFER tokens, 01190 SYMTAB_IDX symtab, 01191 UINT lines_between_decls) 01192 { 01193 /* When "tokens" is NULL, we write the consts directly to the 01194 * Whirl2f_file; otherwise, append them to the given token-list. 01195 */ 01196 #if 0 01197 /* Declare static variables for symbolic constants */ 01198 FOR_ALL_CONSTANTS(st, const_idx) 01199 { 01200 /* TODO: Full support for sym_consts */ 01201 01202 if (tokens != NULL) 01203 { 01204 Append_F77_Indented_Newline(tokens, 01205 lines_between_decls, NULL/*label*/); 01206 ST2F_decl_translate(tokens, st); 01207 } 01208 else 01209 { 01210 tmp_tokens = New_Token_Buffer(); 01211 Append_F77_Indented_Newline(tmp_tokens, 01212 lines_between_decls, NULL/*label*/); 01213 ST2F_decl_translate(tmp_tokens, st); 01214 Write_And_Reclaim_Tokens(W2F_File[W2F_FTN_FILE], 01215 W2F_File[W2F_LOC_FILE], 01216 &tmp_tokens); 01217 } 01218 } 01219 } 01220 #endif 01221 01222 } /* WN2F_Append_Symtab_Consts */ 01223 01224 01225 struct write_st { 01226 private: 01227 TOKEN_BUFFER tokens; 01228 UINT lines_between_decls; 01229 SYMTAB_IDX symtab; 01230 public: 01231 write_st(TOKEN_BUFFER tb,UINT lbd,SYMTAB_IDX symtab) : tokens(tb), lines_between_decls(lbd),symtab(symtab) {} 01232 01233 // A function object to declare an identifier from the ST 01234 // table, provided it represents a function, or a variable 01235 // referenced. Common elements are excluded, but emitted 01236 // as part of TY2F_Declare_Common_Flds. Ditto Formals. 01237 // This is called from WN2F_Append_Symtab_Vars. 01238 01239 01240 void operator() (UINT32 idx , ST* st) const 01241 { 01242 int testb = !BE_ST_w2fc_referenced(st); 01243 int testb1 = !ST_has_nested_ref(st); 01244 int testb2 = !ST_is_in_module(st); 01245 ST *sts = Scope_tab[Current_scope].st; 01246 ST *stbase = ST_base(st); 01247 01248 INITO_IDX inito; 01249 char *scope_name = ST_name(sts); 01250 int lens = strlen(scope_name); 01251 char *stbasename = ST_name(stbase); 01252 BOOL nomodulevar; 01253 PU_IDX current_PU=ST_pu(Scope_tab[Current_scope].st); 01254 01255 01256 char *stname = ST_name(st); 01257 01258 // std::cout << "JU: dealing with " << stname << std::endl; 01259 01260 BOOL variabledefinemodule = !strcmp(stbasename,scope_name); 01261 01262 nomodulevar = !ST_is_in_module(st)||strcmp(stbasename,scope_name); 01263 01264 if (ST_is_deleted(st)) /*CFC works on AST coulde delete some STs*/ 01265 return; 01266 01267 if (ST_class(st)==CLASS_PARAMETER) 01268 { 01269 if (tokens != NULL) 01270 { 01271 Append_F77_Indented_Newline(tokens, 01272 lines_between_decls, NULL/*label*/); 01273 ST2F_decl_translate(tokens, st); 01274 } 01275 else 01276 { 01277 TOKEN_BUFFER tmp_tokens; 01278 01279 tmp_tokens = New_Token_Buffer(); 01280 Append_F77_Indented_Newline(tmp_tokens, 01281 lines_between_decls, NULL/*label*/); 01282 ST2F_decl_translate(tmp_tokens, st); 01283 Write_And_Reclaim_Tokens(W2F_File[W2F_FTN_FILE], 01284 W2F_File[W2F_LOC_FILE], 01285 &tmp_tokens); 01286 } 01287 return; 01288 } 01289 01290 if (ST_class(st)==CLASS_TYPE) { 01291 if (ST_pu(ST_base(st)) == current_PU) 01292 ST2F_decl_translate(tokens, st); 01293 else 01294 Set_TY_is_translated_to_c(ST_type(st)); 01295 return; 01296 } 01297 01298 // std::cout << "JU: decide:" 01299 // << "\n\tBE_ST_w2fc_referenced(st)=" << BE_ST_w2fc_referenced(st) 01300 // << "\n\tST_is_in_module(st)=" << ST_is_in_module(st) 01301 // << "\n\tnomodulevar=" << nomodulevar 01302 // << "\n\tstrcmp(ST_name(st)="<< ST_name(st) << ",stbasename=" << stbasename << ")=" << strcmp(ST_name(st),stbasename) << std::endl; 01303 if (!BE_ST_w2fc_referenced(st) 01304 && 01305 !(BE_ST_w2fc_referenced(stbase) 01306 && 01307 ST_is_equivalenced(st) 01308 && 01309 ST_is_temp_var(stbase)) 01310 && 01311 !ST_has_nested_ref(st) 01312 && 01313 !ST_is_in_module(st) 01314 && 01315 ST_sclass(st)!= SCLASS_DGLOBAL 01316 && 01317 ST_sclass(st)!= SCLASS_PSTATIC 01318 && 01319 (nomodulevar 01320 || 01321 !strcmp(ST_name(st),stbasename)) 01322 && 01323 ST_sclass(st) != SCLASS_EXTERN ) { 01324 // std::cout << "JU: return" << std::endl; 01325 return ; 01326 } 01327 01328 // std::cout << "JU: keepgoing" << std::endl; 01329 01330 if (ST_sclass(st) == SCLASS_EXTERN && 01331 symtab == GLOBAL_SYMTAB) 01332 return; 01333 01334 if (ST_sclass(st) == SCLASS_EXTERN && 01335 !BE_ST_w2fc_referenced(stbase) && 01336 !ST_is_in_module(st)) 01337 return; 01338 01339 if (ST_is_in_module(st) && 01340 nomodulevar && 01341 ST_sclass(st) != SCLASS_EXTERN && 01342 !Stab_Is_Common_Block(stbase)) 01343 return; 01344 01345 if (ST_is_in_module(st) && 01346 !variabledefinemodule && 01347 ST_sclass(st) != SCLASS_EXTERN) 01348 return; 01349 01350 /* don't redeclare recuresive function's type in this PU 01351 * (recursive function) */ 01352 if (ST_sclass(st)==SCLASS_TEXT && variabledefinemodule) 01353 return; 01354 01355 01356 if (ST_is_external(st)) 01357 return; 01358 01359 01360 if (ST_sym_class(st) ==CLASS_FUNC) 01361 if ( ST_export(st) == EXPORT_LOCAL_INTERNAL) 01362 return; 01363 01364 if (ST_sym_class(st) ==CLASS_FUNC) 01365 if (!(ST_sclass(st) == SCLASS_EXTERN)) 01366 return; 01367 01368 01369 BOOL dop ; 01370 01371 dop = ST_sclass(st) != SCLASS_FORMAL && 01372 ST_sclass(st) != SCLASS_FORMAL_REF ; 01373 01374 dop &= ((ST_sym_class(st) == CLASS_VAR && !ST_is_namelist(st)) || 01375 (ST_sym_class(st) == CLASS_FUNC)) ; 01376 01377 01378 if ((ST_sclass(stbase) == SCLASS_DGLOBAL) && 01379 ST_is_initialized(st) && 01380 !Stab_No_Linkage(st) && 01381 (!TY_Is_Structured(ST_type(st)) || 01382 Stab_Is_Equivalence_Block(st))) 01383 { 01384 inito = Find_INITO_For_Symbol(st); 01385 if (inito != (INITO_IDX) 0) 01386 INITO2F_translate(Data_Stmt_Tokens, inito); 01387 } 01388 else 01389 if (dop) 01390 { 01391 if (tokens != NULL) 01392 { 01393 Append_F77_Indented_Newline(tokens, 01394 lines_between_decls, NULL/*label*/); 01395 ST2F_decl_translate(tokens, st); 01396 } 01397 else 01398 { 01399 TOKEN_BUFFER tmp_tokens; 01400 01401 tmp_tokens = New_Token_Buffer(); 01402 Append_F77_Indented_Newline(tmp_tokens, 01403 lines_between_decls, NULL/*label*/); 01404 ST2F_decl_translate(tmp_tokens, st); 01405 Write_And_Reclaim_Tokens(W2F_File[W2F_FTN_FILE], 01406 W2F_File[W2F_LOC_FILE], 01407 &tmp_tokens); 01408 } 01409 } 01410 } 01411 } ; 01412 01413 struct set_derived_ty_based_on_st { 01414 private: 01415 PU_IDX current_PU; 01416 01417 public: 01418 set_derived_ty_based_on_st(PU_IDX c_PU):current_PU(c_PU) {} 01419 void operator()(UINT32, ST* st) const { 01420 if ((ST_class(st)==CLASS_TYPE) && //derived type 01421 (ST_pu(ST_base(st)) == current_PU) ) { 01422 Reset_TY_is_translated_to_c(ST_type(st)); 01423 } 01424 01425 if ((ST_sclass(st) == SCLASS_COMMON) && //common block 01426 (ST_pu(ST_base(st)) == current_PU) ) { 01427 Reset_TY_is_translated_to_c(ST_type(st)); 01428 //Set_BE_ST_w2fc_referenced(st); 01429 } 01430 } 01431 01432 }; 01433 01434 static void 01435 WN2F_Append_Symtab_Vars(TOKEN_BUFFER tokens, 01436 SYMTAB_IDX symtab, 01437 UINT lines_between_decls) 01438 { 01439 /* Declare identifiers from the new symbol table, provided they 01440 * represent functions or variables that are either common or 01441 * that have been referenced/used. 01442 */ 01443 01444 For_all(St_Table,symtab,write_st(tokens,lines_between_decls,symtab)); 01445 01446 01447 } /* WN2F_Append_Symtab_Vars */ 01448 01449 static void 01450 WN2F_Enter_PU_Block(void) 01451 { 01452 WN2F_Next_ReturnSite = PUinfo_Get_ReturnSites(); 01453 WN2F_Prev_CallSite = NULL; 01454 01455 Data_Stmt_Tokens = New_Token_Buffer(); 01456 01457 } /* WN2F_Enter_PU_Block */ 01458 01459 01460 // Emit declarations for a PU, ie: constants, extern/common/local 01461 // variables. The declarations are built in a temporary buffer, 01462 // decl_tokens, then merged with the token buffer passed in. 01463 01464 static void 01465 WN2F_Exit_PU_Block(TOKEN_BUFFER tokens, TOKEN_BUFFER *stmts) 01466 { 01467 SYMTAB_IDX symtab; 01468 TOKEN_BUFFER decl_tokens; 01469 PU & pu = Get_Current_PU(); 01470 PU_IDX current_PU = ST_pu(Scope_tab[CURRENT_SYMTAB].st); 01471 01472 /* 01473 * set all derived type entries with 01474 * Set_TY_is_translated_to_c() 01475 * ---FMZ 01476 */ 01477 for (TY_IDX ty = 1; ty < TY_Table_Size(); ty++) { 01478 if (TY_kind(ty<<8)==KIND_STRUCT) 01479 Set_TY_is_translated_to_c(ty<<8); 01480 } 01481 /* 01482 * reset the derived type table entry "translated_to_c(f)" 01483 * defined in "this" PU. 01484 * ---FMZ 01485 */ 01486 For_all(St_Table,GLOBAL_SYMTAB,set_derived_ty_based_on_st(current_PU)); 01487 01488 /* Declare constants */ 01489 decl_tokens = New_Token_Buffer(); 01490 WN2F_Append_Symtab_Consts(decl_tokens, CURRENT_SYMTAB, 1/*Newlines*/); 01491 if (!W2F_Purple_Emission && !Is_Empty_Token_Buffer(decl_tokens)) { 01492 WHIRL2F_Append_Comment(tokens, "**** Constants ****", 1, 1); 01493 Append_And_Reclaim_Token_List(tokens, &decl_tokens); 01494 } 01495 01496 /* Declare variables and reset the "referenced" flag */ 01497 01498 decl_tokens = New_Token_Buffer(); 01499 symtab = PU_lexical_level(pu); 01500 01501 WN2F_Append_Symtab_Vars(decl_tokens, GLOBAL_SYMTAB, 1); 01502 01503 if (!W2F_Purple_Emission && !Is_Empty_Token_Buffer(decl_tokens)) 01504 WHIRL2F_Append_Comment(tokens, 01505 "**** Global Variables & Derived Type Definitions ****", 1, 1); 01506 Append_And_Reclaim_Token_List(tokens, &decl_tokens); 01507 01508 if (!W2F_Purple_Emission && !Is_Empty_Token_Buffer(param_tokens)) { 01509 WHIRL2F_Append_Comment(tokens, 01510 "**** Parameters and Result ****", 1, 1); 01511 01512 Append_And_Reclaim_Token_List(tokens, ¶m_tokens); 01513 } 01514 01515 decl_tokens = New_Token_Buffer(); 01516 WN2F_Append_Symtab_Vars(decl_tokens, symtab, 1/*Newlines*/); 01517 Stab_Reset_Referenced_Flag(symtab); 01518 01519 Stab_Reset_Referenced_Flag(GLOBAL_SYMTAB); 01520 01521 if (!W2F_Purple_Emission && !Is_Empty_Token_Buffer(decl_tokens)) 01522 { 01523 WHIRL2F_Append_Comment(tokens, 01524 "**** Local Variables and Functions ****", 1, 1); 01525 Append_And_Reclaim_Token_List(tokens, &decl_tokens); 01526 } 01527 /* Declare pseudo registers and other temporary variables after 01528 * regular variables, since the declaration of these may create 01529 * more temporary variables (e.g. to handle implied do-loops 01530 * in initializers). 01531 */ 01532 01533 if (!W2F_Purple_Emission && !Is_Empty_Token_Buffer(PUinfo_local_decls)) 01534 WHIRL2F_Append_Comment(tokens, "**** Temporary Variables ****",1,1); 01535 Append_And_Reclaim_Token_List(tokens, &PUinfo_local_decls); 01536 01537 01538 /* Emit DATA statements; i.e. initializers */ 01539 01540 if (!W2F_Purple_Emission && !Is_Empty_Token_Buffer(Data_Stmt_Tokens)) 01541 WHIRL2F_Append_Comment(tokens, 01542 "**** Initializers ****", 1, 1); 01543 Append_And_Reclaim_Token_List(tokens, &Data_Stmt_Tokens); 01544 01545 if (!W2F_Purple_Emission && !Is_Empty_Token_Buffer(PUinfo_pragmas)) 01546 WHIRL2F_Append_Comment(tokens, 01547 "**** Top Level Pragmas ****", 1, 1); 01548 Append_And_Reclaim_Token_List(tokens, &PUinfo_pragmas); 01549 01550 01551 /* If this is a purple code-extraction, insert a placeholder 01552 * for purple-specific initialization. 01553 */ 01554 01555 if (W2F_Purple_Emission) 01556 { 01557 /* <#PRP_XSYM:INIT_DECL name, id, sclass, export#> 01558 */ 01559 Append_F77_Indented_Newline(tokens, 1, NULL/*label*/); 01560 Append_Token_String(tokens, "<#PRP_XSYM:INIT_DECL"); 01561 WN2F_Append_Purple_Funcinfo(tokens); 01562 Append_Token_String(tokens, "#>"); 01563 } 01564 01565 /* Append the statements to the tokens */ 01566 01567 if (!W2F_Purple_Emission) 01568 WHIRL2F_Append_Comment(tokens, "**** Statements ****", 1, 1); 01569 Append_And_Reclaim_Token_List(tokens, stmts); 01570 01571 if (W2F_Purple_Emission && 01572 strcmp(W2F_Object_Name(PUINFO_FUNC_ST), WN2F_Purple_Region_Name) == 0) 01573 { 01574 /* <#PRP_XSYM:TEST name, id, sclass, export#> 01575 */ 01576 Append_F77_Indented_Newline(tokens, 1, NULL/*label*/); 01577 Append_Token_String(tokens, "<#PRP_XSYM:TEST"); 01578 WN2F_Append_Purple_Funcinfo(tokens); 01579 Append_Token_String(tokens, "#>"); 01580 } 01581 01582 WN2F_Next_ReturnSite = NULL; 01583 WN2F_Prev_CallSite = NULL; 01584 haveCommonBlockName(NULL); 01585 } /* WN2F_Exit_PU_Block */ 01586 01587 /*-------- The initializers and handlers statement translation --------*/ 01588 /*---------------------------------------------------------------------*/ 01589 01590 void 01591 WN2F_Stmt_initialize(void) 01592 { 01593 /* Nothing to do at the moment */ 01594 } /* WN2F_Stmt_initialize */ 01595 01596 01597 void 01598 WN2F_Stmt_finalize(void) 01599 { 01600 /* Nothing to do at the moment */ 01601 } /* WN2F_Stmt_finalize */ 01602 01603 01604 BOOL 01605 WN2F_Skip_Stmt(WN *stmt) 01606 { 01607 return ((W2F_No_Pragmas && \ 01608 (WN_operator(stmt) == OPR_PRAGMA || 01609 WN_operator(stmt) == OPR_XPRAGMA) && 01610 WN_pragma(stmt) != WN_PRAGMA_PREAMBLE_END) || /* For purple */\ 01611 01612 WN2F_Skip_Pragma_Stmt(stmt) || 01613 01614 (!W2F_Emit_Prefetch && 01615 (WN_operator(stmt) == OPR_PREFETCH || 01616 WN_operator(stmt) == OPR_PREFETCHX)) || 01617 01618 (WN2F_Next_ReturnSite != NULL && 01619 (stmt == RETURNSITE_store1(WN2F_Next_ReturnSite) || 01620 stmt == RETURNSITE_store2(WN2F_Next_ReturnSite))) || 01621 01622 (WN2F_Prev_CallSite != NULL && 01623 (stmt == CALLSITE_store1(WN2F_Prev_CallSite) || 01624 stmt == CALLSITE_store2(WN2F_Prev_CallSite))) 01625 ); 01626 } /* WN2F_Skip_Stmt */ 01627 01628 01629 // find and emit any COMMONS that are initialized. 01630 // used by WN2F_Append_Block_Data below. 01631 01632 struct WN2F_emit_commons{ 01633 private: 01634 TOKEN_BUFFER tokens; 01635 01636 public: 01637 WN2F_emit_commons(TOKEN_BUFFER tb) : tokens(tb) {} 01638 01639 void operator() (UINT32, ST* st) const { 01640 if (ST_sclass(st) == SCLASS_DGLOBAL) 01641 if(ST_is_initialized(st)) { 01642 if (!Has_Base_Block(st) || 01643 ST_class(ST_base_idx(st)) == CLASS_BLOCK) { 01644 ST2F_decl_translate(tokens,st); 01645 } 01646 } 01647 } 01648 }; 01649 01650 // Create a BLOCK DATA if any COMMONs in the global symbol 01651 // table are initialized. BLOCK DATA names are lost, but 01652 // that's ok - all (global) initializations that appeared 01653 // in the file are here. 01654 01655 void 01656 WN2F_Append_Block_Data(TOKEN_BUFFER tokens) 01657 { 01658 TOKEN_BUFFER Decl_Stmt_Tokens ; 01659 01660 Decl_Stmt_Tokens = New_Token_Buffer() ; 01661 Data_Stmt_Tokens = New_Token_Buffer() ; 01662 PUinfo_local_decls = New_Token_Buffer() ; 01663 01664 For_all(St_Table,GLOBAL_SYMTAB,WN2F_emit_commons(Decl_Stmt_Tokens)) ; 01665 01666 if (!Is_Empty_Token_Buffer(Decl_Stmt_Tokens)) 01667 { 01668 Append_F77_Indented_Newline(tokens, 1, NULL); 01669 Append_Token_String(tokens, "BLOCK DATA"); 01670 01671 # if 0 01672 Append_F77_Indented_Newline(tokens, 1, NULL); 01673 Append_Token_String(tokens, "IMPLICIT NONE"); 01674 # endif 01675 01676 WHIRL2F_Append_Comment(tokens, "**** Variables ****", 1, 1); 01677 Append_F77_Indented_Newline(tokens, 1, NULL); 01678 Append_And_Reclaim_Token_List(tokens, &Decl_Stmt_Tokens); 01679 01680 Append_And_Reclaim_Token_List(tokens,&PUinfo_local_decls); 01681 01682 if (!Is_Empty_Token_Buffer(Data_Stmt_Tokens)) 01683 { 01684 01685 WHIRL2F_Append_Comment(tokens, "**** Statements ****", 1, 1); 01686 Append_And_Reclaim_Token_List(tokens, &Data_Stmt_Tokens); 01687 } 01688 01689 Append_F77_Indented_Newline(tokens, 1, NULL) ; 01690 Append_Token_String(tokens, "END") ; 01691 Append_Token_Special(tokens, '\n'); 01692 } 01693 01694 } 01695 01696 void 01697 WN2F_Append_Purple_Funcinfo(TOKEN_BUFFER tokens) 01698 { 01699 const char *name = W2F_Object_Name(PUINFO_FUNC_ST); 01700 mUINT32 id = ST_st_idx(PUINFO_FUNC_ST); 01701 ST_SCLASS sclass = ST_sclass(PUINFO_FUNC_ST); 01702 ST_EXPORT export_class = (ST_EXPORT) ST_export(PUINFO_FUNC_ST); 01703 01704 Append_Token_String(tokens, name); 01705 Append_Token_Special(tokens, ','); 01706 if (strcmp(name, WN2F_Purple_Region_Name) == 0) 01707 { 01708 /* This must match the setting in PRP_TRACE_READER::_Read_Next() 01709 * when a region is entered. 01710 */ 01711 id = 0xffffffff; 01712 sclass = SCLASS_TEXT; 01713 export_class = EXPORT_INTERNAL; 01714 } 01715 Append_Token_String(tokens, Number_as_String(id, "%llu")); 01716 Append_Token_Special(tokens, ','); 01717 Append_Token_String(tokens, Number_as_String(sclass, "%lld")); 01718 Append_Token_Special(tokens, ','); 01719 Append_Token_String(tokens, Number_as_String(export_class, "%lld")); 01720 Append_Token_Special(tokens, ','); 01721 Append_Token_String(tokens, "0"); /* Flags */ 01722 } /* WN2F_Append_Purple_Funcinfo */ 01723 01724 01725 WN2F_STATUS 01726 WN2F_block(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01727 { 01728 WN *stmt; 01729 WN *induction_step = NULL; 01730 TOKEN_BUFFER stmt_tokens; 01731 const BOOL is_pu_block = WN2F_CONTEXT_new_pu(context); 01732 const BOOL add_induction_step = WN2F_CONTEXT_insert_induction(context); 01733 01734 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_BLOCK, 01735 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_block")); 01736 01737 01738 if (add_induction_step) 01739 { 01740 induction_step = WN2F_CONTEXT_induction_stmt(context); 01741 reset_WN2F_CONTEXT_induction_step(context); 01742 } 01743 01744 if (is_pu_block) 01745 { 01746 WN2F_Enter_PU_Block(); 01747 reset_WN2F_CONTEXT_new_pu(context); 01748 } 01749 01750 /* Translate statements and determine variable usage */ 01751 stmt_tokens = New_Token_Buffer(); 01752 for (stmt = WN_first(wn); stmt != NULL; stmt = WN_next(stmt)) 01753 { 01754 if (!WN2F_Skip_Stmt(stmt)) 01755 { 01756 if (induction_step != NULL && 01757 WN_next(stmt) == NULL && 01758 WN_operator(stmt) == OPR_LABEL) 01759 { 01760 /* Add induction step before loop-label */ 01761 (void)WN2F_translate(stmt_tokens, induction_step, context); 01762 induction_step = NULL; 01763 } 01764 (void)WN2F_translate(stmt_tokens, stmt, context); 01765 01766 /* Append frequency feedback info in a comment 01767 */ 01768 if (W2F_Emit_Frequency && 01769 W2F_Frequency_Map != WN_MAP_UNDEFINED && 01770 WN_MAP32_Get(W2F_Frequency_Map, stmt) >= 0 && 01771 WN_operator(stmt) != OPR_REGION && 01772 WN_operator(stmt) != OPR_PRAGMA && 01773 WN_operator(stmt) != OPR_XPRAGMA && 01774 WN_operator(stmt) != OPR_TRAP && 01775 WN_operator(stmt) != OPR_ASSERT && 01776 WN_operator(stmt) != OPR_FORWARD_BARRIER && 01777 WN_operator(stmt) != OPR_BACKWARD_BARRIER) 01778 { 01779 INT32 freq = WN_MAP32_Get(W2F_Frequency_Map, stmt); 01780 Append_Token_String(tokens, " !FREQ="); 01781 Append_Token_String(tokens, WHIRL2F_number_as_name(freq)); 01782 } 01783 } 01784 } 01785 01786 /* Append the induction-step as the last statement in the block */ 01787 if (induction_step != NULL) 01788 (void)WN2F_translate(stmt_tokens, induction_step, context); 01789 01790 if (is_pu_block) 01791 WN2F_Exit_PU_Block(tokens, &stmt_tokens); 01792 else 01793 { 01794 Append_And_Reclaim_Token_List(tokens, &stmt_tokens); 01795 } 01796 return EMPTY_WN2F_STATUS; 01797 } /* WN2F_block */ 01798 01799 01800 WN2F_STATUS 01801 WN2F_compgoto(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01802 { 01803 WN *goto_stmt; 01804 INT32 goto_entry; 01805 const char *label_num; 01806 01807 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_COMPGOTO, 01808 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_compgoto")); 01809 ASSERT_DBG_FATAL(WN_operator(WN_compgoto_table(wn)) == OPR_BLOCK, 01810 (DIAG_W2F_UNEXPECTED_OPC, "WN_compgoto_table")); 01811 01812 /* Calculate the computed goto for the given cases */ 01813 if (WN_compgoto_num_cases(wn) > 0) 01814 { 01815 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 01816 Append_Token_String(tokens, "GO TO"); 01817 Append_Token_Special(tokens, '('); 01818 goto_stmt = WN_first(WN_compgoto_table(wn)); 01819 for (goto_entry = 0; 01820 goto_entry < WN_compgoto_num_cases(wn); 01821 goto_entry++) 01822 { 01823 ASSERT_DBG_FATAL(WN_operator(goto_stmt) == OPR_GOTO, 01824 (DIAG_W2F_UNEXPECTED_OPC, "COMPGOTO entry")); 01825 label_num = WHIRL2F_number_as_name(WN_label_number(goto_stmt)); 01826 Append_Token_String(tokens, label_num); 01827 if (goto_entry+1 < WN_compgoto_num_cases(wn)) 01828 Append_Token_Special(tokens, ','); 01829 goto_stmt = WN_next(goto_stmt); 01830 } 01831 Append_Token_Special(tokens, ')'); 01832 Append_Token_Special(tokens, ','); 01833 01834 /* Need to add one to the controlling expression, since it is 01835 * zero-based in WHIRL and 1-based in Fortran. 01836 */ 01837 (void)WN2F_translate(tokens, WN_compgoto_idx(wn), context); 01838 Append_Token_Special(tokens, '+'); 01839 Append_Token_String(tokens, "1"); 01840 } 01841 01842 /* Handle the default case as just a regular goto statement */ 01843 if (WN_compgoto_has_default_case(wn)) 01844 WN2F_goto(tokens, WN_kid(wn,2), context); 01845 01846 return EMPTY_WN2F_STATUS; 01847 } /* WN2F_compgoto */ 01848 01849 01850 WN2F_STATUS 01851 WN2F_do_loop(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01852 { 01853 /* It is somewhat complicated to always translate this correctly 01854 * back to Fortran, dependent on the form of the test-for-termination 01855 * and the idx-variable-increment expressions. When we deem it too 01856 * complicated to be coped with, we generate a DO WHILE expression 01857 * instead. This is an area we can probably always improve with more 01858 * work. 01859 */ 01860 STAB_OFFSET idx_ofst; 01861 ST *idx_var; 01862 WN *step_size; 01863 DO_LOOP_BOUND *bound; 01864 WN *loop_info; 01865 01866 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_DO_LOOP, 01867 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_do_loop")); 01868 ASSERT_DBG_FATAL(WN_operator(WN_start(wn)) == OPR_STID, 01869 (DIAG_W2F_UNEXPECTED_OPC, "WN_start")); 01870 ASSERT_DBG_FATAL(WN_operator(WN_do_body(wn)) == OPR_BLOCK, 01871 (DIAG_W2F_UNEXPECTED_OPC, "WN_do_body")); 01872 01873 if (W2F_Prompf_Emission) 01874 WN2F_Start_Prompf_Transformed_Loop(tokens, wn, context); 01875 01876 loop_info = WN_do_loop_info(wn); 01877 if (W2F_Emit_Cgtag && loop_info != NULL) 01878 WHIRL2F_Append_Comment( 01879 tokens, 01880 Concat2_Strings("LOOPINFO #", 01881 WHIRL2F_number_as_name((INT64)loop_info)), 01882 1, 01883 1); 01884 01885 /* Whether or not we can generate a DO loop depends on the forms 01886 * of WN_end(wn) and WN_step(wn), so the first thing we need to 01887 * do is to accumulate some information about these. 01888 */ 01889 idx_var = WN_st(WN_index(wn)); 01890 idx_ofst = WN_idname_offset(WN_index(wn)); 01891 step_size = WN2F_Get_DoLoop_StepSize(WN_step(wn), idx_var, idx_ofst); 01892 bound = WN2F_Get_DoLoop_Bound(WN_end(wn), idx_var, idx_ofst, step_size); 01893 01894 if (bound != NULL) 01895 { 01896 /* Generate a DO LOOP statement */ 01897 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 01898 Append_Token_String(tokens, "DO"); 01899 set_WN2F_CONTEXT_emit_stid(context); 01900 if (!WN2F_CONTEXT_no_newline(context)) 01901 { 01902 set_WN2F_CONTEXT_no_newline(context); 01903 (void)WN2F_translate(tokens, WN_start(wn), context); 01904 reset_WN2F_CONTEXT_no_newline(context); 01905 } 01906 else 01907 { 01908 (void)WN2F_translate(tokens, WN_start(wn), context); 01909 } 01910 reset_WN2F_CONTEXT_emit_stid(context); 01911 Append_Token_Special(tokens, ','); 01912 01913 (void)WN2F_Translate_DoLoop_Bound(tokens, bound, context); 01914 Append_Token_Special(tokens, ','); 01915 01916 (void)WN2F_translate(tokens, step_size, context); 01917 01918 Increment_Indentation(); 01919 (void)WN2F_translate(tokens, WN_do_body(wn), context); 01920 Decrement_Indentation(); 01921 01922 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 01923 Append_Token_String(tokens, "END DO"); 01924 } 01925 else /* Generate a DO WHILE loop */ 01926 { 01927 (void)WN2F_translate(tokens, WN_start(wn), context); 01928 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 01929 Append_Token_String(tokens, "DO WHILE"); 01930 Append_Token_Special(tokens, '('); 01931 set_WN2F_CONTEXT_has_logical_arg(context); 01932 set_WN2F_CONTEXT_no_parenthesis(context); 01933 (void)WN2F_translate(tokens, WN_end(wn), context); 01934 reset_WN2F_CONTEXT_no_parenthesis(context); 01935 reset_WN2F_CONTEXT_has_logical_arg(context); 01936 Append_Token_Special(tokens, ')'); 01937 Increment_Indentation(); 01938 set_WN2F_CONTEXT_induction_step(context, WN_step(wn)); 01939 (void)WN2F_translate(tokens, WN_do_body(wn), context); 01940 Decrement_Indentation(); 01941 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 01942 Append_Token_String(tokens, "END DO"); 01943 } 01944 01945 if (W2F_Prompf_Emission) 01946 WN2F_End_Prompf_Transformed_Loop(tokens, wn, context); 01947 01948 return EMPTY_WN2F_STATUS; 01949 } /* WN2F_do_loop */ 01950 01951 01952 WN2F_STATUS 01953 WN2F_implied_do(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01954 { 01955 /* This is a fortran implied do_loop, which can only occur as an 01956 * an OPR_IO_ITEM. We should always be able to regenerate 01957 * an implied do-loop from this WHIRL tree, and we should safely 01958 * be able to assert that WN2F_CONTEXT_io_stmt is TRUE. Strictly 01959 * speaking this can be viewed as an expression, rather than as a 01960 * statement, but due to the commonality with regular do-loops 01961 * we handle it in this module. 01962 */ 01963 INT kid; 01964 BOOL emitted; 01965 ST *idx_name; 01966 01967 ASSERT_DBG_FATAL(WN2F_CONTEXT_io_stmt(context) && 01968 WN2F_CONTEXT_no_newline(context), 01969 (DIAG_W2F_UNEXPECTED_CONTEXT, "WN2F_implied_do")); 01970 01971 /* Start an implied do-loop expression */ 01972 Append_Token_Special(tokens, '('); 01973 01974 /* Generate all the expression trees, separated by commas */ 01975 for (kid = 4; kid < WN_kid_count(wn); kid++) 01976 { 01977 emitted = WN2F_io_item(tokens, WN_kid(wn, kid), context); 01978 if (emitted) 01979 Append_Token_Special(tokens, ','); 01980 } 01981 01982 /* Generate the loop expression */ 01983 idx_name = WN_st(WN_index(wn)); 01984 WN2F_Offset_Symref(tokens, 01985 idx_name, /* base-symbol */ 01986 Stab_Pointer_To(ST_type(idx_name)), /* base-type */ 01987 ST_type(idx_name), /* object-type */ 01988 0, /* object-ofst */ 01989 context); 01990 Append_Token_Special(tokens, '='); 01991 (void)WN2F_translate(tokens, WN_start(wn), context); 01992 Append_Token_Special(tokens, ','); 01993 (void)WN2F_translate(tokens, WN_end(wn), context); 01994 Append_Token_Special(tokens, ','); 01995 (void)WN2F_translate(tokens, WN_step(wn), context); 01996 01997 /* Terminate the implied do-loop expression */ 01998 Append_Token_Special(tokens, ')'); 01999 02000 return EMPTY_WN2F_STATUS; 02001 } /* WN2F_implied_do */ 02002 02003 02004 WN2F_STATUS 02005 WN2F_do_while(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02006 { 02007 const char *tmpvar_name; 02008 UINT tmpvar_idx; 02009 TY_IDX logical_ty; 02010 02011 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_DO_WHILE, 02012 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_do_while")); 02013 02014 /* The base-type of the logical expression. Note that TY_is_logical() 02015 * will only hold true when the TY is resolved from a WN_ty or ST_ty 02016 * attribute, not when it is resolved from an MTYPE (descriptor or 02017 * result type). 02018 */ 02019 logical_ty = WN_Tree_Type(WN_while_test(wn)); 02020 02021 if (W2F_Prompf_Emission) 02022 WN2F_Start_Prompf_Transformed_Loop(tokens, wn, context); 02023 02024 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02025 WHIRL2F_Append_Comment(tokens, 02026 "whirl2f:: DO loop with termination test after first iteration", 1, 1); 02027 02028 /* termination test initialization (in temporary variable) */ 02029 tmpvar_idx = Stab_Lock_Tmpvar(logical_ty, &ST2F_Declare_Tempvar); 02030 tmpvar_name = W2CF_Symtab_Nameof_Tempvar(tmpvar_idx); 02031 Append_Token_String(tokens, tmpvar_name); 02032 Append_Token_Special(tokens, '='); 02033 Append_Token_String(tokens, ".TRUE."); 02034 02035 /* loop header */ 02036 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02037 Append_Token_String(tokens, "DO WHILE"); 02038 Append_Token_Special(tokens, '('); 02039 Append_Token_String(tokens, tmpvar_name); 02040 Append_Token_Special(tokens, ')'); 02041 02042 /* loop body and termination test initialization (in temporary variable) */ 02043 Increment_Indentation(); 02044 (void)WN2F_translate(tokens, WN_while_body(wn), context); 02045 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02046 Append_Token_String(tokens, tmpvar_name); 02047 Append_Token_Special(tokens, '='); 02048 set_WN2F_CONTEXT_has_logical_arg(context); 02049 (void)WN2F_translate(tokens, WN_while_test(wn), context); 02050 reset_WN2F_CONTEXT_has_logical_arg(context); 02051 Decrement_Indentation(); 02052 02053 /* Close the loop and allow reuse of the termination test 02054 * temporary variable. 02055 */ 02056 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02057 Append_Token_String(tokens, "END DO"); 02058 Stab_Unlock_Tmpvar(tmpvar_idx); 02059 02060 if (W2F_Prompf_Emission) 02061 WN2F_End_Prompf_Transformed_Loop(tokens, wn, context); 02062 02063 return EMPTY_WN2F_STATUS; 02064 } /* WN2F_do_while */ 02065 02066 02067 WN2F_STATUS 02068 WN2F_while_do(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02069 { 02070 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_WHILE_DO, 02071 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_while_do")); 02072 02073 if (W2F_Prompf_Emission) 02074 WN2F_Start_Prompf_Transformed_Loop(tokens, wn, context); 02075 02076 /* Termination test */ 02077 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02078 Append_Token_String(tokens, "DO WHILE"); 02079 Append_Token_Special(tokens, '('); 02080 set_WN2F_CONTEXT_has_logical_arg(context); 02081 set_WN2F_CONTEXT_no_parenthesis(context); 02082 (void)WN2F_translate(tokens, WN_while_test(wn), context); 02083 reset_WN2F_CONTEXT_no_parenthesis(context); 02084 reset_WN2F_CONTEXT_has_logical_arg(context); 02085 Append_Token_Special(tokens, ')'); 02086 02087 /* loop body */ 02088 Increment_Indentation(); 02089 (void)WN2F_translate(tokens, WN_while_body(wn), context); 02090 Decrement_Indentation(); 02091 02092 /* close the loop */ 02093 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02094 Append_Token_String(tokens, "END DO"); 02095 02096 if (W2F_Prompf_Emission) 02097 WN2F_End_Prompf_Transformed_Loop(tokens, wn, context); 02098 02099 return EMPTY_WN2F_STATUS; 02100 } /* WN2F_while_do */ 02101 02102 02103 WN2F_STATUS 02104 WN2F_if(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02105 { 02106 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_IF, 02107 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_if")); 02108 02109 /* Ignore if-guards inserted by lno, since these are redundant 02110 * in High WHIRL. 02111 */ 02112 if (WN_Is_If_Guard(wn)) 02113 { 02114 /* Emit only the THEN body, provided it is non-empty */ 02115 if (WN_operator(WN_then(wn)) != OPR_BLOCK || 02116 WN_first(WN_then(wn)) != NULL) 02117 { 02118 WN2F_translate(tokens, WN_then(wn), context); 02119 } 02120 } 02121 else /* Not a redundant guard (from whirl2f perspective) */ 02122 { 02123 /* IF header */ 02124 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02125 Append_Token_String(tokens, "IF"); 02126 Append_Token_Special(tokens, '('); 02127 set_WN2F_CONTEXT_has_logical_arg(context); 02128 set_WN2F_CONTEXT_no_parenthesis(context); 02129 (void)WN2F_translate(tokens, WN_if_test(wn), context); 02130 reset_WN2F_CONTEXT_no_parenthesis(context); 02131 reset_WN2F_CONTEXT_has_logical_arg(context); 02132 Append_Token_Special(tokens, ')'); 02133 Append_Token_String(tokens, "THEN"); 02134 02135 /* THEN body */ 02136 Increment_Indentation(); 02137 (void)WN2F_translate(tokens, WN_then(wn), context); 02138 Decrement_Indentation(); 02139 02140 /* ELSE body */ 02141 if (!WN_else_is_empty(wn)) 02142 { 02143 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02144 Append_Token_String(tokens, "ELSE"); 02145 Increment_Indentation(); 02146 (void)WN2F_translate(tokens, WN_else(wn), context); 02147 Decrement_Indentation(); 02148 } 02149 02150 /* if closing */ 02151 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02152 Append_Token_String(tokens, "ENDIF"); 02153 } /* if WN_Is_If_Guard */ 02154 02155 return EMPTY_WN2F_STATUS; 02156 } /* WN2F_if */ 02157 02158 02159 WN2F_STATUS 02160 WN2F_goto(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02161 { 02162 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_GOTO || 02163 WN_operator(wn) == OPR_REGION_EXIT, 02164 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_goto")); 02165 02166 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02167 Append_Token_String(tokens, "GO TO"); 02168 Append_Token_String(tokens, WHIRL2F_number_as_name(WN_label_number(wn))); 02169 02170 return EMPTY_WN2F_STATUS; 02171 } /* WN2F_goto */ 02172 02173 02174 WN2F_STATUS 02175 WN2F_agoto(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02176 { 02177 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_AGOTO, 02178 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_agoto")); 02179 02180 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02181 Append_Token_String(tokens, "GO TO"); 02182 (void)WN2F_translate(tokens, WN_kid0(wn), context); 02183 02184 return EMPTY_WN2F_STATUS; 02185 } /* WN2F_agoto */ 02186 02187 02188 WN2F_STATUS 02189 WN2F_condbr(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02190 { 02191 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_TRUEBR || 02192 WN_operator(wn) == OPR_FALSEBR, 02193 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_condbr")); 02194 02195 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02196 Append_Token_String(tokens, "IF"); 02197 Append_Token_Special(tokens, '('); 02198 set_WN2F_CONTEXT_has_logical_arg(context); 02199 set_WN2F_CONTEXT_no_parenthesis(context); 02200 if (WN_operator(wn) == OPR_FALSEBR) 02201 { 02202 Append_Token_String(tokens, ".NOT."); 02203 Append_Token_Special(tokens, '('); 02204 (void)WN2F_translate(tokens, WN_condbr_cond(wn), context); 02205 Append_Token_Special(tokens, ')'); 02206 } 02207 else /* WN_operator(wn) == OPR_TRUEBR */ 02208 { 02209 (void)WN2F_translate(tokens, WN_condbr_cond(wn), context); 02210 } 02211 reset_WN2F_CONTEXT_no_parenthesis(context); 02212 reset_WN2F_CONTEXT_has_logical_arg(context); 02213 Append_Token_Special(tokens, ')'); 02214 Append_Token_String(tokens, "GO TO"); 02215 Append_Token_String(tokens, WHIRL2F_number_as_name(WN_label_number(wn))); 02216 02217 return EMPTY_WN2F_STATUS; 02218 } /* WN2F_condbr */ 02219 02220 WN2F_STATUS 02221 WN2F_return(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02222 { 02223 /* Ensures that the return value resides in the implicit 02224 * return variable (PUINFO_FUNC_NAME), and returns control 02225 * from the current PU (PUinfo_current_func). 02226 */ 02227 02228 if (WN2F_Next_ReturnSite ==NULL) 02229 return EMPTY_WN2F_STATUS; 02230 02231 ST *result_var = 02232 (ST *)RETURNSITE_return_var(WN2F_Next_ReturnSite); 02233 const WN *result_store = RETURNSITE_store1(WN2F_Next_ReturnSite); 02234 const STAB_OFFSET var_offset = RETURNSITE_var_offset(WN2F_Next_ReturnSite); 02235 02236 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_RETURN, 02237 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_return")); 02238 02239 ASSERT_DBG_FATAL(RETURNSITE_return(WN2F_Next_ReturnSite) == wn, 02240 (DIAG_W2F_UNEXPECTED_RETURNSITE, "WN2F_return()")); 02241 02242 /* Do not emit a return statement for the main program unit. 02243 */ 02244 if (PU_is_mainpu(Get_Current_PU()) || 02245 strcmp(ST_name(WN_entry_name(PUinfo_current_func)), "MAIN__") == 0) 02246 { 02247 WN2F_Next_ReturnSite = RETURNSITE_next(WN2F_Next_ReturnSite); 02248 return EMPTY_WN2F_STATUS; 02249 02250 } 02251 // if this is called with the openad flag omit final returns 02252 if (W2F_OpenAD && // flag is set 02253 WN_kid_count(wn) == 0 && // no kids 02254 WN_last(WN_kid(PUinfo_current_func,WN_kid_count(PUinfo_current_func)-1))==wn) { 02255 // it is the last statement in the last block directly under the FUNCENTRY 02256 WN2F_Next_ReturnSite = RETURNSITE_next(WN2F_Next_ReturnSite); 02257 return EMPTY_WN2F_STATUS; 02258 } 02259 /* Save off the return-value, unless there is no return-value or 02260 * it already resides where we expect it to be. 02261 */ 02262 if (!PUINFO_RETURN_TO_PARAM && 02263 PUINFO_RETURN_TY != (TY_IDX) 0 && 02264 TY_kind(PUINFO_RETURN_TY) != KIND_VOID && 02265 RETURN_PREG_mtype(PUinfo_return_preg, 0) != MTYPE_V) 02266 { 02267 /* Note that we make more assumptions here than in the case 02268 * of whirl2c. In particular, we always assume assignment 02269 * compatibility between the return-variable and the location 02270 * of the found return-value. 02271 */ 02272 if (result_var != NULL) 02273 { 02274 if (ST_class(result_var) == CLASS_PREG || 02275 !ST_is_return_var(result_var)) 02276 { 02277 /* PUinfo_init_pu() revealed that the return value is present 02278 * in a variable or non-return-register. Now, move the value to 02279 * this return location. 02280 */ 02281 TY_IDX rv_ty = ST_type(result_var); 02282 02283 if (TY_kind(rv_ty) != KIND_STRUCT) 02284 { 02285 ASSERT_WARN(WN2F_Can_Assign_Types(rv_ty, 02286 PUINFO_RETURN_TY), 02287 (DIAG_W2F_INCOMPATIBLE_TYS, "WN2F_return")); 02288 } 02289 02290 /* Assign the return value to PUINFO_FUNC_ST */ 02291 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02292 ST2F_use_translate(tokens, PUINFO_FUNC_ST); 02293 Append_Token_Special(tokens, '='); 02294 if (ST_class(result_var) == CLASS_PREG) 02295 ST2F_Use_Preg(tokens, ST_type(result_var),var_offset); 02296 else 02297 WN2F_Offset_Symref(tokens, 02298 result_var, /* base variable */ 02299 Stab_Pointer_To(ST_type(result_var)), 02300 /* expected type of base address */ 02301 PUINFO_RETURN_TY, 02302 /* type of object to be loaded */ 02303 var_offset, 02304 context); 02305 } 02306 } 02307 else if (result_store != NULL) 02308 { 02309 /* We have a store (an STID) into the return register, so just 02310 * assign the rhs into PUINFO_FUNC_NAME. 02311 */ 02312 ASSERT_DBG_FATAL(WN_operator(result_store) == OPR_STID, 02313 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_return")); 02314 ASSERT_WARN(WN2F_Can_Assign_Types(WN_Tree_Type(WN_kid0(result_store)), 02315 PUINFO_RETURN_TY), 02316 (DIAG_W2F_INCOMPATIBLE_TYS, "WN2F_return")); 02317 02318 /* Assign object being stored to PUINFO_FUNC_NAME */ 02319 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02320 ST2F_use_translate(tokens, PUINFO_FUNC_ST); 02321 Append_Token_Special(tokens, '='); 02322 (void)WN2F_translate(tokens, WN_kid0(result_store), context); 02323 } 02324 else if (RETURN_PREG_num_pregs(PUinfo_return_preg) == 1 && 02325 TY_Is_Preg_Type(PUINFO_RETURN_TY)) 02326 { 02327 /* There is a single return register holding the return value, 02328 * so return a reference to this register. 02329 */ 02330 const MTYPE preg_mtype = RETURN_PREG_mtype(PUinfo_return_preg, 0); 02331 TY_IDX const preg_ty = Stab_Mtype_To_Ty(preg_mtype); 02332 const PREG_IDX preg_num = RETURN_PREG_offset(PUinfo_return_preg, 0); 02333 02334 ASSERT_WARN(WN2F_Can_Assign_Types(preg_ty, PUINFO_RETURN_TY), 02335 (DIAG_W2F_INCOMPATIBLE_TYS, "WN2F_return")); 02336 02337 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02338 ST2F_use_translate(tokens, PUINFO_FUNC_ST); 02339 Append_Token_Special(tokens, '='); 02340 ST2F_Use_Preg(tokens, preg_ty, preg_num); 02341 } 02342 else /* Our most difficult case */ 02343 { 02344 /* The return-value is in two registers and we have not been 02345 * able to determine that it also resides in a variable. 02346 * TODO: 02347 * This could be handled by equivalencing the return-variable with 02348 * a type corresponding to the two registers, for then to assign 02349 * the register-values to the components of this equivalent 02350 * return value. For now, do nothing but warn about this case! 02351 */ 02352 # if 0 02353 ASSERT_WARN(FALSE, 02354 (DIAG_UNIMPLEMENTED, "WN2F_return from two registers")); 02355 #endif 02356 02357 } /* if */ 02358 } /* if (need to store return value) */ 02359 02360 /* Return control */ 02361 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02362 Append_Token_String(tokens, "RETURN"); 02363 02364 WN2F_Next_ReturnSite = RETURNSITE_next(WN2F_Next_ReturnSite); 02365 return EMPTY_WN2F_STATUS; 02366 } /* WN2F_return */ 02367 02368 WN2F_STATUS 02369 WN2F_return_val(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02370 { 02371 // char buf[64]; 02372 Is_True(WN_operator(wn) == OPR_RETURN_VAL, 02373 ("Invalid operator for WN2F_return_val()")); 02374 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02375 if (WN_operator(WN_kid0(wn)) == OPR_LDID) 02376 Append_Token_String(tokens, "RETURN"); 02377 else { 02378 Append_Token_String(tokens, "RETURN"); 02379 (void) WN2F_translate(tokens, WN_kid0(wn), context); 02380 } 02381 return EMPTY_WN2F_STATUS; 02382 } /* WN2F_return_val */ 02383 02384 WN2F_STATUS 02385 WN2F_label(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02386 { 02387 const char *label_num; 02388 02389 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_LABEL, 02390 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_label")); 02391 02392 label_num = WHIRL2F_number_as_name(WN_label_number(wn)); 02393 WN2F_Stmt_Newline(tokens, label_num, WN_Get_Linenum(wn), context); 02394 Append_Token_String(tokens, "CONTINUE"); 02395 return EMPTY_WN2F_STATUS; 02396 } /* WN2F_label */ 02397 02398 02399 WN2F_STATUS 02400 WN2F_intrinsic_call(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02401 { 02402 WN *arg_expr; 02403 TY_IDX arg_ty; 02404 INT str_kid, length_kid, first_length_kid; 02405 BOOL regular_call = FALSE; /* Specially treated intrinsic call? */ 02406 02407 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_INTRINSIC_CALL, 02408 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_intrinsic_call")); 02409 02410 switch (WN_intrinsic(wn)) 02411 { 02412 case INTRN_CONCATEXPR: 02413 02414 /* In the context of an IO statement, emit the concatenation 02415 * but disregard the temporary result buffer. 02416 */ 02417 02418 /* Determine the range of kids denoting the base of the string- 02419 * arguments and the the length of these strings respectively. 02420 */ 02421 str_kid = 1; 02422 length_kid = first_length_kid = (WN_kid_count(wn) + 2)/2; 02423 02424 /* Emit the concatenation operations */ 02425 WN2F_String_Argument(tokens, 02426 WN_kid(wn, str_kid), /* base of string1 */ 02427 WN_kid(wn, length_kid), /* length of string1 */ 02428 context); 02429 while ((++str_kid) < first_length_kid) 02430 { 02431 length_kid++; 02432 Append_Token_String(tokens, "//"); 02433 WN2F_String_Argument(tokens, 02434 WN_kid(wn, str_kid), /* base of stringN */ 02435 WN_kid(wn, length_kid), /* length of stringN */ 02436 context); 02437 } 02438 break; 02439 case INTRN_CASSIGNSTMT: 02440 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02441 WN2F_String_Argument(tokens, 02442 WN_kid(wn,0), /* base of destination */ 02443 WN_kid(wn,2), /* length of base */ 02444 context); 02445 Append_Token_Special(tokens, '='); 02446 WN2F_String_Argument(tokens, 02447 WN_kid(wn,1), /* base of source */ 02448 WN_kid(wn,3), /* length of source */ 02449 context); 02450 break; 02451 02452 case INTRN_STOP: 02453 case INTRN_STOP_F90: 02454 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02455 // Since this could be either the F90 stop or the F77 stop output the STOP 02456 // explicitly 02457 Append_Token_String(tokens, "STOP"); 02458 02459 /* Get the string argument type, where the second argument is 02460 * expected to be the string-length. 02461 */ 02462 arg_ty = WN_Tree_Type(WN_kid0(wn)); 02463 arg_expr = WN_Skip_Parm(WN_kid1(wn)); 02464 ASSERT_DBG_WARN(WN_operator(arg_expr) == OPR_INTCONST , 02465 (DIAG_W2F_UNEXPECTED_OPC, 02466 "for INTRN_STOP in WN2F_intrinsic_call")); 02467 02468 /* Only emit the string argument if it is of length > 0 */ 02469 if (WN_const_val(arg_expr) > 0LL) 02470 { 02471 fld_type_z = 0; 02472 WN2F_Offset_Memref(tokens, 02473 WN_kid0(wn), /* address expression */ 02474 arg_ty, /* address type */ 02475 TY_pointed(arg_ty), /* object type */ 02476 0, /* offset from address */ 02477 context); 02478 } 02479 break; 02480 02481 default: 02482 regular_call = TRUE; 02483 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02484 WN2F_call(tokens, wn, context); 02485 break; 02486 } 02487 02488 if (!regular_call && !WN2F_CONTEXT_io_stmt(context)) 02489 { 02490 /* Update the call site information to denote this one */ 02491 if (WN2F_Prev_CallSite == NULL) 02492 WN2F_Prev_CallSite = PUinfo_Get_CallSites(); 02493 else 02494 WN2F_Prev_CallSite = CALLSITE_next(WN2F_Prev_CallSite); 02495 02496 ASSERT_DBG_FATAL(CALLSITE_call(WN2F_Prev_CallSite) == wn, 02497 (DIAG_W2F_UNEXPECTED_CALLSITE, 02498 "WN2F_intrinsic_call()")); 02499 } 02500 02501 return EMPTY_WN2F_STATUS; 02502 } /* WN2F_intrinsic_call */ 02503 02504 02505 WN2F_STATUS 02506 WN2F_call(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02507 { 02508 /* Generates a function-call and ensures that the return value 02509 * is returned into the appropriate context, be it a variable 02510 * or a register. Note that intrinsic calls are dispatched to 02511 * this function from WN2F_intrinsic_call() when appropriate. 02512 * Make sure the handling of instrinsic ops in wn2f_expr.c is 02513 * kept up to date with changes that occur here. 02514 */ 02515 INT arg_idx, implicit_args, first_arg_idx, last_arg_idx; 02516 INT total_implicit_args; 02517 TOKEN_BUFFER call_tokens = New_Token_Buffer(); 02518 TY_IDX return_ty = 0 ; 02519 TY_IDX arg_ty; 02520 BOOL return_to_param; 02521 BOOL is_user_call = FALSE; 02522 BOOL has_stat = FALSE; 02523 BOOL is_allocate_stmt = FALSE; 02524 WN *kidofparm; 02525 TY_IDX kid_ty; 02526 TY_IDX parm_ty; 02527 BOOL first_nonemptyarg = FALSE; 02528 02529 /* Emit any relevant call-site directives 02530 */ 02531 02532 if (WN_operator(wn) == OPR_CALL || WN_operator(wn) == OPR_PICCALL) { 02533 is_user_call = TRUE; 02534 if (WN2F_CONTEXT_io_stmt(context)) 02535 /* Emit directives before io stmt */ 02536 WN2F_Callsite_Directives(WN2F_io_prefix_tokens(), wn, WN_st(wn)); 02537 else 02538 /* Emit directives before this stmt */ 02539 WN2F_Callsite_Directives(tokens, wn, WN_st(wn)); 02540 } 02541 02542 /* Begin the call statement on a new line, unless it is part of an io 02543 * statement. 02544 */ 02545 02546 02547 /* Tokenize the function-value expression and gather information 02548 * about the function type and index range of arguments. 02549 */ 02550 if (WN_operator(wn) == OPR_INTRINSIC_CALL) { 02551 /* Note that all intrinsics that return a CHARACTER string 02552 * will have been treated specially in WN2F_intrinsic_call(), 02553 * so we need only consider returns through a first non- 02554 * string parameter here. 02555 */ 02556 switch (WN_intrinsic(wn)) { 02557 case INTRN_F4VACOS: 02558 case INTRN_F8VACOS: 02559 case INTRN_F4VASIN: 02560 case INTRN_F8VASIN: 02561 case INTRN_F4VATAN: 02562 case INTRN_F8VATAN: 02563 case INTRN_F4VCOS: 02564 case INTRN_F8VCOS: 02565 case INTRN_F4VEXP: 02566 case INTRN_F8VEXP: 02567 case INTRN_F4VLOG: 02568 case INTRN_F8VLOG: 02569 case INTRN_F4VLOG10: 02570 case INTRN_F8VLOG10: 02571 case INTRN_F4VSIN: 02572 case INTRN_F8VSIN: 02573 case INTRN_F4VSQRT: 02574 case INTRN_F8VSQRT: 02575 case INTRN_F4VTAN: 02576 case INTRN_F8VTAN: 02577 /* Use the run-time library name for the vector intrinsic functions. 02578 */ 02579 Append_Token_String(call_tokens, 02580 Concat2_Strings(INTRN_rt_name(WN_intrinsic(wn)), 02581 "$")); 02582 break; 02583 02584 default: 02585 Append_Token_String(call_tokens, 02586 WN_intrinsic_name((INTRINSIC)WN_intrinsic(wn))); 02587 break; 02588 } 02589 return_ty = WN_intrinsic_return_ty(WN_opcode(wn), 02590 (INTRINSIC) WN_intrinsic(wn), wn); 02591 return_to_param = WN_intrinsic_return_to_param(return_ty); 02592 first_arg_idx = (return_to_param? 1 : 0); 02593 last_arg_idx = WN_kid_count(wn) - 1; 02594 } 02595 else { 02596 /* Only two things vary for CALL, ICALL, and PICCALL nodes: the 02597 * method used to get the function type and the last_arg_idx. 02598 */ 02599 TY_IDX func_ty; 02600 02601 if (WN_operator(wn) == OPR_CALL) { 02602 if (strcmp(ST_name(WN_st(wn)),"_ALLOCATE") !=0 && 02603 strcmp(ST_name(WN_st(wn)),"_END") !=0 && 02604 (strcmp(ST_name(WN_st(wn)),"_DEALLOCATE") !=0 )) 02605 02606 ST2F_use_translate(call_tokens, WN_st(wn)); 02607 else { 02608 if (strcmp(ST_name(WN_st(wn)),"_ALLOCATE")== 0 ) { 02609 is_allocate_stmt = TRUE; 02610 Append_Token_String(call_tokens,"ALLOCATE"); } 02611 else if (strcmp(ST_name(WN_st(wn)),"_DEALLOCATE")== 0) { 02612 Append_Token_String(call_tokens,"DEALLOCATE"); 02613 set_WN2F_CONTEXT_has_no_arr_elmt(context); 02614 is_allocate_stmt = TRUE; 02615 } 02616 } 02617 02618 if (strcmp(ST_name(WN_st(wn)),"PRESENT")== 0 || 02619 strcmp(ST_name(WN_st(wn)),"ASSOCIATED")==0 ) 02620 set_WN2F_CONTEXT_has_no_arr_elmt(context); 02621 02622 02623 if (strcmp(ST_name(WN_st(wn)),"ALLOCATED")== 0) { 02624 Append_Token_Special(call_tokens,'('); 02625 /* Get the array name,it shoud be CALL->PARM->ARRSECTION->LDA->st_name 02626 * Is there any other possible? 02627 * JU: we have e.g. CALL->PARM->LDID->st_name or a "value" selector injected 02628 */ 02629 // get PARM 02630 WN* kidWN_p=WN_kid0(wn); 02631 while(kidWN_p!=0) { 02632 if WN_has_sym(kidWN_p) { 02633 Append_Token_String(call_tokens, 02634 ST_name(WN_st(kidWN_p))); 02635 break; 02636 } 02637 kidWN_p=WN_kid0(kidWN_p); 02638 } 02639 ASSERT_DBG_FATAL(kidWN_p!=0, 02640 (DIAG_W2F_UNEXPECTED_CONTEXT, "no name found for ALLOCATED parameter")); 02641 Append_Token_Special(call_tokens,')'); 02642 Append_And_Reclaim_Token_List(tokens, &call_tokens); 02643 return EMPTY_WN2F_STATUS; 02644 } 02645 func_ty = ST_pu_type(WN_st(wn)); 02646 last_arg_idx = WN_kid_count(wn) - 1; 02647 } 02648 else if (WN_operator(wn) == OPR_ICALL) { 02649 (void)WN2F_translate(call_tokens, 02650 WN_kid(wn, WN_kid_count(wn) - 1), 02651 context); 02652 func_ty = WN_ty(wn); 02653 last_arg_idx = WN_kid_count(wn) - 2; 02654 } 02655 else { /* (WN_operator(wn) == OPR_PICCALL) */ 02656 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_PICCALL, 02657 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_call")); 02658 ST2F_use_translate(call_tokens, WN_st(wn)); 02659 func_ty = ST_type(WN_st(wn)); 02660 last_arg_idx = WN_kid_count(wn) - 2; 02661 } /* if OPR_CALL */ 02662 02663 return_ty = W2X_Unparse_Target->Func_Return_Type(func_ty); 02664 return_to_param = W2X_Unparse_Target->Func_Return_To_Param(func_ty); 02665 first_arg_idx = ST2F_FIRST_PARAM_IDX(func_ty); 02666 } /* if OPR_INTRINSIC_CALL */ 02667 02668 /* Determine the number of implicit arguments appended to the end 02669 * of the argument list (i.e. string lengths). 02670 */ 02671 for (arg_idx = first_arg_idx, total_implicit_args = 0; 02672 arg_idx <= last_arg_idx - total_implicit_args; 02673 arg_idx++) { 02674 if (WN_kid(wn,arg_idx)==NULL) 02675 ; 02676 else { 02677 kidofparm = WN_kid0(WN_kid(wn, arg_idx)); 02678 if (WN_operator(kidofparm) != OPR_CALL && 02679 WN_operator(kidofparm) != OPR_INTRINSIC_CALL) { 02680 arg_ty = WN_Tree_Type(WN_kid(wn, arg_idx)); 02681 parm_ty = WN_ty(WN_kid(wn,arg_idx)); 02682 #if 0 02683 if ((TY_Is_Character_Reference(arg_ty) 02684 || TY_Is_Chararray_Reference(arg_ty) 02685 || (TY_Is_Pointer(arg_ty) 02686 && TY_mtype(TY_pointed(arg_ty))==MTYPE_M 02687 && (TY_Is_Character_Reference(parm_ty) 02688 || TY_Is_Chararray_Reference(parm_ty)))) 02689 && !is_allocate_stmt) { 02690 total_implicit_args++; 02691 } 02692 #else 02693 if ( (TY_Is_Character_Reference(parm_ty) || 02694 TY_Is_Chararray_Reference(parm_ty)|| 02695 TY_is_character(parm_ty) ) && 02696 !is_allocate_stmt) 02697 total_implicit_args++; 02698 #endif 02699 } 02700 else { /*the argument is function call 02701 * if the return value is Chararray or Character Reference: 02702 */ 02703 if (WN_operator(kidofparm) == OPR_CALL) { 02704 kid_ty = PU_prototype (Pu_Table[ST_pu(WN_st(kidofparm))]); 02705 if (W2X_Unparse_Target->Func_Return_Character (kid_ty)) 02706 total_implicit_args++; 02707 02708 } 02709 else { 02710 if (WN_operator(kidofparm) == OPR_INTRINSIC_CALL && 02711 WN_intrinsic(kidofparm) == INTRN_CONCATEXPR) 02712 total_implicit_args++; 02713 } 02714 } 02715 } 02716 } 02717 02718 /* Append the argument list to the function reference, skipping 02719 * implicit character-string-length arguments assumed to be the 02720 * last ones in the list (see also ST2F_func_header()). Note 02721 * that we should not need to use any special-casing for 02722 * ADRTMP or VALTMP OPR_INTRINSIC_OP nodes, as these should be 02723 * handled appropriately by WN2F_translate(). 02724 */ 02725 02726 if ((WN_operator(wn) == OPR_CALL) && 02727 strcmp(ST_name(WN_st(wn)),"_END") ==0 ) { 02728 ; 02729 } else { 02730 02731 Append_Token_Special(call_tokens, '('); 02732 set_WN2F_CONTEXT_no_parenthesis(context); 02733 02734 //WARNING 02735 /* tempoarily add a piece of code for processiong optinal 02736 * arguments in intrinsic function "system_clock". will change 02737 * later to process all intrinsic functions with optional 02738 * arguments ---FMZ 02739 */ 02740 02741 // if (strcmp(ST_name(WN_st(wn)),"SYSTEM_CLOCK") != 0 || TRUE) { //don't need it anymore FMZ 02742 02743 for (arg_idx = first_arg_idx, implicit_args = 0; 02744 arg_idx <= last_arg_idx - implicit_args; 02745 arg_idx++) { 02746 if (WN_kid(wn, arg_idx) == NULL) 02747 ; 02748 else { 02749 kidofparm = WN_kid0(WN_kid(wn, arg_idx)); 02750 if (WN_operator(kidofparm) !=OPR_CALL) { 02751 arg_ty = WN_Tree_Type(WN_kid(wn, arg_idx)); 02752 parm_ty = WN_ty(WN_kid(wn,arg_idx)); 02753 } 02754 else { 02755 arg_ty = PU_prototype (Pu_Table[ST_pu(WN_st(kidofparm))]); 02756 parm_ty = PU_prototype (Pu_Table[ST_pu(WN_st(kidofparm))]); 02757 } 02758 02759 if (WN_operator(wn) == OPR_INTRINSIC_CALL && 02760 INTRN_by_value(WN_intrinsic(wn))) { 02761 /* Call-by value, but argument should be emitted without 02762 * the %val() qualifier. 02763 */ 02764 if (WN_kid(wn, arg_idx)!=NULL) { 02765 first_nonemptyarg = TRUE; 02766 WN2F_translate(call_tokens, WN_kid(wn, arg_idx), context); 02767 } 02768 } 02769 else if ((WN_operator(kidofparm) != OPR_CALL && 02770 (TY_Is_Character_Reference(parm_ty) || 02771 TY_Is_Chararray_Reference(parm_ty) || 02772 TY_is_character(parm_ty) ) || 02773 WN_operator(kidofparm) == OPR_CALL && 02774 W2X_Unparse_Target->Func_Return_Character(arg_ty) ) && 02775 !is_allocate_stmt) { 02776 /* Handle substring arguments here. These are always assumed 02777 * to be passed by reference. For a function result, the length 02778 * follows the address - does this look like char fn result? 02779 * can't tell, but make good guess.. 02780 */ 02781 INT len_idx ; 02782 INT cur_idx = arg_idx ; 02783 implicit_args++; 02784 02785 if ((is_user_call) && 02786 (cur_idx == first_arg_idx) && 02787 (cur_idx == first_arg_idx) && 02788 (WN_kid_count(wn) >= cur_idx + 2) && 02789 ( WN_kid(wn,cur_idx+1) != NULL) && 02790 (WN_Parm_By_Value(WN_kid(wn,cur_idx + 1))) && 02791 ((return_ty != 0) && (TY_kind(return_ty) == KIND_VOID))) { 02792 len_idx = cur_idx + 1 ; 02793 } 02794 else 02795 len_idx = last_arg_idx - (total_implicit_args - implicit_args); 02796 if (first_nonemptyarg && !has_stat ) 02797 Append_Token_Special(call_tokens, ','); 02798 else 02799 has_stat = FALSE; 02800 02801 first_nonemptyarg = TRUE; 02802 02803 if (WN_kid(wn, cur_idx)->u3.ty_fields.ty) { //keyword FMZ 02804 ST2F_output_keyword(call_tokens, 02805 &St_Table[WN_kid(wn, cur_idx)->u3.ty_fields.ty]); 02806 Append_Token_Special(call_tokens,'='); 02807 } 02808 02809 WN2F_String_Argument(call_tokens, 02810 WN_kid(wn, cur_idx), /* string base */ 02811 WN_kid(wn, len_idx), /* string length */ 02812 context); 02813 } 02814 else if (!TY_Is_Pointer(arg_ty) || 02815 (WN_operator(WN_kid(wn, arg_idx)) == OPR_INTRINSIC_OP && 02816 INTR_is_valtmp(WN_intrinsic(WN_kid(wn, arg_idx))))) { 02817 /* Need to explicitly note this as a value parameter. 02818 */ 02819 02820 if (WN_operator(kidofparm) == OPR_INTRINSIC_CALL && 02821 WN_intrinsic(kidofparm)==INTRN_CONCATEXPR) 02822 02823 implicit_args++; 02824 /*parser always generate an extra arg for concat operator*/ 02825 02826 if (WN_kid(wn, arg_idx)!=NULL && 02827 WN_kid0(WN_kid(wn,arg_idx)) && 02828 WN_operator(WN_kid0(WN_kid(wn,arg_idx)))!= OPR_IMPLICIT_BND) { 02829 if (first_nonemptyarg && !has_stat) 02830 Append_Token_Special(call_tokens, ','); 02831 else 02832 has_stat=FALSE; 02833 first_nonemptyarg = TRUE; 02834 WN2F_translate(call_tokens, WN_kid(wn, arg_idx), context); 02835 } 02836 // Append_Token_Special(call_tokens, ')'); 02837 } 02838 else { /* TY_Is_Pointer(arg_ty) */ 02839 /* There is also an implicit string length when the argument 02840 * is an array of character strings. 02841 */ 02842 if (TY_Is_Chararray_Reference(arg_ty) && 02843 !is_allocate_stmt) 02844 implicit_args++; 02845 02846 /* Assume call-by-reference parameter passing */ 02847 if (WN_kid(wn, arg_idx)!=NULL){ 02848 if (first_nonemptyarg && !has_stat) 02849 Append_Token_Special(call_tokens, ','); 02850 else 02851 has_stat = FALSE; 02852 02853 first_nonemptyarg = TRUE; 02854 fld_type_z = 0; 02855 WN2F_Offset_Memref(call_tokens, 02856 WN_kid(wn, arg_idx), /* address expression */ 02857 arg_ty, /* address type */ 02858 TY_pointed(arg_ty), /* object type */ 02859 0, /* offset from address*/ 02860 context); 02861 } 02862 } 02863 02864 if ((arg_idx+implicit_args) < (last_arg_idx-1) && 02865 WN_kid(wn, arg_idx)!=NULL) 02866 ; 02867 else 02868 if ((arg_idx+implicit_args) == (last_arg_idx-1)) { 02869 if (WN_operator(wn) == OPR_CALL && 02870 (strcmp(ST_name(WN_st(wn)),"_ALLOCATE")== 0 || 02871 strcmp(ST_name(WN_st(wn)),"_DEALLOCATE")== 0)) { 02872 if ((WN_opc_operator(WN_kid0(WN_kid(wn, (last_arg_idx))))) 02873 == OPR_LDA) { 02874 Append_Token_Special(call_tokens, ','); 02875 Append_Token_String(call_tokens,"STAT="); 02876 has_stat=TRUE; 02877 } else 02878 arg_idx++; 02879 ; 02880 02881 } 02882 else 02883 if (WN_kid(wn, arg_idx)!=NULL && WN_kid(wn,arg_idx+1)!=NULL) 02884 ; 02885 02886 /* argument could be "optional" argument,so there could 02887 be NULL wn */ 02888 // Append_Token_Special(call_tokens, ','); 02889 } 02890 } 02891 } 02892 // } /*not system_clock*/ 02893 #if 0 02894 else { /* here for system clock*/ 02895 arg_idx = 0; 02896 if (WN_kid(wn, arg_idx)!=NULL) { 02897 first_nonemptyarg =TRUE; 02898 Append_Token_String(call_tokens,"count="); 02899 WN2F_translate(call_tokens, WN_kid(wn, arg_idx), context); 02900 } 02901 arg_idx++; 02902 if (WN_kid(wn, arg_idx)!=NULL) { 02903 if (first_nonemptyarg) 02904 Append_Token_Special(call_tokens, ','); 02905 else 02906 first_nonemptyarg = TRUE; 02907 Append_Token_String(call_tokens,"count_rate="); 02908 WN2F_translate(call_tokens, WN_kid(wn, arg_idx), context); 02909 } 02910 arg_idx++; 02911 if (WN_kid(wn, arg_idx)!=NULL) { 02912 if (first_nonemptyarg) 02913 Append_Token_Special(call_tokens, ','); 02914 else first_nonemptyarg =TRUE; 02915 Append_Token_String(call_tokens,"count_max="); 02916 WN2F_translate(call_tokens, WN_kid(wn, arg_idx), context); 02917 } 02918 02919 } 02920 #endif 02921 02922 reset_WN2F_CONTEXT_no_parenthesis(context); 02923 reset_WN2F_CONTEXT_has_no_arr_elmt(context); 02924 Append_Token_Special(call_tokens, ')'); 02925 } 02926 02927 /* Only save off return-values for calls outside io-statements. 02928 * I assume here that no call information inside io-statements 02929 * have been recorded, assuming such calls are not walked when 02930 * traversing the stetements of a PU in PUinfo.c. 02931 */ 02932 if (!WN2F_CONTEXT_io_stmt(context)) { 02933 /* Update the call site information to denote this one */ 02934 if (WN2F_Prev_CallSite == NULL) 02935 WN2F_Prev_CallSite = PUinfo_Get_CallSites(); 02936 else 02937 WN2F_Prev_CallSite = CALLSITE_next(WN2F_Prev_CallSite); 02938 02939 ASSERT_DBG_FATAL(CALLSITE_call(WN2F_Prev_CallSite) == wn, 02940 (DIAG_W2F_UNEXPECTED_CALLSITE, "WN2F_call()")); 02941 02942 /* Next, save off the function return value to a (temporary) 02943 * variable or a return-register, as is appropriate. 02944 */ 02945 if (return_ty != (TY_IDX) 0 && TY_kind(return_ty) != KIND_VOID) { 02946 /* This is not a subroutine, so a CALL statement is not valid 02947 * Fortran. We must assign the resultant value to some location. 02948 * We do that here! 02949 */ 02950 ASSERT_DBG_WARN(return_to_param || first_arg_idx == 0, 02951 (DIAG_A_STRING, 02952 "WN2F_call expects first argument as kid0 " 02953 "when not returning through first argument")); 02954 02955 if (return_to_param) { 02956 /* Return through a parameter: Assign the call-value to 02957 * the dereferenced implicit argument expression (first_arg). 02958 */ 02959 fld_type_z = 0; 02960 (void)WN2F_Offset_Memref(tokens, 02961 WN_kid0(wn), /* return addr expression */ 02962 WN_Tree_Type(WN_kid0(wn)), /* addr type */ 02963 return_ty, /* object type */ 02964 0, /* offset from address */ 02965 context); 02966 Append_Token_Special(tokens, '='); 02967 } 02968 else /* Do not return to a parameter */ 02969 ; 02970 } 02971 else { /* No return value, i.e. a SUBROUTINE */ 02972 if (!WN2F_CONTEXT_io_stmt(context)) 02973 02974 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_Get_Linenum(wn), context); 02975 02976 if (WN_operator(wn)==OPR_ICALL || 02977 strcmp(ST_name(WN_st(wn)),"_ALLOCATE") !=0 && 02978 strcmp(ST_name(WN_st(wn)),"_END") !=0 && 02979 (strcmp(ST_name(WN_st(wn)),"_DEALLOCATE") !=0 )) 02980 Prepend_Token_String(call_tokens, "CALL"); 02981 } 02982 } 02983 Append_And_Reclaim_Token_List(tokens, &call_tokens); 02984 02985 return EMPTY_WN2F_STATUS; 02986 } /* WN2F_call */ 02987 02988 02989 WN2F_STATUS 02990 WN2F_prefetch(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02991 { 02992 /* Prefetch information is currently added in a comment */ 02993 INT pflag; 02994 02995 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_PREFETCH || 02996 WN_operator(wn) == OPR_PREFETCHX, 02997 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_prefetch")); 02998 02999 /* Ensure array references are dereferenced and a comment line is begun */ 03000 set_WN2F_CONTEXT_deref_addr(context); 03001 Append_F77_Comment_Newline(tokens, 1/*empty-lines*/, TRUE/*indent*/); 03002 03003 /* Get the prefetch identifier and address expression */ 03004 if (WN_operator(wn) == OPR_PREFETCH) 03005 { 03006 Append_Token_String(tokens, 03007 Concat3_Strings("PREFETCH(", Ptr_as_String(wn), ")")); 03008 03009 (void)WN2F_translate(tokens, WN_kid0(wn), context); 03010 03011 Append_Token_String(tokens, 03012 Concat2_Strings("OFFS=", WHIRL2F_number_as_name(WN_offset(wn)))); 03013 } 03014 else /* (WN_operator(wn) == OPR_PREFETCHX) */ 03015 { 03016 Append_Token_String(tokens, 03017 Concat3_Strings("PREFETCH(", Ptr_as_String(wn),")")); 03018 03019 (void)WN2F_translate(tokens, WN_kid0(wn), context); 03020 Append_Token_Special(tokens, '+'); 03021 (void)WN2F_translate(tokens, WN_kid1(wn), context); 03022 } 03023 03024 /* Emit the prefetch flags information (pf_cg.h) on a separate line */ 03025 pflag = WN_prefetch_flag(wn); 03026 Set_Current_Indentation(Current_Indentation()+3); 03027 Append_F77_Comment_Newline(tokens, 1/*empty-lines*/, TRUE/*indent*/); 03028 Append_Token_String(tokens, 03029 Concat2_Strings( PF_GET_READ(pflag)? "read" : "write", 03030 Concat2_Strings( " strid1=", 03031 Concat2_Strings( WHIRL2F_number_as_name(PF_GET_STRIDE_1L(pflag)), 03032 Concat2_Strings( " strid2=", 03033 Concat2_Strings( WHIRL2F_number_as_name(PF_GET_STRIDE_2L(pflag)), 03034 Concat2_Strings(" conf=", 03035 WHIRL2F_number_as_name(PF_GET_CONFIDENCE(pflag)) 03036 ))))))); 03037 Set_Current_Indentation(Current_Indentation()-3); 03038 03039 return EMPTY_WN2F_STATUS; 03040 } /* WN2F_prefetch */ 03041 03042 03043 WN2F_STATUS 03044 WN2F_eval(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03045 { 03046 /* This generates code that will not recompile. Short of 03047 * some kind of surrounding statement there is no way to do 03048 * this in Fortran-77. 03049 */ 03050 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_EVAL, 03051 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_eval")); 03052 03053 Append_F77_Comment_Newline(tokens, 1/*empty-lines*/, TRUE/*indent*/); 03054 Append_Token_String(tokens, "CALL"); 03055 Append_Token_String(tokens, "_EVAL"); 03056 Append_Token_Special(tokens, '('); 03057 set_WN2F_CONTEXT_has_logical_arg(context); 03058 set_WN2F_CONTEXT_no_parenthesis(context); 03059 (void)WN2F_translate(tokens, WN_kid0(wn), context); 03060 Append_Token_Special(tokens, ')'); 03061 03062 return EMPTY_WN2F_STATUS; 03063 } /* WN2F_eval */ 03064 03065 //********************************************** 03066 WN2F_STATUS 03067 WN2F_use_stmt(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03068 { 03069 return EMPTY_WN2F_STATUS; 03070 } //WN2F_use_stmt 03071 //********************************************** 03072 WN2F_STATUS 03073 WN2F_namelist_stmt(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03074 { 03075 int k ; 03076 03077 const char *st_name = W2CF_Symtab_Nameof_St(WN_st(wn)); 03078 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_NAMELIST, 03079 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_namelist_stmt")); 03080 if (ST_is_external(WN_st(wn))) 03081 { 03082 ; 03083 } else { 03084 03085 Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03086 Append_Token_String(tokens, "NAMELIST /"); 03087 Append_Token_String(tokens, st_name); 03088 Append_Token_String(tokens, " /"); 03089 03090 for(k=0;k< WN_kid_count(wn);k++ ) 03091 03092 { st_name = W2CF_Symtab_Nameof_St(WN_st(WN_kid(wn,k))); 03093 Set_BE_ST_w2fc_referenced(WN_st(WN_kid(wn,k))); 03094 if (k==0) 03095 ; 03096 else 03097 Append_Token_String(tokens,","); 03098 Append_Token_String(tokens,st_name); 03099 03100 } 03101 } 03102 03103 return EMPTY_WN2F_STATUS; 03104 } //WN2F_namelist_stmt 03105 03106 //********************************************** 03107 WN2F_STATUS 03108 WN2F_implicit_bnd(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03109 { 03110 Append_Token_Special(tokens, ' '); 03111 return EMPTY_WN2F_STATUS; 03112 } 03113 03114 // OPC_SWITCH only appears in very high level whirl 03115 03116 WN2F_STATUS 03117 WN2F_switch(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03118 { 03119 WN *stmt; 03120 WN *kid1wn; 03121 03122 //Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03123 // Append_Token_String(tokens,"SELECT CASE ("); 03124 //(void)WN2F_translate(tokens, WN_condbr_cond(wn), context); 03125 // Append_Token_Special(tokens, ')'); 03126 03127 kid1wn = WN_kid1(wn); 03128 03129 for (stmt = WN_first(kid1wn); stmt != NULL; stmt = WN_next(stmt)) 03130 { 03131 if (!WN2F_Skip_Stmt(stmt)) 03132 { 03133 if (WN_operator(stmt) == OPR_CASEGOTO) 03134 WN_st_idx(stmt) = WN_st_idx(WN_kid0(wn)); 03135 } 03136 } 03137 03138 (void)WN2F_translate(tokens, WN_kid1(wn), context); 03139 if (WN_kid_count(wn) == 3) 03140 (void)WN2F_translate(tokens, WN_kid2(wn), context); 03141 // Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03142 // Append_Token_String(tokens,"END SELECT "); 03143 03144 return EMPTY_WN2F_STATUS; 03145 } 03146 03147 03148 WN2F_STATUS 03149 WN2F_casegoto(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03150 { 03151 ST *st; 03152 st = WN_st(wn); 03153 03154 Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03155 // Append_Token_String(tokens,"CASE"); 03156 Append_Token_String(tokens,"IF ("); 03157 ST2F_use_translate(tokens,st); 03158 Append_Token_String(tokens," .EQ. "); 03159 TCON2F_translate(tokens,Host_To_Targ(MTYPE_I4,WN_const_val(wn)),FALSE); 03160 Append_Token_Special(tokens,')'); 03161 Append_Token_String(tokens," GO TO "); 03162 Append_Token_String(tokens, WHIRL2F_number_as_name(WN_label_number(wn))); 03163 return EMPTY_WN2F_STATUS; 03164 } 03165 03166 03167 //********************************************** 03168 WN2F_STATUS 03169 WN2F_nullify_stmt(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03170 { 03171 int k ; 03172 WN* kidwn; 03173 03174 const char *st_name; 03175 03176 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_NULLIFY, 03177 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_nullify_stmt")); 03178 03179 Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03180 Append_Token_String(tokens, "NULLIFY ("); 03181 03182 for(k=0;k< WN_kid_count(wn);k++ ) { 03183 if (k==0) 03184 ; 03185 else 03186 Append_Token_String(tokens,","); 03187 03188 kidwn=WN_kid(wn,k); 03189 03190 while (( WN_operator(kidwn)==OPR_ARRAY) || 03191 (WN_operator(kidwn)==OPR_ARRSECTION)) { 03192 kidwn = WN_kid0(kidwn); //skip array scripts part 03193 } 03194 03195 (void)WN2F_translate(tokens,kidwn,context); 03196 03197 } 03198 03199 Append_Token_Special(tokens,')' ); 03200 03201 return EMPTY_WN2F_STATUS; 03202 } //WN2F_nullify_stmt 03203 03204 //********************************************** 03205 WN2F_STATUS 03206 WN2F_interface_blk(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03207 { 03208 int k ; 03209 ST **param_st; 03210 ST *st = WN_st(wn); 03211 ST *rslt = NULL; 03212 INT param,num_params; 03213 INT first_param; 03214 TY_IDX return_ty; 03215 TOKEN_BUFFER header_tokens; 03216 INT implicit ; 03217 BOOL add_rsl_decl = 0; 03218 03219 03220 03221 03222 const char *intface_name = ST_name(st); 03223 03224 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_INTERFACE, 03225 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_interface_blk")); 03226 03227 if (ST_is_external(WN_st(wn))) 03228 return EMPTY_WN2F_STATUS; 03229 03230 Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03231 Append_Token_String(tokens, "interface "); 03232 03233 if (ST_is_assign_interface(st)) 03234 { 03235 Append_Token_String(tokens,"assignment "); 03236 Append_Token_Special(tokens,'('); 03237 } 03238 03239 if (ST_is_operator_interface(st) || ST_is_u_operator_interface(st)){ 03240 Append_Token_String(tokens,"operator"); 03241 Append_Token_Special(tokens,'('); 03242 } 03243 03244 if (ST_is_u_operator_interface(st)) 03245 Append_Token_Special(tokens,'.'); 03246 03247 if (strcmp(intface_name,unnamed_interface)) 03248 Append_Token_String(tokens, intface_name); 03249 03250 if (ST_is_u_operator_interface(st)) 03251 Append_Token_Special(tokens,'.'); 03252 03253 if (ST_is_assign_interface(st) || 03254 ST_is_operator_interface(st) || 03255 ST_is_u_operator_interface(st)) 03256 Append_Token_Special(tokens,')'); 03257 03258 Append_Token_Special(tokens, '\n'); 03259 Increment_Indentation(); 03260 03261 for(k=0;k< WN_kid_count(wn);k++ ) 03262 /* each kid is a WN with "OPR_FUNC_ENTRY" */ 03263 { 03264 implicit = 0; 03265 add_rsl_decl = 0; 03266 header_tokens = New_Token_Buffer(); 03267 num_params = WN_kid_count(WN_kid(wn,k)); 03268 param_st = (ST **)alloca((num_params + 1) * sizeof(ST *)); 03269 for (param = 0; param < num_params; param++) 03270 { 03271 param_st[param] = WN_st(WN_formal(WN_kid(wn,k), param)); 03272 // if a type of a dummy argument is user defined type "mtype" 03273 // get the ST entry of the module "m1", add "use m1" 03274 } 03275 param_st[num_params]=NULL; /* terminate the list with NULL */ 03276 st = &St_Table[WN_entry_name(WN_kid(wn,k))]; 03277 TY_IDX funtype = ST_pu_type(st); 03278 03279 return_ty = W2X_Unparse_Target->Func_Return_Type(funtype); 03280 03281 if (ST_is_in_module(st) ) { 03282 Append_Token_String(header_tokens,"module procedure "); 03283 Append_Token_String(header_tokens, W2CF_Symtab_Nameof_St(st)); 03284 } 03285 else { 03286 if (return_ty != (TY_IDX) 0 && TY_kind(return_ty) != KIND_VOID) 03287 /* function */ 03288 { 03289 Append_Token_String(header_tokens, "FUNCTION"); 03290 03291 if (PU_recursive(Get_Current_PU())) 03292 Prepend_Token_String(header_tokens, "RECURSIVE"); 03293 add_rsl_decl = 1; 03294 } 03295 else /* subroutine */ 03296 { 03297 Append_Token_String(header_tokens, "SUBROUTINE"); 03298 } 03299 03300 Append_Token_String(header_tokens, W2CF_Symtab_Nameof_St(st)); 03301 03302 03303 /* Emit the parameter name-list, if one is present, and skip any 03304 * implicit "length" parameters associated with character strings. 03305 * Such implicit parameters should be at the end of the parameter list. 03306 */ 03307 03308 first_param = ST2F_FIRST_PARAM_IDX(funtype); 03309 BOOL isFirstArg = TRUE; 03310 /* become FALSE after first argument has been emitted */ 03311 /* ([email protected]) */ 03312 if (param_st[first_param] != NULL) 03313 { 03314 Append_Token_Special(header_tokens, '('); 03315 for (param = first_param; 03316 param < num_params-implicit; 03317 param++) 03318 { 03319 if (STAB_PARAM_HAS_IMPLICIT_LENGTH(param_st[param])) 03320 implicit++; 03321 if (!ST_is_return_var(param_st[param])) { 03322 /* separate argument with a comma, if not the first one */ 03323 /* ([email protected]) */ 03324 if(isFirstArg == FALSE) 03325 Append_Token_Special(header_tokens, ','); 03326 else 03327 isFirstArg = FALSE; 03328 Append_Token_String(header_tokens, 03329 W2CF_Symtab_Nameof_St(param_st[param])); 03330 03331 /* Bug: next and last param may be implicit */ 03332 /* this causes the argument list to end with a comma */ 03333 /* ([email protected]) */ 03334 }else 03335 rslt = param_st[param]; 03336 03337 } 03338 Append_Token_Special(header_tokens, ')'); 03339 } 03340 else 03341 { 03342 /* Use the "()" notation for "no parameters" */ 03343 Append_Token_Special(header_tokens, '('); 03344 Append_Token_Special(header_tokens, ')'); 03345 } 03346 03347 if (rslt !=NULL && 03348 strcasecmp(W2CF_Symtab_Nameof_St(st), W2CF_Symtab_Nameof_St(rslt)) != 0) 03349 { 03350 /* append the RESULT option only if it is different from the function name */ 03351 /* ([email protected]) */ 03352 Append_Token_String(header_tokens,"result("); 03353 Append_Token_String( header_tokens, 03354 W2CF_Symtab_Nameof_St(rslt)); 03355 Append_Token_Special(header_tokens, ')'); 03356 } 03357 03358 Append_F77_Indented_Newline(header_tokens, 1/*empty-lines*/, NULL/*label*/); 03359 Append_Token_String(header_tokens, "use w2f__types"); 03360 03361 // add "use mm" 03362 TyIdxToStIdxMap::iterator currpos; 03363 03364 // set "module st " with "BE_ST_w2fc_referenced" 03365 // to prevent multiple "use" stmt 03366 for (currpos=tyidx_modidx.begin(); 03367 currpos != tyidx_modidx.end(); 03368 currpos++) 03369 Set_BE_ST_w2fc_referenced(currpos->second); 03370 03371 for (param = 0; param < num_params; param++){ 03372 TY_IDX parmty= ST_type(param_st[param]); 03373 ST_IDX currmod; 03374 if (TY_kind(parmty) == KIND_STRUCT) { 03375 currpos=tyidx_modidx.find(parmty); 03376 if (currpos !=tyidx_modidx.end()) { 03377 currmod = currpos->second; 03378 if (BE_ST_w2fc_referenced(currmod)) { 03379 Clear_BE_ST_w2fc_referenced(currmod); 03380 Append_F77_Indented_Newline(header_tokens, 1/*empty-lines*/, NULL/*label*/); 03381 Append_Token_String(header_tokens,"use "); 03382 Append_Token_String(header_tokens, 03383 W2CF_Symtab_Nameof_St(&St_Table[currmod])); 03384 } 03385 } 03386 } 03387 } 03388 03389 03390 if (add_rsl_decl){ 03391 TOKEN_BUFFER temp_tokens = New_Token_Buffer(); 03392 Append_F77_Indented_Newline(header_tokens, 1/*empty-lines*/, NULL/*label*/); 03393 if (TY_Is_Pointer(return_ty)) 03394 TY2F_translate(temp_tokens, 03395 Stab_Mtype_To_Ty(TY_mtype(return_ty))); 03396 else { 03397 if (TY_kind(return_ty)==KIND_ARRAY && !TY_is_character(return_ty)) 03398 TY2F_translate(temp_tokens,TY_AR_etype(return_ty)); 03399 else 03400 TY2F_translate(temp_tokens, return_ty); 03401 } 03402 Append_Token_String(temp_tokens, W2CF_Symtab_Nameof_St(st)); 03403 Append_And_Reclaim_Token_List(header_tokens, &temp_tokens); 03404 } 03405 03406 if (num_params) 03407 ReorderParms(param_st,num_params-implicit); 03408 03409 for (param = first_param; param < num_params-implicit ; param++) 03410 if (param_st[param] != NULL) { 03411 Append_F77_Indented_Newline(header_tokens, 1, NULL/*label*/); 03412 ST2F_decl_translate(header_tokens, param_st[param]); 03413 if (ST_is_optional_argument(param_st[param])) { 03414 Append_F77_Indented_Newline(header_tokens, 1, NULL/*label*/); 03415 Append_Token_String(header_tokens,"OPTIONAL "); 03416 Append_Token_String(header_tokens, 03417 W2CF_Symtab_Nameof_St(param_st[param])); 03418 } 03419 if (ST_is_intent_in_argument(param_st[param])) { 03420 Append_F77_Indented_Newline(header_tokens, 1, NULL/*label*/); 03421 Append_Token_String(header_tokens,"INTENT(in) "); 03422 Append_Token_String(header_tokens, 03423 W2CF_Symtab_Nameof_St(param_st[param])); 03424 } 03425 if (ST_is_intent_out_argument(param_st[param])) { 03426 Append_F77_Indented_Newline(header_tokens, 1, NULL/*label*/); 03427 Append_Token_String(header_tokens,"INTENT(out) "); 03428 Append_Token_String(header_tokens, 03429 W2CF_Symtab_Nameof_St(param_st[param])); 03430 } 03431 } 03432 03433 Append_Token_Special(header_tokens, '\n'); 03434 Append_F77_Indented_Newline(header_tokens, 0, NULL); 03435 03436 if (return_ty != (TY_IDX) 0 && TY_kind(return_ty) != KIND_VOID) 03437 /* function */ 03438 Append_Token_String(header_tokens, "END FUNCTION"); 03439 else /* subroutine */ 03440 Append_Token_String(header_tokens, "END SUBROUTINE"); 03441 } 03442 03443 Append_Token_Special(header_tokens, '\n'); 03444 Append_F77_Indented_Newline(tokens, 0, NULL); 03445 Append_And_Reclaim_Token_List(tokens, &header_tokens); 03446 } 03447 Decrement_Indentation(); 03448 Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03449 Append_Token_String(tokens, "end interface "); 03450 Append_F77_Indented_Newline(tokens, 1/*empty-lines*/, NULL/*label*/); 03451 return EMPTY_WN2F_STATUS; 03452 03453 } //WN2F_interface_blk 03454 03455 03456 03457 WN2F_STATUS 03458 WN2F_ar_construct(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03459 { 03460 INT kid; 03461 03462 Append_Token_Special(tokens,'('); 03463 Append_Token_Special(tokens,'/'); 03464 for (kid = 0; kid < WN_kid_count(wn); kid++) { 03465 03466 (void)WN2F_translate(tokens,WN_kid(wn,kid), context); 03467 if (kid < WN_kid_count(wn)-1) 03468 Append_Token_Special(tokens,','); 03469 } 03470 03471 03472 Append_Token_Special(tokens,'/'); 03473 Append_Token_Special(tokens,')'); 03474 03475 return EMPTY_WN2F_STATUS; 03476 03477 } 03478 03479 WN2F_STATUS 03480 WN2F_noio_implied_do(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03481 { 03482 INT kid; 03483 INT numkids = 5; 03484 Append_Token_Special(tokens,'('); 03485 (void)WN2F_translate(tokens,WN_kid0(wn),context); 03486 Append_Token_Special(tokens,','); 03487 (void)WN2F_translate(tokens,WN_kid1(wn),context); 03488 Append_Token_Special(tokens,'='); 03489 03490 for (kid = 2;kid<numkids; kid++) { 03491 (void)WN2F_translate(tokens,WN_kid(wn,kid),context); 03492 if (kid < numkids-1) 03493 Append_Token_Special(tokens,','); 03494 } 03495 03496 Append_Token_Special(tokens,')'); 03497 return EMPTY_WN2F_STATUS; 03498 } //WN2F_noio_implied_do 03499 03500 WN2F_STATUS 03501 WN2F_idname(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 03502 { 03503 const char *st_name; 03504 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_IDNAME, 03505 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_idname")); 03506 st_name = W2CF_Symtab_Nameof_St(WN_st(wn)); 03507 Append_Token_String(tokens,st_name); 03508 Set_BE_ST_w2fc_referenced(WN_st(wn)); 03509 return EMPTY_WN2F_STATUS; 03510 03511 } //WN2F_idname 03512 03513 03514