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 * 27-Apr-95 - Original Version 00042 * 00043 * Description: 00044 * 00045 * See tcon2f.h for a description of the exported functions and 00046 * variables. 00047 * 00048 * ==================================================================== 00049 * ==================================================================== 00050 */ 00051 00052 #include "whirl2f_common.h" 00053 #include "tcon2f.h" 00054 #include "alloca.h" 00055 00056 00057 /*---------------------- Hidden utilities ---------------------*/ 00058 /*-------------------------------------------------------------*/ 00059 00060 static char * 00061 Remove_Trailing_Zero_Fraction(char *strbase) 00062 { 00063 /* Expect the input to be of the form: "d.dddde+dd", where a '-' may 00064 * occur in place of the '+', or the '+' could be omitted. We view the 00065 * 'e' as any letter. 00066 */ 00067 INT last, i; 00068 00069 /* Get to the first digit from the right, which is non-zero. 00070 */ 00071 for (last = 0; strbase[last] != '\0'; last++); 00072 for (i = last-1; strbase[i] == '0'; i--); 00073 00074 /* Remove any unnecesary exponent part and the trailing zeros in the 00075 * fractional part. 00076 */ 00077 if (strbase[i] < '0' || strbase[i] > '9') 00078 { 00079 while (strbase[i] < '0' || strbase[i] > '9') i--; 00080 while (strbase[i] == '0') i--; 00081 if (strbase[i] == '.') 00082 { 00083 strbase[i+1] = '0'; 00084 last = i+2; 00085 } 00086 else 00087 { 00088 last = i+1; 00089 } 00090 } 00091 else 00092 { 00093 INT j, remove_to; 00094 00095 while (strbase[i] >= '0' && strbase[i] <= '9') i--; /* skip exp digits */ 00096 while (strbase[i] < '0' || strbase[i] > '9') i--; /* skip exp letters */ 00097 remove_to = i; 00098 00099 while (strbase[i] == '0') i--; /* skip zero digits in the fraction */ 00100 if (strbase[i] == '.') 00101 i += 1; 00102 00103 /* Move exponent part up till just after the non-zero fractional part 00104 */ 00105 for (j = remove_to+1; j < last; j++) 00106 strbase[++i] = strbase[j]; 00107 last = i+1; 00108 } 00109 strbase[last] = '\0'; 00110 00111 return strbase; 00112 } /* Remove_Trailing_Zero_Fraction */ 00113 00114 00115 static char * 00116 TCON2F_append_string_char(char *str, char ch) 00117 { 00118 BOOL escape; 00119 char escaped_ch; 00120 00121 switch (ch) 00122 { 00123 case '\n': 00124 escaped_ch = 'n'; 00125 escape = TRUE; 00126 break; 00127 case '\t': 00128 escaped_ch = 't'; 00129 escape = TRUE; 00130 break; 00131 case '\b': 00132 escaped_ch = 'b'; 00133 escape = TRUE; 00134 break; 00135 case '\r': 00136 escaped_ch = 'r'; 00137 escape = TRUE; 00138 break; 00139 case '\f': 00140 escaped_ch = 'f'; 00141 escape = TRUE; 00142 break; 00143 case '\v': 00144 escaped_ch = 'v'; 00145 escape = TRUE; 00146 break; 00147 case '\\': 00148 escaped_ch = '\\'; 00149 escape = TRUE; 00150 break; 00151 case '\'': 00152 escaped_ch = '"'; 00153 escape=FALSE; 00154 break; 00155 default: 00156 escaped_ch = ch; 00157 escape = FALSE; 00158 break; 00159 } 00160 if (escape) 00161 *str++ = '\\'; 00162 *str++ = escaped_ch; 00163 00164 return str; 00165 } /* TCON2F_append_string_char */ 00166 00167 00168 void 00169 TCON2F_Append_String_Const(TOKEN_BUFFER tokens, 00170 const char *orig_str, 00171 INT32 strlen) 00172 { 00173 const char *str_base; 00174 char *str; 00175 INT32 stridx; 00176 00177 str_base = str = (char * )alloca(2*strlen + 3); /* "'", orig_str, "'", and "\0" */ 00178 *(str++) = '\''; 00179 for (stridx = 0; stridx < strlen; stridx++) 00180 str = TCON2F_append_string_char(str, orig_str[stridx]); 00181 while (str[-1] == '\0') str--; 00182 *(str++) = '\''; 00183 *(str++) = '\0'; 00184 Append_Token_String(tokens, str_base); 00185 } /* TCON2F_Append_String_Const */ 00186 00187 00188 /*---------------------- Exported functions -------------------*/ 00189 /*-------------------------------------------------------------*/ 00190 00191 void 00192 TCON2F_hollerith(TOKEN_BUFFER tokens, TCON tvalue) 00193 { 00194 /* Translates the given Hollerith constant into Fortran representation. 00195 * A hollerith constant cannot be split into substrings. 00196 */ 00197 const char *strbase; 00198 char *str; 00199 INT32 strlen; 00200 00201 ASSERT_DBG_WARN(TCON_ty(tvalue) == MTYPE_STR, 00202 (DIAG_W2F_UNEXPECTED_BTYPE, 00203 MTYPE_name(TCON_ty(tvalue)), "TCON2F_hollerith")); 00204 00205 strlen = Targ_String_Length(tvalue); 00206 strbase = Targ_String_Address(tvalue); 00207 str = (char *) alloca(strlen + 16); 00208 sprintf(str, "%dH%s", strlen, strbase); 00209 Append_Token_String(tokens, str); 00210 } /* TCON2F_hollerith */ 00211 00212 00213 void 00214 TCON2F_translate(TOKEN_BUFFER tokens, TCON tvalue, BOOL is_logical,TY_IDX object_ty) 00215 { 00216 00217 /* Translates the given TCON to a Fortran representation. Since 00218 * the tcon itself does not tell us, we must rely on the context 00219 * to inform us whether or not a integer constant is a logical 00220 * value or not. 00221 */ 00222 const char *strbase; 00223 char *str; 00224 INT32 max_strlen, strlen, stridx; 00225 INT32 seg_length; 00226 INT32 non_empty_length; 00227 00228 if (is_logical && 00229 MTYPE_type_class(TCON_ty(tvalue)) & MTYPE_CLASS_INTEGER) 00230 { 00231 /* Treat it as regular integral constant, unless it has 00232 * value 0 or 1. 00233 */ 00234 if (Targ_To_Host(tvalue) == 0LL) 00235 Append_Token_String(tokens, ".FALSE."); 00236 else if (Targ_To_Host(tvalue) == 1LL) 00237 Append_Token_String(tokens, ".TRUE."); 00238 else 00239 is_logical = FALSE; 00240 } 00241 else /* Only integral values can be treated as boolean */ 00242 is_logical = FALSE; 00243 00244 00245 if (!is_logical) 00246 { 00247 switch (TCON_ty(tvalue)) 00248 { 00249 case MTYPE_STR: 00250 max_strlen = (Get_Maximum_Linelength()*2)/3; 00251 strlen = Targ_String_Length(tvalue); 00252 strbase = Targ_String_Address(tvalue); 00253 if (object_ty) 00254 seg_length = TY_size(object_ty); 00255 else 00256 seg_length = max_strlen; 00257 00258 str = (char *) alloca(seg_length + 1); 00259 00260 if (object_ty) { 00261 if (max_strlen > 0 && seg_length < strlen) 00262 { 00263 /* We need to split the string constant into substrings */ 00264 // str = (char *) alloca(seg_length + 1); 00265 while (strlen > seg_length) 00266 { 00267 for (stridx = 0; stridx < seg_length; stridx++) 00268 str[stridx] = strbase[stridx]; 00269 str[stridx] = '\0'; 00270 strbase = &strbase[stridx]; 00271 strlen -= seg_length; 00272 non_empty_length=seg_length-1; 00273 while (str[non_empty_length]==' ') 00274 --non_empty_length; 00275 ++non_empty_length; 00276 str[non_empty_length] ='\0'; 00277 TCON2F_Append_String_Const(tokens, str,non_empty_length); 00278 Append_Token_Special(tokens, ','); 00279 } 00280 } 00281 00282 non_empty_length=strlen-1; 00283 while (str[non_empty_length]==' ') 00284 --non_empty_length; 00285 ++non_empty_length; 00286 str[non_empty_length] ='\0'; 00287 TCON2F_Append_String_Const(tokens, strbase,non_empty_length); 00288 00289 } 00290 else { 00291 if (max_strlen > 0 && seg_length < strlen) 00292 { 00293 /* We need to split the string constant into substrings */ 00294 while (strlen > seg_length) 00295 { 00296 for (stridx = 0; stridx < seg_length; stridx++) 00297 str[stridx] = strbase[stridx]; 00298 str[stridx] = '\0'; 00299 strbase = &strbase[stridx]; 00300 strlen -= seg_length; 00301 TCON2F_Append_String_Const(tokens, str, seg_length); 00302 Append_Token_String(tokens, "//"); /* Concatenation */ 00303 } 00304 } 00305 TCON2F_Append_String_Const(tokens, strbase, strlen); 00306 } 00307 break; 00308 00309 case MTYPE_I1: 00310 case MTYPE_I2: 00311 case MTYPE_I4: 00312 00313 Append_Token_String(tokens, Targ_Print("%1d", tvalue)) ; 00314 break; 00315 00316 00317 case MTYPE_I8: 00318 00319 /* here should see if the value is big enough to add "_8" * 00320 * otherwise should not add it, 00321 * will figure out a range later 00322 */ 00323 Append_Token_String(tokens, Targ_Print("%1lld_w2f__i8", tvalue)); 00324 00325 break; 00326 00327 case MTYPE_U1: 00328 case MTYPE_U2: 00329 case MTYPE_U4: 00330 Append_Token_String(tokens, Targ_Print("%1u", tvalue)); 00331 break; 00332 00333 case MTYPE_U8: 00334 /* same thing to do with "MTYPE_I8 */ 00335 Append_Token_String(tokens, Targ_Print("%1llu_w2f__i8", tvalue)); 00336 break; 00337 00338 case MTYPE_F4: 00339 str = Targ_Print("%.10e", tvalue); 00340 strbase = Remove_Trailing_Zero_Fraction(str); 00341 if (str = (char *) strchr(strbase, 'd')) 00342 *str = 'E'; 00343 Append_Token_String(tokens, strbase); 00344 break; 00345 00346 case MTYPE_F8: 00347 str = Targ_Print("%.20e", tvalue); 00348 strbase = Remove_Trailing_Zero_Fraction(str); 00349 if (str = (char *)strchr(strbase, 'E')) /* due to bug in targ_const.h */ 00350 *str = 'D'; 00351 else if (str = (char *)strchr(strbase, 'd')) 00352 *str = 'D'; 00353 else 00354 strbase = Concat2_Strings(strbase, "D00"); 00355 Append_Token_String(tokens, strbase); 00356 00357 break; 00358 00359 case MTYPE_FQ: 00360 str = Targ_Print(NULL, tvalue); 00361 strbase = Remove_Trailing_Zero_Fraction(str); 00362 if (str = (char *)strchr(strbase, 'E')) /* due to bug in targ_const.h */ 00363 *str = 'Q'; 00364 else if (str = (char *)strchr(strbase, 'd')) 00365 *str = 'Q'; 00366 else 00367 strbase = Concat2_Strings(strbase, "Q00"); 00368 Append_Token_String(tokens, strbase); 00369 00370 break; 00371 00372 case MTYPE_C4: 00373 case MTYPE_C8: 00374 case MTYPE_CQ: 00375 Append_Token_Special(tokens, '('); 00376 TCON2F_translate(tokens, Extract_Complex_Real(tvalue), FALSE); 00377 Append_Token_Special(tokens, ','); 00378 TCON2F_translate(tokens, Extract_Complex_Imag(tvalue), FALSE); 00379 Append_Token_Special(tokens, ')'); 00380 break; 00381 00382 default: 00383 /* Only expression nodes should be handled here */ 00384 ASSERT_DBG_WARN(FALSE, (DIAG_W2F_UNEXPECTED_BTYPE, 00385 MTYPE_name(TCON_ty(tvalue)), 00386 "TCON2F_translate")); 00387 Append_Token_String(tokens, "<aTCON>"); 00388 break; 00389 } /* switch */ 00390 } /* if */ 00391 00392 00393 } /* TCON2F_translate */ 00394 00395 void 00396 TCON2F_translate(TOKEN_BUFFER tokens, TCON tvalue, BOOL is_logical) 00397 { 00398 TCON2F_translate(tokens,tvalue,is_logical,0); 00399 }