|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 /* ==================================================================== 00037 * ==================================================================== 00038 * 00039 * 00040 * Revision history: 00041 * 12-Apr-95 - Original Version 00042 * 00043 * Description: 00044 * 00045 * Translate a WN expression subtree to Fortran by means of an inorder 00046 * recursive descent traversal of the WHIRL IR. Note that the routines 00047 * to handle statements and loads/stores are in separate source files. 00048 * Recursive translation of WN nodes should only use WN2F_Translate()! 00049 * 00050 * ==================================================================== 00051 * ==================================================================== 00052 */ 00053 00054 #ifdef _KEEP_RCS_ID 00055 /*REFERENCED*/ 00056 #endif 00057 00058 #include "whirl2f_common.h" 00059 #include "PUinfo.h" /* In be/whirl2c directory */ 00060 #include "tcon2f.h" 00061 #include "wn2f.h" 00062 #include "ty2f.h" 00063 #include "st2f.h" 00064 #include "wn2f_load_store.h" 00065 #include "intrn_info.h" /* INTR macros */ 00066 #include "ty_ftn.h" 00067 00068 extern BOOL W2F_OpenAD; /* w2f_driver.h */ 00069 00070 /*---- Fortran names for binary and unary arithmetic operations -------*/ 00071 /*---------------------------------------------------------------------*/ 00072 00073 00074 /* The builtin Fortran operations will begin with a special character 00075 * or an alphabetic character, where those beginning with an alphabetic 00076 * character will be applied like functions and all others will be 00077 * applied in usual infix format. When a name begins with '_', it is 00078 * a whirl2f special symbol to be applied like a function. It will 00079 * be implemented in a library made available to be linked in with 00080 * compiled whirl2f code. 00081 */ 00082 #define WN2F_IS_ALPHABETIC(opc) \ 00083 ((Opc_Fname[opc][0]>='a' && Opc_Fname[opc][0]<='z') || \ 00084 (Opc_Fname[opc][0]>='A' && Opc_Fname[opc][0]<='Z') || \ 00085 (Opc_Fname[opc][0]=='_')) 00086 00087 #define WN2F_IS_INFIX_OP(opc) \ 00088 (Opc_Fname[opc]!=NULL && !WN2F_IS_ALPHABETIC(opc)) 00089 00090 #define WN2F_IS_FUNCALL_OP(opc) \ 00091 (Opc_Fname[opc]!=NULL && WN2F_IS_ALPHABETIC(opc)) 00092 00093 /* Mapping from opcodes to Fortran names for arithmetic/logical 00094 * operations. An empty (NULL) name will occur for non- 00095 * arithmetic/logical opcodes, which must be handled by special 00096 * handler-functions. This mapping is dynamically initialized, 00097 * based on Fname_Map[], in WN2F_Expr_Initialize(). 00098 */ 00099 #define NUMBER_OF_OPCODES (OPCODE_LAST+1) 00100 static const char *Opc_Fname[NUMBER_OF_OPCODES]; 00101 00102 00103 typedef struct Fname_PartialMap 00104 { 00105 OPCODE opc; 00106 const char *fname; 00107 } FNAME_PARTIALMAP; 00108 00109 #define NUMBER_OF_FNAME_PARTIALMAPS \ 00110 sizeof(Fname_Map) / sizeof(FNAME_PARTIALMAP) 00111 00112 static const FNAME_PARTIALMAP Fname_Map[] = 00113 { 00114 {OPC_U8NEG, "-"}, 00115 {OPC_FQNEG, "-"}, 00116 {OPC_I8NEG, "-"}, 00117 {OPC_U4NEG, "-"}, 00118 {OPC_CQNEG, "-"}, 00119 {OPC_F8NEG, "-"}, 00120 {OPC_C8NEG, "-"}, 00121 {OPC_I4NEG, "-"}, 00122 {OPC_F4NEG, "-"}, 00123 {OPC_C4NEG, "-"}, 00124 {OPC_I4ABS, "ABS"}, 00125 {OPC_F4ABS, "ABS"}, 00126 {OPC_FQABS, "ABS"}, 00127 {OPC_I8ABS, "ABS"}, 00128 {OPC_F8ABS, "ABS"}, 00129 {OPC_F4SQRT, "SQRT"}, 00130 {OPC_C4SQRT, "SQRT"}, 00131 {OPC_FQSQRT, "SQRT"}, 00132 {OPC_CQSQRT, "SQRT"}, 00133 {OPC_F8SQRT, "SQRT"}, 00134 {OPC_C8SQRT, "SQRT"}, 00135 {OPC_I4F4RND, "JNINT"}, 00136 {OPC_I4FQRND, "JIQNNT"}, 00137 {OPC_I4F8RND, "JIDNNT"}, 00138 {OPC_U4F4RND, "JNINT"}, 00139 {OPC_U4FQRND, "JIQNNT"}, 00140 {OPC_U4F8RND, "JIDNNT"}, 00141 {OPC_I8F4RND, "KNINT"}, 00142 {OPC_I8FQRND, "KIQNNT"}, 00143 {OPC_I8F8RND, "KIDNNT"}, 00144 {OPC_U8F4RND, "KNINT"}, 00145 {OPC_U8FQRND, "KIQNNT"}, 00146 {OPC_U8F8RND, "KIDNNT"}, 00147 {OPC_I4I4TRUNC, "INT"}, 00148 {OPC_I4F4TRUNC, "INT"}, 00149 {OPC_I4FQTRUNC, "INT"}, 00150 {OPC_I4F8TRUNC, "INT"}, 00151 {OPC_U4F4TRUNC, "INT"}, 00152 {OPC_U4FQTRUNC, "INT"}, 00153 {OPC_U4F8TRUNC, "INT"}, 00154 {OPC_I8F4TRUNC, "INT"}, 00155 {OPC_I8FQTRUNC, "INT"}, 00156 {OPC_I8F8TRUNC, "INT"}, 00157 {OPC_U8F4TRUNC, "INT"}, 00158 {OPC_U8FQTRUNC, "INT"}, 00159 {OPC_U8F8TRUNC, "INT"}, 00160 {OPC_I4F4CEIL, "CEILING"}, 00161 {OPC_I4FQCEIL, "CEILING"}, 00162 {OPC_I4F8CEIL, "CEILING"}, 00163 {OPC_I8F4CEIL, "CEILING"}, 00164 {OPC_I8FQCEIL, "CEILING"}, 00165 {OPC_I8F8CEIL, "CEILING"}, 00166 {OPC_I4F4FLOOR, "FLOOR"}, 00167 {OPC_I4FQFLOOR, "FLOOR"}, 00168 {OPC_I4F8FLOOR, "FLOOR"}, 00169 {OPC_I8F4FLOOR, "FLOOR"}, 00170 {OPC_I8FQFLOOR, "FLOOR"}, 00171 {OPC_I8F8FLOOR, "FLOOR"}, 00172 {OPC_I4BNOT, "NOT"}, 00173 {OPC_U8BNOT, "NOT"}, 00174 {OPC_I8BNOT, "NOT"}, 00175 {OPC_U4BNOT, "NOT"}, 00176 // >> WHIRL 0.30: replace OPC_LNOT by OPC_B and OPC_I4 variant 00177 // TODO WHIRL 0.30: get rid of OPC_I4 variant 00178 {OPC_BLNOT, ".NOT."}, 00179 {OPC_I4LNOT, ".NOT."}, 00180 // << WHIRL 0.30: replace OPC_LNOT by OPC_B and OPC_I4 variant 00181 {OPC_U8ADD, "+"}, 00182 {OPC_FQADD, "+"}, 00183 {OPC_I8ADD, "+"}, 00184 {OPC_U4ADD, "+"}, 00185 {OPC_CQADD, "+"}, 00186 {OPC_F8ADD, "+"}, 00187 {OPC_C8ADD, "+"}, 00188 {OPC_I4ADD, "+"}, 00189 {OPC_F4ADD, "+"}, 00190 {OPC_C4ADD, "+"}, 00191 {OPC_U8SUB, "-"}, 00192 {OPC_FQSUB, "-"}, 00193 {OPC_I8SUB, "-"}, 00194 {OPC_U4SUB, "-"}, 00195 {OPC_CQSUB, "-"}, 00196 {OPC_F8SUB, "-"}, 00197 {OPC_C8SUB, "-"}, 00198 {OPC_I4SUB, "-"}, 00199 {OPC_F4SUB, "-"}, 00200 {OPC_C4SUB, "-"}, 00201 {OPC_U8MPY, "*"}, 00202 {OPC_FQMPY, "*"}, 00203 {OPC_I8MPY, "*"}, 00204 {OPC_U4MPY, "*"}, 00205 {OPC_CQMPY, "*"}, 00206 {OPC_F8MPY, "*"}, 00207 {OPC_C8MPY, "*"}, 00208 {OPC_I4MPY, "*"}, 00209 {OPC_F4MPY, "*"}, 00210 {OPC_C4MPY, "*"}, 00211 {OPC_U8DIV, "/"}, 00212 {OPC_FQDIV, "/"}, 00213 {OPC_I8DIV, "/"}, 00214 {OPC_U4DIV, "/"}, 00215 {OPC_CQDIV, "/"}, 00216 {OPC_F8DIV, "/"}, 00217 {OPC_C8DIV, "/"}, 00218 {OPC_I4DIV, "/"}, 00219 {OPC_F4DIV, "/"}, 00220 {OPC_C4DIV, "/"}, 00221 {OPC_I4MOD, "MOD"}, 00222 {OPC_U8MOD, "MOD"}, 00223 {OPC_I8MOD, "MOD"}, 00224 {OPC_U8MOD, "MOD"}, 00225 {OPC_U4MOD, "MOD"}, 00226 {OPC_I4REM, "MOD"}, 00227 {OPC_U8REM, "MOD"}, 00228 {OPC_I8REM, "MOD"}, 00229 {OPC_U4REM, "MOD"}, 00230 {OPC_I4MAX, "MAX"}, 00231 {OPC_U8MAX, "MAX"}, 00232 {OPC_F4MAX, "MAX"}, 00233 {OPC_FQMAX, "MAX"}, 00234 {OPC_I8MAX, "MAX"}, 00235 {OPC_U4MAX, "MAX"}, 00236 {OPC_F8MAX, "MAX"}, 00237 {OPC_I4MIN, "MIN"}, 00238 {OPC_U8MIN, "MIN"}, 00239 {OPC_F4MIN, "MIN"}, 00240 {OPC_FQMIN, "MIN"}, 00241 {OPC_I8MIN, "MIN"}, 00242 {OPC_U4MIN, "MIN"}, 00243 {OPC_F8MIN, "MIN"}, 00244 {OPC_I4BAND, "IAND"}, 00245 {OPC_U8BAND, "IAND"}, 00246 {OPC_I8BAND, "IAND"}, 00247 {OPC_U4BAND, "IAND"}, 00248 {OPC_I4BIOR, "IOR"}, 00249 {OPC_U8BIOR, "IOR"}, 00250 {OPC_I8BIOR, "IOR"}, 00251 {OPC_U4BIOR, "IOR"}, 00252 {OPC_I4BXOR, "IEOR"}, 00253 {OPC_U8BXOR, "IEOR"}, 00254 {OPC_I8BXOR, "IEOR"}, 00255 {OPC_U4BXOR, "IEOR"}, 00256 // >> WHIRL 0.30: replaced OPC_{LAND,LIOR,CAND,CIOR} by OPC_B and OPC_I4 variants 00257 // TODO WHIRL 0.30: get rid of OPC_I4 variants 00258 {OPC_BLAND, ".AND."}, 00259 {OPC_I4LAND, ".AND."}, 00260 {OPC_BLIOR, ".OR."}, 00261 {OPC_I4LIOR, ".OR."}, 00262 {OPC_BCAND, ".AND."}, 00263 {OPC_I4CAND, ".AND."}, 00264 {OPC_BCIOR, ".OR."}, 00265 {OPC_I4CIOR, ".OR."}, 00266 // << WHIRL 0.30: replaced OPC_{LAND,LIOR,CAND,CIOR} by OPC_B and OPC_I4 variants 00267 {OPC_I4SHL, "ISHIFT"}, 00268 {OPC_U8SHL, "ISHIFT"}, 00269 {OPC_I8SHL, "ISHIFT"}, 00270 {OPC_U4SHL, "ISHIFT"}, 00271 {OPC_I4ASHR, "IASHR"}, 00272 {OPC_U8ASHR, "IASHR"}, 00273 {OPC_I8ASHR, "IASHR"}, 00274 {OPC_U4ASHR, "IASHR"}, 00275 // >> WHIRL 0.30: replaced OPC_T1{EQ,NE,GT,GE,LT,LE} by OPC_B and OPC_I4 variants 00276 // TODO WHIRL 0.30: get rid of OPC_I4 variants 00277 {OPC_BU8EQ, ".EQ."}, 00278 {OPC_BFQEQ, ".EQ."}, 00279 {OPC_BI8EQ, ".EQ."}, 00280 {OPC_BU4EQ, ".EQ."}, 00281 {OPC_BCQEQ, ".EQ."}, 00282 {OPC_BF8EQ, ".EQ."}, 00283 {OPC_BC8EQ, ".EQ."}, 00284 {OPC_BI4EQ, ".EQ."}, 00285 {OPC_BF4EQ, ".EQ."}, 00286 {OPC_BC4EQ, ".EQ."}, 00287 {OPC_BU8NE, ".NE."}, 00288 {OPC_BFQNE, ".NE."}, 00289 {OPC_BI8NE, ".NE."}, 00290 {OPC_BU4NE, ".NE."}, 00291 {OPC_BCQNE, ".NE."}, 00292 {OPC_BF8NE, ".NE."}, 00293 {OPC_BC8NE, ".NE."}, 00294 {OPC_BI4NE, ".NE."}, 00295 {OPC_BF4NE, ".NE."}, 00296 {OPC_BC4NE, ".NE."}, 00297 {OPC_BI4GT, ".GT."}, 00298 {OPC_BU8GT, ".GT."}, 00299 {OPC_BF4GT, ".GT."}, 00300 {OPC_BFQGT, ".GT."}, 00301 {OPC_BI8GT, ".GT."}, 00302 {OPC_BU4GT, ".GT."}, 00303 {OPC_BF8GT, ".GT."}, 00304 {OPC_BI4GE, ".GE."}, 00305 {OPC_BU8GE, ".GE."}, 00306 {OPC_BF4GE, ".GE."}, 00307 {OPC_BFQGE, ".GE."}, 00308 {OPC_BI8GE, ".GE."}, 00309 {OPC_BU4GE, ".GE."}, 00310 {OPC_BF8GE, ".GE."}, 00311 {OPC_BI4LT, ".LT."}, 00312 {OPC_BU8LT, ".LT."}, 00313 {OPC_BF4LT, ".LT."}, 00314 {OPC_BFQLT, ".LT."}, 00315 {OPC_BI8LT, ".LT."}, 00316 {OPC_BU4LT, ".LT."}, 00317 {OPC_BF8LT, ".LT."}, 00318 {OPC_BI4LE, ".LE."}, 00319 {OPC_BU8LE, ".LE."}, 00320 {OPC_BF4LE, ".LE."}, 00321 {OPC_BFQLE, ".LE."}, 00322 {OPC_BI8LE, ".LE."}, 00323 {OPC_BU4LE, ".LE."}, 00324 {OPC_BF8LE, ".LE."}, 00325 {OPC_I4U8EQ, ".EQ."}, 00326 {OPC_I4FQEQ, ".EQ."}, 00327 {OPC_I4I8EQ, ".EQ."}, 00328 {OPC_I4U4EQ, ".EQ."}, 00329 {OPC_I4CQEQ, ".EQ."}, 00330 {OPC_I4F8EQ, ".EQ."}, 00331 {OPC_I4C8EQ, ".EQ."}, 00332 {OPC_I4I4EQ, ".EQ."}, 00333 {OPC_I4F4EQ, ".EQ."}, 00334 {OPC_I4C4EQ, ".EQ."}, 00335 {OPC_I4U8NE, ".NE."}, 00336 {OPC_I4FQNE, ".NE."}, 00337 {OPC_I4I8NE, ".NE."}, 00338 {OPC_I4U4NE, ".NE."}, 00339 {OPC_I4CQNE, ".NE."}, 00340 {OPC_I4F8NE, ".NE."}, 00341 {OPC_I4C8NE, ".NE."}, 00342 {OPC_I4I4NE, ".NE."}, 00343 {OPC_I4F4NE, ".NE."}, 00344 {OPC_I4C4NE, ".NE."}, 00345 {OPC_I4I4GT, ".GT."}, 00346 {OPC_I4U8GT, ".GT."}, 00347 {OPC_I4F4GT, ".GT."}, 00348 {OPC_I4FQGT, ".GT."}, 00349 {OPC_I4I8GT, ".GT."}, 00350 {OPC_I4U4GT, ".GT."}, 00351 {OPC_I4F8GT, ".GT."}, 00352 {OPC_I4I4GE, ".GE."}, 00353 {OPC_I4U8GE, ".GE."}, 00354 {OPC_I4F4GE, ".GE."}, 00355 {OPC_I4FQGE, ".GE."}, 00356 {OPC_I4I8GE, ".GE."}, 00357 {OPC_I4U4GE, ".GE."}, 00358 {OPC_I4F8GE, ".GE."}, 00359 {OPC_I4I4LT, ".LT."}, 00360 {OPC_I4U8LT, ".LT."}, 00361 {OPC_I4F4LT, ".LT."}, 00362 {OPC_I4FQLT, ".LT."}, 00363 {OPC_I4I8LT, ".LT."}, 00364 {OPC_I4U4LT, ".LT."}, 00365 {OPC_I4F8LT, ".LT."}, 00366 {OPC_I4I4LE, ".LE."}, 00367 {OPC_I4U8LE, ".LE."}, 00368 {OPC_I4F4LE, ".LE."}, 00369 {OPC_I4FQLE, ".LE."}, 00370 {OPC_I4I8LE, ".LE."}, 00371 {OPC_I4U4LE, ".LE."}, 00372 {OPC_I4F8LE, ".LE."} 00373 // << WHIRL 0.30: replaced OPC_T1{EQ,NE,GT,GE,LT,LE} by OPC_B and OPC_I4 variants 00374 }; /* Fname_Map */ 00375 00376 00377 /*------------------------- Value Conversions -------------------------*/ 00378 /*---------------------------------------------------------------------*/ 00379 00380 /* Create a mapping from a pair of MTYPEs to the Fortran intrinsic 00381 * or builtin operation that carries out the conversion. NULL means 00382 * that either the conversion is redundant and can be ignored or there 00383 * is no way we can do it. 00384 */ 00385 static const char *Conv_Op[MTYPE_LAST+1][MTYPE_LAST+1]; 00386 00387 typedef struct Conv_Op 00388 { 00389 MTYPE from, to; 00390 const char *name; 00391 } CONV_OP; 00392 00393 #define NUMBER_OF_CONV_OPS sizeof(Conv_Op_Map)/sizeof(CONV_OP) 00394 00395 static const CONV_OP Conv_Op_Map[] = 00396 { 00397 /* from | to | op-name */ 00398 00399 /* Only consider conversion to ptr sized unsigned numbers 00400 * valid in Fortran. 00401 */ 00402 {MTYPE_I1, MTYPE_U4, ""}, // eraxxon: was JZEXT 00403 {MTYPE_I2, MTYPE_U4, ""}, 00404 {MTYPE_I4, MTYPE_U4, ""}, 00405 {MTYPE_I8, MTYPE_U4, ""}, 00406 /*{MTYPE_U1, MTYPE_U4, ""},*/ 00407 /*{MTYPE_U2, MTYPE_U4, ""},*/ 00408 /*{MTYPE_U4, MTYPE_U4, ""},*/ 00409 {MTYPE_U8, MTYPE_U4, ""}, 00410 00411 {MTYPE_I1, MTYPE_U8, ""}, // eraxxon: was KZEXT 00412 {MTYPE_I2, MTYPE_U8, ""}, 00413 {MTYPE_I4, MTYPE_U8, ""}, 00414 {MTYPE_I8, MTYPE_U8, ""}, 00415 /*{MTYPE_U1, MTYPE_U8, ""},*/ 00416 /*{MTYPE_U2, MTYPE_U8, ""},*/ 00417 /*{MTYPE_U4, MTYPE_U8, ""},*/ 00418 /*{MTYPE_U8, MTYPE_U8, ""},*/ 00419 00420 /*{MTYPE_I1, MTYPE_I1, ""},*/ 00421 {MTYPE_I2, MTYPE_I1, "INT1"}, 00422 {MTYPE_I4, MTYPE_I1, "INT1"}, 00423 {MTYPE_I8, MTYPE_I1, "INT1"}, 00424 /*{MTYPE_U1, MTYPE_I1, ""},*/ 00425 {MTYPE_U2, MTYPE_I1, "INT1"}, 00426 {MTYPE_U4, MTYPE_I1, "INT1"}, 00427 {MTYPE_U8, MTYPE_I1, "INT1"}, 00428 {MTYPE_F4, MTYPE_I1, "INT1"}, 00429 {MTYPE_F8, MTYPE_I1, "INT1"}, 00430 {MTYPE_FQ, MTYPE_I1, "INT1"}, 00431 00432 {MTYPE_I1, MTYPE_I2, "INT2"}, 00433 /*{MTYPE_I2, MTYPE_I2, ""},*/ 00434 {MTYPE_I4, MTYPE_I2, "INT2"}, 00435 {MTYPE_I8, MTYPE_I2, "INT2"}, 00436 {MTYPE_U1, MTYPE_I2, "INT2"}, 00437 /*{MTYPE_U2, MTYPE_I2, ""},*/ 00438 {MTYPE_U4, MTYPE_I2, "INT2"}, 00439 {MTYPE_U8, MTYPE_I2, "INT2"}, 00440 {MTYPE_F4, MTYPE_I2, "INT2"}, 00441 {MTYPE_F8, MTYPE_I2, "INT2"}, 00442 {MTYPE_FQ, MTYPE_I2, "INT2"}, 00443 00444 {MTYPE_I1, MTYPE_I4, "INT"}, 00445 {MTYPE_I2, MTYPE_I4, "INT"}, 00446 /*{MTYPE_I4, MTYPE_I4, ""},*/ 00447 {MTYPE_I8, MTYPE_I4, "INT"}, 00448 {MTYPE_U1, MTYPE_I4, "INT"}, 00449 {MTYPE_U2, MTYPE_I4, "INT"}, 00450 /*{MTYPE_U4, MTYPE_I4, ""},*/ 00451 {MTYPE_U8, MTYPE_I4, "INT"}, 00452 {MTYPE_F4, MTYPE_I4, "INT"}, 00453 {MTYPE_F8, MTYPE_I4, "INT"}, 00454 {MTYPE_FQ, MTYPE_I4, "INT"}, 00455 00456 00457 {MTYPE_I1, MTYPE_I8, "INT"}, 00458 {MTYPE_I2, MTYPE_I8, "INT"}, 00459 {MTYPE_I4, MTYPE_I8, "INT"}, 00460 /*{MTYPE_I8, MTYPE_I8, ""},*/ 00461 {MTYPE_U1, MTYPE_I8, "INT"}, 00462 {MTYPE_U2, MTYPE_I8, "INT"}, 00463 {MTYPE_U4, MTYPE_I8, "INT"}, 00464 /*{MTYPE_U8, MTYPE_I8, ""},*/ 00465 {MTYPE_F4, MTYPE_I8, "INT"}, 00466 {MTYPE_F8, MTYPE_I8, "INT"}, 00467 {MTYPE_FQ, MTYPE_I8, "INT"}, 00468 00469 {MTYPE_I1, MTYPE_F4, "REAL"}, 00470 {MTYPE_I2, MTYPE_F4, "REAL"}, 00471 {MTYPE_I4, MTYPE_F4, "REAL"}, 00472 {MTYPE_I8, MTYPE_F4, "REAL"}, 00473 {MTYPE_U1, MTYPE_F4, "REAL"}, 00474 {MTYPE_U2, MTYPE_F4, "REAL"}, 00475 {MTYPE_U4, MTYPE_F4, "REAL"}, 00476 {MTYPE_U8, MTYPE_F4, "REAL"}, 00477 /*{MTYPE_F4, MTYPE_F4, ""},*/ 00478 {MTYPE_F8, MTYPE_F4, "REAL"}, 00479 {MTYPE_FQ, MTYPE_F4, "REAL"}, 00480 00481 {MTYPE_I1, MTYPE_F8, "DBLE"}, 00482 {MTYPE_I2, MTYPE_F8, "DBLE"}, 00483 {MTYPE_I4, MTYPE_F8, "DBLE"}, 00484 {MTYPE_I8, MTYPE_F8, "DBLE"}, 00485 {MTYPE_U1, MTYPE_F8, "DBLE"}, 00486 {MTYPE_U2, MTYPE_F8, "DBLE"}, 00487 {MTYPE_U4, MTYPE_F8, "DBLE"}, 00488 {MTYPE_U8, MTYPE_F8, "DBLE"}, 00489 {MTYPE_F4, MTYPE_F8, "DBLE"}, 00490 /*{MTYPE_F8, MTYPE_F8, ""},*/ 00491 {MTYPE_FQ, MTYPE_F8, "DBLE"}, 00492 00493 {MTYPE_I1, MTYPE_FQ, "QREAL"}, 00494 {MTYPE_I2, MTYPE_FQ, "QREAL"}, 00495 {MTYPE_I4, MTYPE_FQ, "QREAL"}, 00496 {MTYPE_I8, MTYPE_FQ, "QREAL"}, 00497 {MTYPE_U1, MTYPE_FQ, "QREAL"}, 00498 {MTYPE_U2, MTYPE_FQ, "QREAL"}, 00499 {MTYPE_U4, MTYPE_FQ, "QREAL"}, 00500 {MTYPE_U8, MTYPE_FQ, "QREAL"}, 00501 {MTYPE_F4, MTYPE_FQ, "QREAL"}, 00502 {MTYPE_F8, MTYPE_FQ, "QREAL"} 00503 /*{MTYPE_FQ, MTYPE_FQ, ""}*/ 00504 }; /* Conv_Op_Map */ 00505 00506 00507 static void 00508 WN2F_Convert(TOKEN_BUFFER tokens, 00509 MTYPE from_mtype, 00510 MTYPE to_mtype) 00511 { 00512 /* We emit a warning message for conversions not covered (TODO: put 00513 * this warning under a command-line option). Converts the expression 00514 * in the given token-buffer to the given mtype. 00515 */ 00516 Prepend_Token_Special(tokens, '('); 00517 00518 if (Conv_Op[from_mtype][to_mtype] == NULL) 00519 { 00520 ASSERT_WARN(Conv_Op[from_mtype][to_mtype] != NULL, 00521 (DIAG_W2F_UNEXPECTED_CVT, 00522 MTYPE_name(from_mtype), MTYPE_name(to_mtype), 00523 "WN2F_Convert")); 00524 Prepend_Token_String(tokens, "WN2F_Convert"); 00525 } 00526 else 00527 { 00528 /* Note all these are intrinsics in the mongoose compiler and 00529 * need not be declared. 00530 */ 00531 Prepend_Token_String(tokens, Conv_Op[from_mtype][to_mtype]); 00532 } 00533 Append_Token_Special(tokens, ')'); 00534 } /* WN2F_Convert */ 00535 00536 00537 /*------------------------- Utility Functions -------------------------*/ 00538 /*---------------------------------------------------------------------*/ 00539 00540 static WN2F_STATUS 00541 WN2F_Translate_Arithmetic_Operand(TOKEN_BUFFER tokens, 00542 WN *opnd, 00543 TY_IDX assumed_ty, 00544 BOOL call_by_value, 00545 WN2F_CONTEXT context) 00546 { 00547 /* Translate an operand to a function or built-in operator invocation, 00548 * based on whether the context indicates that we have call-by-value 00549 * or call-by-reference. Also, the context indicates what type of 00550 * argument we expect. 00551 */ 00552 00553 /* TODO(?): Type promotion 00554 * 00555 * TY *opnd_ty = WN_Tree_Type(opnd); 00556 * if (!WN2F_arithmetic_compatible_types(assumed_ty, opnd_ty)) 00557 * { 00558 * WN2F_prepend_cast(opnd, assumed_ty, context); 00559 * } 00560 */ 00561 00562 /* We do not handle substring expressions here, and assume any 00563 * such expression will be dispatched to a specialty routine 00564 * such as WN2F_Intr_Infix_SubstrExpr(). 00565 */ 00566 ASSERT_DBG_WARN(!TY_Is_Character_Reference(assumed_ty) && 00567 !TY_Is_Chararray_Reference(assumed_ty), 00568 (DIAG_W2F_UNEXPECTED_SUBSTRING_REF, 00569 "WN2F_Translate_Arithmetic_Operand()")); 00570 00571 if (!call_by_value) 00572 { 00573 WN2F_Offset_Memref(tokens, 00574 opnd, /* address expression */ 00575 assumed_ty, /* address type */ 00576 TY_pointed(assumed_ty), /* object type */ 00577 0, /* offset from address */ 00578 context); 00579 } 00580 else 00581 { 00582 WN2F_translate(tokens, opnd, context); 00583 } 00584 00585 return EMPTY_WN2F_STATUS; 00586 } /* WN2F_Translate_Arithmetic_Operand */ 00587 00588 00589 static WN2F_STATUS 00590 WN2F_Infix_Op(TOKEN_BUFFER tokens, 00591 OPCODE opcode, 00592 TY_IDX result_ty, 00593 WN *wn0, 00594 WN *wn1, 00595 WN2F_CONTEXT context) 00596 { 00597 /* Infix Fortran operator. Only string argument are passed by 00598 * reference; all other argument types are passed by value. 00599 */ 00600 const BOOL parenthesize = !(WN2F_CONTEXT_no_parenthesis(context) || 00601 WN2F_CONTEXT_subexp_no_parenthesis(context)); 00602 00603 const BOOL binary_op = (wn0 != NULL); 00604 00605 TY_IDX wn0_ty; /* Expected type of wn0 */ 00606 TY_IDX wn1_ty; /* Expected type of wn1 */ 00607 TY_IDX kid0_ty; 00608 TY_IDX kid1_ty; 00609 INT priori_p = 0; 00610 INT priori_k0 = 0; 00611 INT priori_k1 = 0; 00612 00613 /* Ensure that subexpressions are parenthesized */ 00614 reset_WN2F_CONTEXT_no_parenthesis(context); 00615 00616 /* Get the expected types for the two operands, dependent on whether 00617 * or not we have a descriptor type. 00618 */ 00619 if (OPCODE_desc(opcode) == MTYPE_V) 00620 wn0_ty = wn1_ty = OPCODE_rtype(opcode); 00621 else 00622 wn0_ty = wn1_ty = Stab_Mtype_To_Ty(OPCODE_desc(opcode)); 00623 00624 if (parenthesize) 00625 Append_Token_Special(tokens, '('); 00626 00627 if (OPCODE_operator(opcode) == OPR_ADD) 00628 priori_p = 1; 00629 else if (OPCODE_operator(opcode) == OPR_SUB) 00630 priori_p = 2; 00631 else if (OPCODE_operator(opcode) == OPR_MPY) 00632 priori_p = 3; 00633 00634 if (binary_op) { 00635 if (WN_operator(wn0) == OPR_ADD || 00636 WN_operator(wn0) == OPR_SUB) 00637 priori_k0 = 2; 00638 else if (WN_operator(wn0) == OPR_MPY) 00639 priori_k0 = 3; 00640 } 00641 00642 if (WN_operator(wn1) == OPR_ADD || 00643 WN_operator(wn1) == OPR_SUB) 00644 priori_k1 = 1; 00645 else if (WN_operator(wn1) == OPR_MPY) 00646 priori_k1 = 3; 00647 00648 if (priori_p && priori_k0 && 00649 priori_p <= priori_k0) 00650 set_WN2F_CONTEXT_subexp_no_parenthesis(context); 00651 else 00652 reset_WN2F_CONTEXT_subexp_no_parenthesis(context); 00653 00654 /* First operand */ 00655 if (binary_op) { 00656 WN2F_Translate_Arithmetic_Operand(tokens, wn0, wn0_ty, 00657 TRUE/*call-by-value*/, 00658 context); 00659 } 00660 00661 reset_WN2F_CONTEXT_subexp_no_parenthesis(context); 00662 00663 /* Operation */ 00664 OPERATOR opr = OPCODE_operator(opcode); 00665 if (opr == OPR_EQ || opr == OPR_NE) { 00666 const char *oprstr = NULL, *logoprstr = NULL; 00667 switch (opr) { 00668 case OPR_EQ: 00669 oprstr = ".eq."; 00670 logoprstr = ".eqv."; 00671 break; 00672 case OPR_NE: 00673 oprstr = ".ne."; 00674 logoprstr = ".neqv."; 00675 break; 00676 }; 00677 00678 kid0_ty = kid1_ty = 0; 00679 if (WN_rtype(wn0) == MTYPE_I4 && WN_rtype(wn1) == MTYPE_I4) { 00680 if (WN_operator(wn0) == OPR_CALL) { 00681 kid0_ty = TY_ret_type(ST_pu_type(WN_st(wn0))); 00682 } 00683 else if (OPERATOR_has_1ty(WN_operator(wn0)) || OPERATOR_is_boolean(WN_operator(wn0))) { 00684 kid0_ty = WN_ty(wn0); 00685 } 00686 if (WN_operator(wn1) == OPR_CALL) { 00687 kid1_ty = TY_ret_type(ST_pu_type(WN_st(wn1))); 00688 } else if (OPERATOR_has_1ty(WN_operator(wn1)) || OPERATOR_is_boolean(WN_operator(wn1))) { 00689 kid1_ty = WN_ty(wn1); 00690 } 00691 } 00692 00693 if ( (wn0 && (kid0_ty && 00694 (TY_is_logical(kid0_ty) || TY_is_logical(wn0_ty)))) || 00695 (wn1 && (kid1_ty && 00696 (TY_is_logical(kid1_ty) || TY_is_logical(wn1_ty)))) ) { 00697 set_WN2F_CONTEXT_has_logical_arg(context); 00698 Append_Token_String(tokens, logoprstr); 00699 } 00700 else { 00701 Append_Token_String(tokens, oprstr); 00702 } 00703 } 00704 else { 00705 Append_Token_String(tokens, Opc_Fname[opcode]); 00706 reset_WN2F_CONTEXT_is_logical_operation(context); 00707 } 00708 00709 /* Second operand, or only operand for unary operation */ 00710 if (priori_p && priori_k1 && 00711 priori_p <= priori_k1) 00712 set_WN2F_CONTEXT_subexp_no_parenthesis(context); 00713 else 00714 reset_WN2F_CONTEXT_subexp_no_parenthesis(context); 00715 00716 WN2F_Translate_Arithmetic_Operand(tokens, wn1, wn1_ty, 00717 TRUE/*call-by-value*/, 00718 context); 00719 00720 reset_WN2F_CONTEXT_has_logical_arg(context); 00721 reset_WN2F_CONTEXT_subexp_no_parenthesis(context); 00722 00723 if (parenthesize) 00724 Append_Token_Special(tokens, ')'); 00725 00726 return EMPTY_WN2F_STATUS; 00727 } /* WN2F_Infix_Op */ 00728 00729 static WN2F_STATUS 00730 WN2F_Funcall_Op(TOKEN_BUFFER tokens, 00731 OPCODE opcode, 00732 WN *wn0, 00733 WN *wn1, 00734 WN2F_CONTEXT context) 00735 { 00736 /* Prefix Fortran operator. Only string argument are passed by 00737 * reference; all other argument types are passed by value. 00738 */ 00739 const BOOL binary_op = (wn0 != NULL); 00740 00741 TY_IDX const rty = Stab_Mtype_To_Ty(OPCODE_rtype(opcode)); 00742 TY_IDX dty = Stab_Mtype_To_Ty(OPCODE_desc(opcode)); 00743 00744 /* If there is no descriptor type, assume the operands should be 00745 * of the same type as the result. The assumed type of the argument 00746 * will be the dty. 00747 */ 00748 if (TY_kind(dty) == KIND_VOID) 00749 dty = rty; 00750 00751 00752 switch (OPCODE_operator(opcode)) { 00753 case OPR_EQ: 00754 if ((wn0 !=NULL) && TY_is_logical(WN_ty(wn0)) || 00755 (( wn1 !=NULL) && TY_is_logical(WN_ty(wn1)))) 00756 00757 Append_Token_String(tokens,".eqv."); 00758 else 00759 Append_Token_String(tokens,".eq."); 00760 00761 break; 00762 case OPR_NE: 00763 if ((wn0 !=NULL) && TY_is_logical(WN_ty(wn0)) || 00764 (( wn1 !=NULL) && TY_is_logical(WN_ty(wn1)))) 00765 Append_Token_String(tokens,".neq."); 00766 else 00767 Append_Token_String(tokens,".ne."); 00768 00769 break; 00770 00771 default: 00772 Append_Token_String(tokens, Opc_Fname[opcode]); 00773 reset_WN2F_CONTEXT_is_logical_operation(context); 00774 00775 break; 00776 } /*switch */ 00777 00778 00779 Append_Token_Special(tokens, '('); 00780 00781 /* No need to parenthesize subexpressions */ 00782 set_WN2F_CONTEXT_no_parenthesis(context); 00783 00784 /* First operand */ 00785 if (binary_op) 00786 { 00787 WN2F_Translate_Arithmetic_Operand(tokens, wn0, dty, 00788 TRUE/*call-by-value*/, 00789 context); 00790 Append_Token_Special(tokens, ','); 00791 } 00792 00793 /* Second operand, or only operand for unary operation */ 00794 WN2F_Translate_Arithmetic_Operand(tokens, wn1, dty, 00795 TRUE/*call-by-value*/, 00796 context); 00797 00798 Append_Token_Special(tokens, ')'); 00799 return EMPTY_WN2F_STATUS; 00800 } /* WN2F_Funcall_Op */ 00801 00802 00803 static WN2F_STATUS 00804 WN2F_Intr_Funcall(TOKEN_BUFFER tokens, 00805 WN *wn, 00806 const char *func_name, 00807 INT first_arg_idx, 00808 INT last_arg_idx, 00809 BOOL call_by_value, 00810 WN2F_CONTEXT context) 00811 { 00812 /* An intrinsic operator expression to be emitted with function 00813 * call syntax. All arguments are passed by value or by reference, 00814 * i.e. we never have some arguments passed by value and some by 00815 * reference, unless we have explicit INTR_OPC_ADRTMP or 00816 * INTR_OPC_VALTMP argument expressions. Note that we also 00817 * handle substring arguments here. 00818 */ 00819 INT arg_idx, implicit_args, total_implicit_args; 00820 TY_IDX opnd_type; 00821 00822 /* Determine the number of implicit arguments appended to the end 00823 * of the argument list (i.e. string lengths). 00824 */ 00825 if (WN_intrinsic(wn)==INTRN_COUNT) 00826 last_arg_idx--; 00827 00828 for (arg_idx = first_arg_idx, total_implicit_args = 0; 00829 arg_idx <= last_arg_idx - total_implicit_args; 00830 arg_idx++) 00831 { 00832 opnd_type = WN_Tree_Type(WN_kid(wn, arg_idx)); 00833 if (TY_Is_Character_Reference(opnd_type) || 00834 TY_Is_Chararray_Reference(opnd_type)) 00835 { 00836 total_implicit_args++; 00837 } 00838 } 00839 00840 /* Append the function-name */ 00841 if (WN_intrinsic(wn)==INTRN_LENTRIM) 00842 Append_Token_String(tokens,"LEN_TRIM"); 00843 else 00844 if (WN_intrinsic(wn)==INTRN_F90INDEX) 00845 Append_Token_String(tokens,"INDEX"); 00846 else 00847 Append_Token_String(tokens, func_name); 00848 00849 /* Append the argument list to the function reference, skipping 00850 * implicit character-string-length arguments assumed to be the 00851 * last ones in the list (see also ST2F_func_header()). 00852 */ 00853 Append_Token_Special(tokens, '('); 00854 set_WN2F_CONTEXT_no_parenthesis(context); 00855 00856 switch (WN_intrinsic(wn)) 00857 { 00858 case INTRN_F90INDEX: 00859 case INTRN_SCAN: 00860 case INTRN_VERIFY: 00861 for (arg_idx = first_arg_idx; 00862 arg_idx < last_arg_idx ; 00863 arg_idx=arg_idx+2) 00864 { 00865 opnd_type = WN_Tree_Type(WN_kid(wn, arg_idx)); 00866 00867 if (TY_Is_Character_Reference(opnd_type) || 00868 TY_Is_Chararray_Reference(opnd_type)) 00869 { 00870 WN2F_String_Argument(tokens, 00871 WN_kid(wn, arg_idx), /* string base */ 00872 WN_kid(wn, 00873 last_arg_idx 00874 ), /* string length */ 00875 context); 00876 } 00877 else { 00878 00879 WN2F_Translate_Arithmetic_Operand(tokens, 00880 WN_kid(wn, arg_idx), 00881 opnd_type, 00882 call_by_value, 00883 context); 00884 00885 } 00886 00887 if ((arg_idx) < WN_kid_count(wn) - 1) 00888 Append_Token_Special(tokens, ','); 00889 00890 } 00891 00892 set_WN2F_CONTEXT_has_logical_arg(context); 00893 00894 WN2F_Translate_Arithmetic_Operand(tokens, 00895 WN_kid(wn, last_arg_idx), 00896 opnd_type, 00897 call_by_value, 00898 context); 00899 00900 reset_WN2F_CONTEXT_has_logical_arg(context); 00901 00902 00903 break; 00904 00905 default: 00906 00907 for (arg_idx = first_arg_idx, implicit_args = 0; 00908 arg_idx <= last_arg_idx - implicit_args; 00909 arg_idx++) 00910 { 00911 opnd_type = WN_Tree_Type(WN_kid(wn, arg_idx)); 00912 00913 if (TY_Is_Character_Reference(opnd_type) || 00914 TY_Is_Chararray_Reference(opnd_type)) 00915 { 00916 implicit_args++; 00917 WN2F_String_Argument(tokens, 00918 WN_kid(wn, arg_idx), /* string base */ 00919 WN_kid(wn, 00920 last_arg_idx - 00921 (total_implicit_args - 00922 implicit_args)), /* string length */ 00923 context); 00924 if ((arg_idx+implicit_args) < WN_kid_count(wn) - 1) 00925 Append_Token_Special(tokens, ','); 00926 } 00927 else 00928 00929 if ((WN_intrinsic(wn)==INTRN_SUM|| 00930 INTRN_MAXVAL|| 00931 INTRN_PRODUCT) && 00932 (WN_opc_operator(WN_kid0(WN_kid(wn,arg_idx)))== OPR_INTCONST) && 00933 (WN_const_val(WN_kid0(WN_kid(wn,arg_idx)))==0)) { 00934 00935 } else { 00936 00937 WN2F_Translate_Arithmetic_Operand(tokens, 00938 WN_kid(wn, arg_idx), 00939 opnd_type, 00940 call_by_value, 00941 context); 00942 00943 // if ((arg_idx+implicit_args) < WN_kid_count(wn) - 1) 00944 if ((arg_idx+implicit_args) < last_arg_idx) 00945 if ((WN_intrinsic(wn)==INTRN_SUM || 00946 INTRN_MAXVAL|| 00947 INTRN_PRODUCT) && 00948 (WN_opc_operator(WN_kid0(WN_kid(wn,arg_idx+1)))== OPR_INTCONST) && 00949 (WN_const_val(WN_kid0(WN_kid(wn,arg_idx+1)))==0)) { 00950 00951 } else 00952 Append_Token_Special(tokens, ',');} 00953 } 00954 break; 00955 } 00956 Append_Token_Special(tokens, ')'); 00957 00958 /* TODO: See if we need to cast the resultant value */ 00959 00960 return EMPTY_WN2F_STATUS; 00961 } /* WN2F_Intr_Funcall */ 00962 00963 00964 static WN2F_STATUS 00965 WN2F_Intr_Infix(TOKEN_BUFFER tokens, 00966 const char *op_name, 00967 WN *opnd0, /* NULL for unary operation */ 00968 WN *opnd1, 00969 BOOL call_by_value, 00970 WN2F_CONTEXT context) 00971 { 00972 /* An intrinsic operator expression to be emitted with infix operator 00973 * syntax. Note that we have already determined what the two arguments 00974 * are, and any implicit argument have already been ignored. 00975 */ 00976 const BOOL parenthesize = !WN2F_CONTEXT_no_parenthesis(context); 00977 const BOOL binary_op = (opnd0 != NULL); 00978 00979 /* Ensure that subexpressions are parenthesized */ 00980 reset_WN2F_CONTEXT_no_parenthesis(context); 00981 00982 if (parenthesize) 00983 Append_Token_Special(tokens, '('); 00984 00985 if (binary_op) 00986 WN2F_Translate_Arithmetic_Operand(tokens, 00987 opnd0, 00988 WN_Tree_Type(opnd0), 00989 call_by_value, 00990 context); 00991 Append_Token_String(tokens, op_name); 00992 WN2F_Translate_Arithmetic_Operand(tokens, 00993 opnd1, 00994 WN_Tree_Type(opnd1), 00995 call_by_value, 00996 context); 00997 if (parenthesize) 00998 Append_Token_Special(tokens, ')'); 00999 01000 return EMPTY_WN2F_STATUS; 01001 } /* WN2F_Intr_Infix */ 01002 01003 01004 static WN2F_STATUS 01005 WN2F_Binary_Substr_Op(TOKEN_BUFFER tokens, 01006 WN *op_wn, /* Top-level expression */ 01007 const char *op_name, /* The builtin operator */ 01008 WN2F_CONTEXT context) 01009 { 01010 /* Similar to WN2F_Infix_Op, but we expect the arguments to be 01011 * string expressions. 01012 */ 01013 const BOOL parenthesize = !WN2F_CONTEXT_no_parenthesis(context); 01014 01015 /* Ensure that subexpressions are parenthesized */ 01016 reset_WN2F_CONTEXT_no_parenthesis(context); 01017 01018 if (parenthesize) 01019 Append_Token_Special(tokens, '('); 01020 01021 WN2F_String_Argument(tokens, 01022 WN_kid(op_wn, 0), /* string base */ 01023 WN_kid(op_wn, 2), /* string length */ 01024 context); 01025 Append_Token_String(tokens, op_name); 01026 WN2F_String_Argument(tokens, 01027 WN_kid(op_wn, 1), /* string base */ 01028 WN_kid(op_wn, 3), /* string length */ 01029 context); 01030 if (parenthesize) 01031 Append_Token_Special(tokens, ')'); 01032 01033 return EMPTY_WN2F_STATUS; 01034 } /* WN2F_Binary_Substr_Op */ 01035 01036 01037 /*------------------------- Exported Functions ------------------------*/ 01038 /*---------------------------------------------------------------------*/ 01039 01040 01041 void WN2F_Expr_initialize(void) 01042 { 01043 INT map; 01044 01045 /* Reset the Opc_Fname array. This has already been 01046 * implicitly done by declaring it as static: 01047 * 01048 * OPCODE opc; 01049 * for (opc = 0; opc < NUMBER_OF_OPCODES; opc++) 01050 * Opc_Fname[opc] = NULL; 01051 * 01052 * Initialize the Opc_Fname array: 01053 */ 01054 for (map = 0; map < NUMBER_OF_FNAME_PARTIALMAPS; map++) 01055 Opc_Fname[Fname_Map[map].opc] = Fname_Map[map].fname; 01056 01057 /* Initialize the Conv_Op array (default value is NULL) */ 01058 for (map = 0; map < NUMBER_OF_CONV_OPS; map++) 01059 Conv_Op[Conv_Op_Map[map].from][Conv_Op_Map[map].to] = 01060 Conv_Op_Map[map].name; 01061 01062 } /* WN2F_Expr_initialize */ 01063 01064 01065 void WN2F_Expr_finalize(void) 01066 { 01067 /* Nothing to do for now */ 01068 } /* WN2F_Expr_finalize */ 01069 01070 01071 WN2F_STATUS 01072 WN2F_binaryop(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01073 { 01074 const BOOL parenthesize = !WN2F_CONTEXT_no_parenthesis(context); 01075 01076 ASSERT_DBG_FATAL(WN_kid_count(wn) == 2, 01077 (DIAG_W2F_UNEXPECTED_NUM_KIDS, 01078 WN_kid_count(wn), 2, WN_opc_name(wn))); 01079 01080 if (WN2F_IS_INFIX_OP(WN_opcode(wn))) 01081 WN2F_Infix_Op(tokens, 01082 WN_opcode(wn), 01083 WN_Tree_Type(wn), 01084 WN_kid0(wn), 01085 WN_kid1(wn), 01086 context); 01087 else if (WN2F_IS_FUNCALL_OP(WN_opcode(wn))) 01088 WN2F_Funcall_Op(tokens, 01089 WN_opcode(wn), 01090 WN_kid0(wn), 01091 WN_kid1(wn), 01092 context); 01093 else 01094 ASSERT_DBG_FATAL(FALSE, (DIAG_W2F_UNEXPECTED_OPC, "WN2F_binaryop")); 01095 01096 reset_WN2F_CONTEXT_is_logical_operation(context); 01097 01098 return EMPTY_WN2F_STATUS; 01099 } /* WN2F_binaryop */ 01100 01101 01102 WN2F_STATUS 01103 WN2F_unaryop(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01104 { 01105 ASSERT_DBG_FATAL(WN_kid_count(wn) == 1, 01106 (DIAG_W2F_UNEXPECTED_NUM_KIDS, 01107 WN_kid_count(wn), 1, WN_opc_name(wn))); 01108 01109 if (WN2F_IS_INFIX_OP(WN_opcode(wn))) 01110 WN2F_Infix_Op(tokens, 01111 WN_opcode(wn), 01112 WN_Tree_Type(wn), 01113 NULL, /* No first operand */ 01114 WN_kid0(wn), 01115 context); 01116 else if (WN2F_IS_FUNCALL_OP(WN_opcode(wn))) 01117 WN2F_Funcall_Op(tokens, 01118 WN_opcode(wn), 01119 NULL, /* No first operand */ 01120 WN_kid0(wn), 01121 context); 01122 else 01123 ASSERT_DBG_FATAL(FALSE, (DIAG_W2F_UNEXPECTED_OPC, "WN2F_binaryop")); 01124 01125 return EMPTY_WN2F_STATUS; 01126 } /* WN2F_unaryop */ 01127 01128 01129 WN2F_STATUS 01130 WN2F_intrinsic_op(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01131 { 01132 /* An intrinsic operator expression. Generate the call as is, 01133 * regardless how the return value is returned, since we know 01134 * the consumer of the value is the surrounding expression. This 01135 * call is not related to the call-info generated by PUinfo. 01136 * Note that either all or none of the arguments are call-by-value. 01137 */ 01138 INT first_arg_idx, last_arg_idx; 01139 BOOL by_value; 01140 01141 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_INTRINSIC_OP, 01142 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_intrinsic_op")); 01143 01144 by_value = INTRN_by_value(WN_intrinsic(wn)); 01145 last_arg_idx = WN_kid_count(wn) - 1; 01146 first_arg_idx = 0; /* Assume we never return to first argument */ 01147 01148 /* Switch on WN_intrinsic(wn) to handle builtin fortran opcodes. 01149 */ 01150 switch (WN_intrinsic(wn)) 01151 { 01152 case INTRN_I4EXPEXPR: 01153 case INTRN_I8EXPEXPR: 01154 case INTRN_F4EXPEXPR: 01155 case INTRN_F8EXPEXPR: 01156 case INTRN_FQEXPEXPR: 01157 case INTRN_C4EXPEXPR: 01158 case INTRN_C8EXPEXPR: 01159 case INTRN_CQEXPEXPR: 01160 case INTRN_F4I4EXPEXPR: 01161 case INTRN_F4I8EXPEXPR: 01162 case INTRN_F8I4EXPEXPR: 01163 case INTRN_F8I8EXPEXPR: 01164 case INTRN_FQI4EXPEXPR: 01165 case INTRN_FQI8EXPEXPR: 01166 case INTRN_C4I4EXPEXPR: 01167 case INTRN_C4I8EXPEXPR: 01168 case INTRN_C8I4EXPEXPR: 01169 case INTRN_C8I8EXPEXPR: 01170 case INTRN_CQI4EXPEXPR: 01171 case INTRN_CQI8EXPEXPR: 01172 WN2F_Intr_Infix(tokens, 01173 "**", WN_kid0(wn), WN_kid1(wn), by_value, context); 01174 break; 01175 01176 case INTRN_CEQEXPR: 01177 WN2F_Binary_Substr_Op(tokens, wn, ".EQ.", context); 01178 break; 01179 case INTRN_CNEEXPR: 01180 WN2F_Binary_Substr_Op(tokens, wn, ".NE.", context); 01181 break; 01182 case INTRN_CGEEXPR: 01183 WN2F_Binary_Substr_Op(tokens, wn, ".GE.", context); 01184 break; 01185 case INTRN_CGTEXPR: 01186 WN2F_Binary_Substr_Op(tokens, wn, ".GT.", context); 01187 break; 01188 case INTRN_CLEEXPR: 01189 WN2F_Binary_Substr_Op(tokens, wn, ".LE.", context); 01190 break; 01191 case INTRN_CLTEXPR: 01192 WN2F_Binary_Substr_Op(tokens, wn, ".LT.", context); 01193 break; 01194 01195 case INTRN_U4I1ADRTMP: 01196 case INTRN_U4I2ADRTMP: 01197 case INTRN_U4I4ADRTMP: 01198 case INTRN_U4I8ADRTMP: 01199 case INTRN_U4F4ADRTMP: 01200 case INTRN_U4F8ADRTMP: 01201 case INTRN_U4FQADRTMP: 01202 case INTRN_U4C4ADRTMP: 01203 case INTRN_U4C8ADRTMP: 01204 case INTRN_U4CQADRTMP: 01205 case INTRN_U4VADRTMP : 01206 case INTRN_U8I1ADRTMP: 01207 case INTRN_U8I2ADRTMP: 01208 case INTRN_U8I4ADRTMP: 01209 case INTRN_U8I8ADRTMP: 01210 case INTRN_U8F4ADRTMP: 01211 case INTRN_U8F8ADRTMP: 01212 case INTRN_U8FQADRTMP: 01213 case INTRN_U8C4ADRTMP: 01214 case INTRN_U8C8ADRTMP: 01215 case INTRN_U8CQADRTMP: 01216 case INTRN_U8VADRTMP: 01217 /* Implicit call by reference. Emit the dereferenced parameter. 01218 */ 01219 WN2F_translate(tokens, WN_kid0(wn), context); 01220 break; 01221 01222 case INTRN_I4VALTMP: 01223 case INTRN_I8VALTMP: 01224 case INTRN_F4VALTMP: 01225 case INTRN_F8VALTMP: 01226 case INTRN_FQVALTMP: 01227 case INTRN_C4VALTMP: 01228 case INTRN_C8VALTMP: 01229 case INTRN_CQVALTMP: 01230 /* Call-by-value. Assume the context determines when it is 01231 * necessary to put a %val qualifier around the argument. 01232 */ 01233 WN2F_translate(tokens, WN_kid0(wn), context); 01234 break; 01235 01236 default: 01237 WN2F_Intr_Funcall(tokens, 01238 wn, 01239 WN_intrinsic_name((INTRINSIC) WN_intrinsic(wn)), 01240 first_arg_idx, 01241 last_arg_idx, 01242 by_value, 01243 context); 01244 break; 01245 } /*switch*/ 01246 01247 /* TODO: See if we need to cast the resultant value. 01248 * TY * return_ty = 01249 * WN_intrinsic_return_ty(WN_opcode(wn), WN_intrinsic(wn)); 01250 */ 01251 01252 return EMPTY_WN2F_STATUS; 01253 } /* WN2F_intrinsic_op */ 01254 01255 01256 WN2F_STATUS 01257 WN2F_tas(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01258 { 01259 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_TAS, 01260 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_tas")); 01261 01262 /* Just ignore TAS operators for now. TODO: make sure this 01263 * is always ok. 01264 */ 01265 return WN2F_translate(tokens, WN_kid0(wn), context); 01266 } /* WN2F_tas */ 01267 01268 01269 WN2F_STATUS 01270 WN2F_select(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01271 { 01272 /* SELECT is almost the same as the F90 MERGE intrinsic, 01273 so I will output it that way for now */ 01274 01275 Append_Token_String(tokens, "MERGE"); 01276 Append_Token_Special(tokens, '('); 01277 WN2F_translate(tokens, WN_kid1(wn), context); 01278 Append_Token_Special(tokens, ','); 01279 01280 WN2F_translate(tokens, WN_kid2(wn), context); 01281 Append_Token_Special(tokens, ','); 01282 01283 WN2F_translate(tokens, WN_kid0(wn), context); 01284 01285 Append_Token_Special(tokens, ')'); 01286 #if 0 01287 ASSERT_DBG_WARN(FALSE, (DIAG_UNIMPLEMENTED, "WN2F_select")); 01288 #endif 01289 01290 return EMPTY_WN2F_STATUS; 01291 } /* WN2F_select */ 01292 01293 01294 WN2F_STATUS 01295 WN2F_cvt(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01296 { 01297 TOKEN_BUFFER expr_tokens = New_Token_Buffer(); 01298 01299 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_CVT, 01300 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_cvt")); 01301 01302 WN2F_translate(expr_tokens, WN_kid0(wn), context); 01303 01304 /* Maybe we shouldn't or needn't explicitly output these kinds of 01305 convert in .w2f.f file----fzhao 01306 */ 01307 if (W2F_OpenAD) { 01308 WN2F_Convert(expr_tokens, WN_opc_dtype(wn), WN_opc_rtype(wn)); 01309 } 01310 Append_And_Reclaim_Token_List(tokens, &expr_tokens); 01311 01312 return EMPTY_WN2F_STATUS; 01313 } /* WN2F_cvt */ 01314 01315 01316 WN2F_STATUS 01317 WN2F_cvtl(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01318 { 01319 TY_IDX rtype, dtype; 01320 TOKEN_BUFFER expr_tokens; 01321 01322 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_CVTL, 01323 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_cvtl")); 01324 01325 dtype = WN_Tree_Type(WN_kid0(wn)); 01326 rtype = WN_Tree_Type(wn); 01327 01328 /* Only convert if it is necessary */ 01329 01330 if (Conv_Op[TY_mtype(dtype)][TY_mtype(rtype)] != NULL ) 01331 01332 { 01333 expr_tokens = New_Token_Buffer(); 01334 WN2F_translate(expr_tokens, WN_kid0(wn), context); 01335 WN2F_Convert(expr_tokens, TY_mtype(dtype), TY_mtype(rtype)); 01336 Append_And_Reclaim_Token_List(tokens, &expr_tokens); 01337 } 01338 else 01339 { 01340 WN2F_translate(tokens, WN_kid0(wn), context); 01341 } 01342 return EMPTY_WN2F_STATUS; 01343 } /* WN2F_cvtl */ 01344 01345 01346 WN2F_STATUS 01347 WN2F_realpart(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01348 { 01349 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_REALPART, 01350 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_realpart")); 01351 01352 switch (WN_opc_rtype(wn)) 01353 { 01354 case MTYPE_F4: 01355 Append_Token_String(tokens, "REAL"); 01356 break; 01357 case MTYPE_F8: 01358 Append_Token_String(tokens, "DBLE"); 01359 break; 01360 case MTYPE_FQ: 01361 Append_Token_String(tokens, "QREAL"); 01362 01363 break; 01364 default: 01365 ASSERT_DBG_FATAL(FALSE, 01366 (DIAG_W2F_UNEXPECTED_BTYPE, 01367 MTYPE_name(WN_opc_rtype(wn)), 01368 "WN2F_realpart")); 01369 Append_Token_String(tokens, "WN2F_realpart"); 01370 break; 01371 } 01372 Append_Token_Special(tokens, '('); 01373 WN2F_translate(tokens, WN_kid0(wn), context); 01374 Append_Token_Special(tokens, ')'); 01375 01376 return EMPTY_WN2F_STATUS; 01377 } /* WN2F_realpart */ 01378 01379 01380 WN2F_STATUS 01381 WN2F_imagpart(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01382 { 01383 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_IMAGPART, 01384 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_imagpart")); 01385 01386 switch (WN_opc_rtype(wn)) 01387 { 01388 case MTYPE_F4: 01389 Append_Token_String(tokens, "AIMAG"); 01390 break; 01391 case MTYPE_F8: 01392 Append_Token_String(tokens, "DIMAG"); 01393 break; 01394 case MTYPE_FQ: 01395 Append_Token_String(tokens, "QIMAG"); 01396 break; 01397 default: 01398 ASSERT_DBG_FATAL(FALSE, 01399 (DIAG_W2F_UNEXPECTED_BTYPE, 01400 MTYPE_name(WN_opc_rtype(wn)), 01401 "WN2F_imagpart")); 01402 Append_Token_String(tokens, "WN2F_imagpart"); 01403 break; 01404 } 01405 Append_Token_Special(tokens, '('); 01406 WN2F_translate(tokens, WN_kid0(wn), context); 01407 Append_Token_Special(tokens, ')'); 01408 01409 return EMPTY_WN2F_STATUS; 01410 } /* WN2F_imagpart */ 01411 01412 01413 WN2F_STATUS 01414 WN2F_paren(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01415 { 01416 WN2F_STATUS status; 01417 01418 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_PAREN, 01419 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_paren")); 01420 01421 Append_Token_Special(tokens, '('); 01422 set_WN2F_CONTEXT_subexp_no_parenthesis(context); 01423 status = WN2F_translate(tokens, WN_kid0(wn), context); 01424 reset_WN2F_CONTEXT_subexp_no_parenthesis(context); 01425 Append_Token_Special(tokens, ')'); 01426 01427 return status; 01428 } /* WN2F_paren */ 01429 01430 01431 WN2F_STATUS 01432 WN2F_complex(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01433 { 01434 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_COMPLEX, 01435 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_complex")); 01436 01437 switch (WN_opc_rtype(wn)) 01438 { 01439 case MTYPE_C4: 01440 Append_Token_String(tokens, "CMPLX"); 01441 break; 01442 case MTYPE_C8: 01443 Append_Token_String(tokens, "DCMPLX"); 01444 break; 01445 case MTYPE_CQ: 01446 Append_Token_String(tokens, "QCMPLX"); 01447 break; 01448 default: 01449 ASSERT_DBG_FATAL(FALSE, 01450 (DIAG_W2F_UNEXPECTED_BTYPE, 01451 MTYPE_name(WN_opc_rtype(wn)), 01452 "WN2F_complex")); 01453 Append_Token_String(tokens, "WN2F_complex"); 01454 break; 01455 } 01456 /* No need to parenthesize subexpressions */ 01457 set_WN2F_CONTEXT_no_parenthesis(context); 01458 01459 Append_Token_Special(tokens, '('); /* getting real part */ 01460 (void)WN2F_translate(tokens, WN_kid0(wn), context); 01461 Append_Token_Special(tokens, ','); /* getting imaginary part */ 01462 (void)WN2F_translate(tokens, WN_kid1(wn), context); 01463 Append_Token_Special(tokens, ')'); 01464 01465 return EMPTY_WN2F_STATUS; 01466 } /* WN2F_complex */ 01467 01468 01469 WN2F_STATUS 01470 WN2F_ceil(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01471 { 01472 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_CEIL, 01473 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_ceil")); 01474 ASSERT_DBG_FATAL(WN_kid_count(wn) == 1, 01475 (DIAG_W2F_UNEXPECTED_NUM_KIDS, 01476 WN_kid_count(wn), 1, WN_opc_name(wn))); 01477 01478 /* Special handling for opcodes that do not have an intrinsic 01479 * counterpart in compiler versions < v7.00. TODO: define this one. 01480 */ 01481 ASSERT_DBG_WARN(!W2F_Ansi_Format, 01482 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_ceil")); 01483 01484 WN2F_Funcall_Op(tokens, 01485 WN_opcode(wn), 01486 NULL, 01487 WN_kid0(wn), 01488 context); 01489 01490 return EMPTY_WN2F_STATUS; 01491 } /* WN2F_ceil */ 01492 01493 01494 WN2F_STATUS 01495 WN2F_floor(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01496 { 01497 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_FLOOR, 01498 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_floor")); 01499 ASSERT_DBG_FATAL(WN_kid_count(wn) == 1, 01500 (DIAG_W2F_UNEXPECTED_NUM_KIDS, 01501 WN_kid_count(wn), 1, WN_opc_name(wn))); 01502 01503 /* Special handling for opcodes that do not have an intrinsic 01504 * counterpart in compiler versions < v7.00. TODO: define this one. 01505 */ 01506 ASSERT_DBG_WARN(!W2F_Ansi_Format, 01507 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_floor")); 01508 01509 WN2F_Funcall_Op(tokens, 01510 WN_opcode(wn), 01511 NULL, 01512 WN_kid0(wn), 01513 context); 01514 01515 return EMPTY_WN2F_STATUS; 01516 } /* WN2F_floor */ 01517 01518 01519 WN2F_STATUS 01520 WN2F_ashr(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01521 { 01522 TY_IDX const rty = Stab_Mtype_To_Ty(WN_rtype(wn)); 01523 01524 ASSERT_DBG_FATAL(WN_kid_count(wn) == 2, 01525 (DIAG_W2F_UNEXPECTED_NUM_KIDS, 01526 WN_kid_count(wn), 2, WN_opc_name(wn))); 01527 01528 if (W2F_Ansi_Format) 01529 { 01530 /* Special handling for opcodes that do not have an intrinsic 01531 * counterpart in compiler versions < v7.00. 01532 */ 01533 switch (WN_opcode(wn)) 01534 { 01535 case OPC_I4ASHR: 01536 Append_Token_String(tokens, "I4ASHR"); 01537 break; 01538 case OPC_U8ASHR: 01539 Append_Token_String(tokens, "U8ASHR"); 01540 break; 01541 case OPC_I8ASHR: 01542 Append_Token_String(tokens, "I8ASHR"); 01543 break; 01544 case OPC_U4ASHR: 01545 Append_Token_String(tokens, "I4ASHR"); 01546 break; 01547 default: 01548 ASSERT_DBG_FATAL(FALSE, 01549 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_ashr")); 01550 break; 01551 } 01552 01553 /* No need to parenthesize subexpressions */ 01554 set_WN2F_CONTEXT_no_parenthesis(context); 01555 01556 Append_Token_Special(tokens, '('); 01557 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid0(wn), rty, 01558 TRUE, /* call-by-value */ 01559 context); 01560 Append_Token_Special(tokens, ','); 01561 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid1(wn), rty, 01562 TRUE, /* call-by-value */ 01563 context); 01564 01565 Append_Token_Special(tokens, ')'); 01566 } 01567 else 01568 { 01569 /* Has an intrinsic counterpart in compiler versions >= v7.00. 01570 */ 01571 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_ASHR, 01572 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_ashr")); 01573 WN2F_Funcall_Op(tokens, 01574 WN_opcode(wn), 01575 WN_kid0(wn), 01576 WN_kid1(wn), 01577 context); 01578 } 01579 01580 return EMPTY_WN2F_STATUS; 01581 } /* WN2F_ashr */ 01582 01583 01584 WN2F_STATUS 01585 WN2F_lshr(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01586 { 01587 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01588 01589 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_LSHR, 01590 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_lshr")); 01591 01592 /* No need to parenthesize subexpressions */ 01593 set_WN2F_CONTEXT_no_parenthesis(context); 01594 01595 Append_Token_String(tokens, "ISHIFT"); 01596 Append_Token_Special(tokens, '('); 01597 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,0), result_ty, 01598 !TY_Is_Character_Reference(result_ty), 01599 context); 01600 Append_Token_Special(tokens, ','); 01601 Append_Token_Special(tokens, '-'); 01602 Append_Token_Special(tokens, '('); 01603 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,1), result_ty, 01604 !TY_Is_Character_Reference(result_ty), 01605 context); 01606 Append_Token_Special(tokens, ')'); 01607 Append_Token_Special(tokens, ')'); 01608 01609 return EMPTY_WN2F_STATUS; 01610 } /* WN2F_lshr */ 01611 01612 01613 WN2F_STATUS 01614 WN2F_bnor(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01615 { 01616 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01617 01618 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_BNOR, 01619 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_bnor")); 01620 01621 /* No need to parenthesize subexpressions */ 01622 set_WN2F_CONTEXT_no_parenthesis(context); 01623 01624 Append_Token_String(tokens, "NOT"); 01625 Append_Token_Special(tokens, '('); 01626 Append_Token_String(tokens, "IOR"); 01627 Append_Token_Special(tokens, '('); 01628 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,0), result_ty, 01629 !TY_Is_Character_Reference(result_ty), 01630 context); 01631 Append_Token_Special(tokens, ','); 01632 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,1), result_ty, 01633 !TY_Is_Character_Reference(result_ty), 01634 context); 01635 Append_Token_Special(tokens, ')'); 01636 Append_Token_Special(tokens, ')'); 01637 01638 return EMPTY_WN2F_STATUS; 01639 } /* WN2F_bnor */ 01640 01641 01642 WN2F_STATUS 01643 WN2F_recip(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01644 { 01645 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01646 BOOL no_parenthesis = (WN_operator(WN_kid0(wn)) == OPR_PAREN || 01647 WN_operator(WN_kid0(wn)) == OPR_LDID || 01648 WN_operator(WN_kid0(wn)) == OPR_LDA); 01649 01650 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_RECIP, 01651 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_recip")); 01652 01653 if (TY_mtype(result_ty) == MTYPE_FQ || TY_mtype(result_ty) == MTYPE_CQ) 01654 Append_Token_String(tokens, "1Q00"); 01655 else if (TY_mtype(result_ty) == MTYPE_F8 || TY_mtype(result_ty) == MTYPE_C8) 01656 Append_Token_String(tokens, "1D00"); 01657 else 01658 Append_Token_String(tokens, "1E00"); 01659 01660 Append_Token_Special(tokens, '/'); 01661 if (!no_parenthesis) 01662 Append_Token_Special(tokens, '('); 01663 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,0), result_ty, 01664 !TY_Is_Character_Reference(result_ty), 01665 context); 01666 if (!no_parenthesis) 01667 Append_Token_Special(tokens, ')'); 01668 01669 return EMPTY_WN2F_STATUS; 01670 } /* WN2F_recip */ 01671 01672 WN2F_STATUS 01673 WN2F_rsqrt(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01674 { 01675 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01676 01677 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_RSQRT, 01678 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_rsqrt")); 01679 01680 Append_Token_Special(tokens, '('); 01681 Append_Token_String(tokens, "1.0"); 01682 Append_Token_Special(tokens, '/'); 01683 Append_Token_String(tokens, "SQRT"); 01684 Append_Token_Special(tokens, '('); 01685 set_WN2F_CONTEXT_no_parenthesis(context); 01686 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,0), result_ty, 01687 !TY_Is_Character_Reference(result_ty), 01688 context); 01689 Append_Token_Special(tokens, ')'); 01690 Append_Token_Special(tokens, ')'); 01691 01692 return EMPTY_WN2F_STATUS; 01693 } /* WN2F_rsqrt */ 01694 01695 01696 WN2F_STATUS 01697 WN2F_madd(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01698 { 01699 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01700 01701 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_MADD, 01702 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_madd")); 01703 01704 Append_Token_Special(tokens, '('); 01705 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,1), result_ty, 01706 !TY_Is_Character_Reference(result_ty), 01707 context); 01708 Append_Token_Special(tokens, '*'); 01709 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,2), result_ty, 01710 !TY_Is_Character_Reference(result_ty), 01711 context); 01712 Append_Token_Special(tokens, '+'); 01713 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn, 0), result_ty, 01714 !TY_Is_Character_Reference(result_ty), 01715 context); 01716 Append_Token_Special(tokens, ')'); 01717 01718 return EMPTY_WN2F_STATUS; 01719 } /* WN2F_madd */ 01720 01721 01722 WN2F_STATUS 01723 WN2F_msub(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01724 { 01725 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01726 01727 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_MSUB, 01728 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_msub")); 01729 01730 Append_Token_Special(tokens, '('); 01731 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,1), result_ty, 01732 !TY_Is_Character_Reference(result_ty), 01733 context); 01734 Append_Token_Special(tokens, '*'); 01735 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,2), result_ty, 01736 !TY_Is_Character_Reference(result_ty), 01737 context); 01738 Append_Token_Special(tokens, '-'); 01739 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn, 0), result_ty, 01740 !TY_Is_Character_Reference(result_ty), 01741 context); 01742 Append_Token_Special(tokens, ')'); 01743 01744 return EMPTY_WN2F_STATUS; 01745 } /* WN2F_msub */ 01746 01747 01748 WN2F_STATUS 01749 WN2F_nmadd(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01750 { 01751 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01752 01753 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_NMADD, 01754 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_nmadd")); 01755 01756 Append_Token_Special(tokens, '-'); 01757 Append_Token_Special(tokens, '('); 01758 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,1), result_ty, 01759 !TY_Is_Character_Reference(result_ty), 01760 context); 01761 Append_Token_Special(tokens, '*'); 01762 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,2), result_ty, 01763 !TY_Is_Character_Reference(result_ty), 01764 context); 01765 Append_Token_Special(tokens, '+'); 01766 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn, 0), result_ty, 01767 !TY_Is_Character_Reference(result_ty), 01768 context); 01769 Append_Token_Special(tokens, ')'); 01770 01771 return EMPTY_WN2F_STATUS; 01772 } /* WN2F_nmadd */ 01773 01774 01775 WN2F_STATUS 01776 WN2F_nmsub(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01777 { 01778 TY_IDX const result_ty = Stab_Mtype_To_Ty(WN_opc_rtype(wn)); 01779 01780 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_NMSUB, 01781 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_nmsub")); 01782 01783 Append_Token_Special(tokens, '-'); 01784 Append_Token_Special(tokens, '('); 01785 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,1), result_ty, 01786 !TY_Is_Character_Reference(result_ty), 01787 context); 01788 Append_Token_Special(tokens, '*'); 01789 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn,2), result_ty, 01790 !TY_Is_Character_Reference(result_ty), 01791 context); 01792 Append_Token_Special(tokens, '-'); 01793 WN2F_Translate_Arithmetic_Operand(tokens, WN_kid(wn, 0), result_ty, 01794 !TY_Is_Character_Reference(result_ty), 01795 context); 01796 Append_Token_Special(tokens, ')'); 01797 01798 return EMPTY_WN2F_STATUS; 01799 } /* WN2F_nmsub */ 01800 01801 01802 WN2F_STATUS 01803 WN2F_const(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01804 { 01805 const BOOL parenthesize = !WN2F_CONTEXT_no_parenthesis(context); 01806 BOOL add_paren = false; 01807 01808 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_CONST, 01809 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_const")); 01810 01811 /* eraxxon: always parenthesize negative constants to prevent generation of 01812 code like "x + -73" */ 01813 TCON& tcon = STC_val(WN_st(wn)); 01814 if (parenthesize && !WN2F_CONTEXT_is_logical_arg(context)) { 01815 BOOL neg_num = 0; 01816 switch (TCON_ty(tcon)) 01817 { 01818 case MTYPE_F4: 01819 neg_num = (TCON_fval(tcon) < 0); 01820 break; 01821 case MTYPE_F8: 01822 neg_num = (TCON_dval(tcon) < 0); 01823 break; 01824 case MTYPE_FQ: 01825 neg_num = (TCON_qval(tcon) < 0); 01826 break; 01827 case MTYPE_I1: 01828 case MTYPE_I2: 01829 case MTYPE_I4: 01830 case MTYPE_I8: 01831 neg_num = (TCON_ival(tcon) < 0); 01832 break; 01833 } 01834 add_paren = (neg_num); 01835 } 01836 01837 if (add_paren) { 01838 Append_Token_Special(tokens, '('); 01839 } 01840 TCON2F_translate(tokens, tcon, (TY_is_logical(ST_type(WN_st(wn))) || 01841 WN2F_CONTEXT_is_logical_arg(context))); 01842 if (add_paren) { 01843 Append_Token_Special(tokens, ')'); 01844 } 01845 01846 if (parenthesize) 01847 reset_WN2F_CONTEXT_no_parenthesis(context); 01848 01849 return EMPTY_WN2F_STATUS; 01850 } /* WN2F_const */ 01851 01852 01853 WN2F_STATUS 01854 WN2F_intconst(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01855 { 01856 const BOOL parenthesize = !WN2F_CONTEXT_no_parenthesis(context); 01857 01858 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_INTCONST, 01859 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_intconst")); 01860 01861 if (parenthesize && !WN2F_CONTEXT_is_logical_arg(context)) 01862 { 01863 switch (TCON_ty(Host_To_Targ(WN_opc_rtype(wn), WN_const_val(wn)))) 01864 { 01865 case MTYPE_I1: 01866 case MTYPE_I2: 01867 case MTYPE_I4: 01868 case MTYPE_I8: 01869 if (TCON_ival(Host_To_Targ(WN_opc_rtype(wn), WN_const_val(wn)))<0) { 01870 Append_Token_Special(tokens, '('); 01871 TCON2F_translate(tokens, 01872 Host_To_Targ(WN_opc_rtype(wn), WN_const_val(wn)), 01873 WN2F_CONTEXT_is_logical_arg(context)); 01874 01875 Append_Token_Special(tokens, ')'); 01876 } 01877 else 01878 TCON2F_translate(tokens, 01879 Host_To_Targ(WN_opc_rtype(wn), WN_const_val(wn)), 01880 WN2F_CONTEXT_is_logical_arg(context)); 01881 break; 01882 01883 default: 01884 TCON2F_translate(tokens, 01885 Host_To_Targ(WN_opc_rtype(wn), WN_const_val(wn)), 01886 WN2F_CONTEXT_is_logical_arg(context)); 01887 01888 break; 01889 01890 } /*switch*/ 01891 } 01892 else 01893 01894 TCON2F_translate(tokens, 01895 Host_To_Targ(WN_opc_rtype(wn), WN_const_val(wn)), 01896 WN2F_CONTEXT_is_logical_arg(context)); 01897 if (parenthesize) 01898 reset_WN2F_CONTEXT_no_parenthesis(context); 01899 01900 return EMPTY_WN2F_STATUS; 01901 } /* WN2F_intconst */ 01902 01903 01904 WN2F_STATUS 01905 WN2F_eq(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01906 { 01907 /* Try to reduce "bool .EQ. 0" to simply ".NOT. (bool)", whenever possible. 01908 */ 01909 01910 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_EQ, 01911 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_eq")); 01912 01913 if (WN_opc_operator(WN_kid0(wn)) == OPR_INTCONST && 01914 WN_const_val(WN_kid0(wn)) == 0LL && 01915 (OPCODE_is_boolean(WN_opcode(WN_kid1(wn))) || 01916 TY_is_logical(WN_Tree_Type(WN_kid1(wn))))) 01917 { 01918 Append_Token_String(tokens, ".NOT."); 01919 Append_Token_Special(tokens, '('); 01920 set_WN2F_CONTEXT_no_parenthesis(context); 01921 WN2F_translate(tokens, WN_kid1(wn), context); 01922 Append_Token_Special(tokens, ')'); 01923 } 01924 else if (WN_opc_operator(WN_kid1(wn)) == OPR_INTCONST && 01925 WN_const_val(WN_kid1(wn)) == 0LL && 01926 (OPCODE_is_boolean(WN_opcode(WN_kid0(wn))) || 01927 TY_is_logical(WN_Tree_Type(WN_kid0(wn))))) 01928 { 01929 Append_Token_String(tokens, ".NOT."); 01930 Append_Token_Special(tokens, '('); 01931 set_WN2F_CONTEXT_no_parenthesis(context); 01932 WN2F_translate(tokens, WN_kid0(wn), context); 01933 Append_Token_Special(tokens, ')'); 01934 } 01935 else 01936 { 01937 WN2F_binaryop(tokens, wn, context); 01938 } 01939 01940 return EMPTY_WN2F_STATUS; 01941 } /* WN2F_eq */ 01942 01943 01944 WN2F_STATUS 01945 WN2F_ne(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01946 { 01947 /* Try to reduce "bool .NE. 0" to simply "bool", whenever possible. 01948 */ 01949 01950 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_NE, 01951 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_ne")); 01952 01953 if (WN_opc_operator(WN_kid0(wn)) == OPR_INTCONST && 01954 WN_const_val(WN_kid0(wn)) == 0LL && 01955 (OPCODE_is_boolean(WN_opcode(WN_kid1(wn))) || 01956 TY_is_logical(WN_Tree_Type(WN_kid1(wn))))) 01957 { 01958 WN2F_translate(tokens, WN_kid1(wn), context); 01959 } 01960 else if (WN_opc_operator(WN_kid1(wn)) == OPR_INTCONST && 01961 WN_const_val(WN_kid1(wn)) == 0LL && 01962 (OPCODE_is_boolean(WN_opcode(WN_kid0(wn))) || 01963 TY_is_logical(WN_Tree_Type(WN_kid0(wn))))) 01964 { 01965 WN2F_translate(tokens, WN_kid0(wn), context); 01966 } 01967 else 01968 { 01969 WN2F_binaryop(tokens, wn, context); 01970 } 01971 01972 return EMPTY_WN2F_STATUS; 01973 } /* WN2F_ne */ 01974 01975 01976 01977 WN2F_STATUS 01978 WN2F_parm(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 01979 { 01980 /* TODO: handle opcode parms properly, i.e. take some advantage 01981 * of the information provided in this packaging of argument 01982 * expressions. For now, just skip these nodes. 01983 */ 01984 ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_PARM, 01985 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_parm")); 01986 01987 if ( wn->u3.ty_fields.ty){ //ST_IDX point to key word FMZ August 2005 01988 ST2F_output_keyword(tokens,&St_Table[wn->u3.ty_fields.ty]); 01989 Append_Token_Special(tokens,'='); 01990 } 01991 01992 01993 if (WN_Parm_Copy_In(wn) && 01994 WN_kid0(wn) && 01995 WN_operator(WN_kid0(wn)) !=OPR_PAREN) 01996 Append_Token_Special(tokens,'('); 01997 01998 01999 if ( TY_is_logical(Ty_Table[WN_ty(wn)]) || 02000 WN2F_CONTEXT_is_logical_arg(context)) //fzhao Jan 02001 { 02002 set_WN2F_CONTEXT_has_logical_arg(context); 02003 WN2F_translate(tokens, WN_kid0(wn), context); 02004 reset_WN2F_CONTEXT_has_logical_arg(context); 02005 } 02006 else 02007 WN2F_translate(tokens, WN_kid0(wn), context); 02008 02009 if (WN_Parm_Copy_In(wn) && 02010 WN_kid0(wn) && 02011 WN_operator(WN_kid0(wn)) !=OPR_PAREN) 02012 Append_Token_Special(tokens,')'); 02013 02014 return EMPTY_WN2F_STATUS; 02015 02016 } /* WN2F_parm */ 02017 02018 02019 /*---------------- Memory allocation ops -------------------*/ 02020 02021 WN2F_STATUS 02022 WN2F_alloca(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02023 { 02024 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_ALLOCA, 02025 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_alloca")); 02026 02027 02028 Append_Token_String(tokens,"OPR_ALLOCA"); 02029 Append_Token_Special(tokens,'('); 02030 WN2F_translate(tokens,WN_kid0(wn),context); 02031 Append_Token_Special(tokens,')'); 02032 02033 return EMPTY_WN2F_STATUS; 02034 } /* WN2F_alloca */ 02035 02036 02037 WN2F_STATUS 02038 WN2F_dealloca(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context) 02039 { 02040 INT16 n,i; 02041 02042 ASSERT_DBG_FATAL(WN_operator(wn) == OPR_DEALLOCA, 02043 (DIAG_W2F_UNEXPECTED_OPC, "WN2F_dealloca")); 02044 02045 n = WN_kid_count(wn); 02046 02047 WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_linenum(wn), context); 02048 Append_Token_String(tokens,"CALL OPR_DEALLOCA"); 02049 Append_Token_Special(tokens,'('); 02050 02051 i = 0 ; 02052 while (i < n) 02053 { 02054 WN2F_translate(tokens,WN_kid(wn,i),context); 02055 if (++i < n) 02056 Append_Token_Special(tokens,','); 02057 } 02058 02059 Append_Token_Special(tokens,')'); 02060 return EMPTY_WN2F_STATUS; 02061 } /* WN2F_dealloca */ 02062
1.7.6.1 
