Open64: osprey/be/whirl2f/tcon2f.cxx Source File

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