Open64: osprey/be/whirl2f/wn2f_load

00001 /*
00002  * Copyright 2005, 2006 PathScale, Inc.  All Rights Reserved.
00003  */
00004 
00005 /*
00006 
00007   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00008 
00009   This program is free software; you can redistribute it and/or modify it
00010   under the terms of version 2 of the GNU General Public License as
00011   published by the Free Software Foundation.
00012 
00013   This program is distributed in the hope that it would be useful, but
00014   WITHOUT ANY WARRANTY; without even the implied warranty of
00015   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00016 
00017   Further, this software is distributed without any warranty that it is
00018   free of the rightful claim of any third person regarding infringement 
00019   or the like.  Any license provided herein, whether implied or 
00020   otherwise, applies only to this software file.  Patent licenses, if 
00021   any, provided herein do not apply to combinations of this program with 
00022   other software, or any other product whatsoever.  
00023 
00024   You should have received a copy of the GNU General Public License along
00025   with this program; if not, write the Free Software Foundation, Inc., 59
00026   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00027 
00028   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00029   Mountain View, CA 94043, or:
00030 
00031   http://www.sgi.com
00032 
00033   For further information regarding this notice, see:
00034 
00035   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00036 
00037 */
00038 
00039 
00040 /* ====================================================================
00041  * ====================================================================
00042  *
00043  * Module: wn2f_load_store.c
00044  * $Revision: 1.5 $
00045  * $Date: 05/12/05 08:59:32-08:00 $
00046  * $Author: bos@eng-24.pathscale.com $
00047  * $Source: /scratch/mee/2.4-65/kpro64-pending/be/whirl2f/SCCS/s.wn2f_load_store.cxx $
00048  *
00049  * Revision history:
00050  *  12-Apr-95 - Original Version
00051  *
00052  * Description:
00053  *
00054  *   Translate a WN load/store subtree to Fortran by means of an inorder 
00055  *   recursive descent traversal of the WHIRL IR.  Note that the routines
00056  *   handle statements and expressions are in separate source files.
00057  *   Recursive translation of WN nodes should only use WN2F_Translate()!
00058  *
00059  * ====================================================================
00060  * ====================================================================
00061  */
00062 
00063 #ifdef _KEEP_RCS_ID
00064 /*REFERENCED*/
00065 static char *rcs_id = "$Source: /scratch/mee/2.4-65/kpro64-pending/be/whirl2f/SCCS/s.wn2f_load_store.cxx $ $Revision: 1.5 $";
00066 #endif
00067 
00068 #include "whirl2f_common.h"
00069 #include "PUinfo.h"          /* In be/whirl2c directory */
00070 #include "pf_cg.h"
00071 #include "wn2f.h"
00072 #include "st2f.h"
00073 #include "ty2f.h"
00074 #include "tcon2f.h"
00075 #include "wn2f_load_store.h"
00076 
00077 extern BOOL W2F_Only_Mark_Loads; /* Defined in w2f_driver.c */
00078 static void WN2F_Block(TOKEN_BUFFER tokens, ST * st, STAB_OFFSET off,WN2F_CONTEXT context) ;
00079 
00080 static WN *WN2F_ZeroInt_Ptr = NULL;
00081 static WN *WN2F_OneInt_Ptr = NULL;
00082 
00083 #define WN2F_INTCONST_ZERO\
00084    (WN2F_ZeroInt_Ptr == NULL? WN2F_ZeroInt_Ptr = WN2F_Initiate_ZeroInt() \
00085                             : WN2F_ZeroInt_Ptr)
00086 #define WN2F_INTCONST_ONE\
00087    (WN2F_OneInt_Ptr == NULL? WN2F_OneInt_Ptr = WN2F_Initiate_OneInt() \
00088                             : WN2F_OneInt_Ptr)
00089 
00090 
00091 void WN2F_Array_Slots(TOKEN_BUFFER tokens, WN *wn,WN2F_CONTEXT context,BOOL parens);
00092 
00093 /*------------------------- Utility Functions ------------------------*/
00094 /*--------------------------------------------------------------------*/
00095 
00096 static ST *
00097 WN2F_Get_Named_Param(const WN *pu, const char *param_name)
00098 {
00099    /* Find a parameter with a matching name, if possible, otherwise
00100     * return NULL.
00101     */
00102    ST *param_st = NULL;
00103    INT param, num_formals;
00104 
00105    if (WN_opcode(pu) == OPC_ALTENTRY)
00106       num_formals = WN_kid_count(pu);
00107    else
00108       num_formals = WN_num_formals(pu);
00109 
00110    /* Search through the parameter ST entries
00111     */
00112    for (param = 0; param_st == NULL && param < num_formals; param++)
00113    {
00114       if (ST_name(WN_st(WN_formal(pu, param))) != NULL &&
00115     strcmp(ST_name(WN_st(WN_formal(pu, param))), param_name) == 0)
00116    param_st = WN_st(WN_formal(pu, param));
00117    }
00118    return param_st;
00119 } /* WN2F_Get_Named_Param */
00120 
00121 static void
00122 WN2F_Translate_StringLEN(TOKEN_BUFFER tokens, ST *param_st)
00123 {
00124    INT dim;
00125    TY_IDX param_ty = (TY_Is_Pointer(ST_type(param_st))? 
00126                    TY_pointed(ST_type(param_st)) : ST_type(param_st));
00127 
00128    Append_Token_String(tokens, "LEN");
00129    Append_Token_Special(tokens, '(');
00130    Append_Token_String(tokens, W2CF_Symtab_Nameof_St(param_st));
00131 
00132    if (TY_Is_Array(param_ty) && !TY_Is_Character_String(param_ty))
00133    {
00134       /* Append index values (any arbitrary value will do for each dimension)
00135        */
00136       Append_Token_Special(tokens, '(');
00137 
00138 
00139       ARB_HANDLE arb_base = TY_arb(param_ty);
00140       dim = ARB_dimension(arb_base) - 1; 
00141 
00142       while ( dim >= 0)
00143       {
00144   ARB_HANDLE arb = arb_base[dim];
00145 
00146          Append_Token_String(tokens, "1");
00147    if (dim-- > 0)
00148             Append_Token_Special(tokens, ',');
00149       }
00150       Append_Token_Special(tokens, ')');
00151    }
00152    else
00153    {
00154       ASSERT_WARN(TY_Is_Character_String(param_ty), 
00155                   (DIAG_W2F_EXPECTED_PTR_TO_CHARACTER,
00156         "WN2F_Translate_StringLEN"));
00157    }
00158    Append_Token_Special(tokens, ')');
00159 } /* WN2F_Translate_StringLEN */
00160 
00161 static WN *
00162 WN2F_Initiate_ZeroInt(void)
00163 {
00164    static char ZeroInt [sizeof (WN)];
00165    WN       *wn = (WN*) &ZeroInt;
00166    OPCODE    opcode = OPCODE_make_op(OPR_INTCONST, MTYPE_I4, MTYPE_V);
00167 
00168    bzero(wn, sizeof(WN));
00169    WN_set_opcode(wn, opcode);
00170    WN_set_kid_count(wn, 0);
00171    WN_set_map_id(wn, WN_MAP_UNDEFINED);
00172    WN_const_val(wn) = 0LL;
00173    return wn;
00174 } /* WN2F_Initiate_ZeroInt */
00175 
00176 static WN *
00177 WN2F_Initiate_OneInt(void)
00178 {
00179    static char OneInt [sizeof (WN)];
00180    WN       *wn = (WN*) &OneInt;
00181    OPCODE    opcode = OPCODE_make_op(OPR_INTCONST, MTYPE_I4, MTYPE_V);
00182 
00183    bzero(wn, sizeof(WN));
00184    WN_set_opcode(wn, opcode);
00185    WN_set_kid_count(wn, 0);
00186    WN_set_map_id(wn, WN_MAP_UNDEFINED);
00187    WN_const_val(wn) = 1LL;
00188    return wn;
00189 } /* WN2F_Initiate_ZeroInt */
00190 
00191 
00192 static BOOL
00193 WN2F_Expr_Plus_Literal(TOKEN_BUFFER tokens,
00194            WN          *wn,
00195            INT64        literal,
00196            WN2F_CONTEXT context)
00197 {
00198    /* Returns TRUE if the resultant value is constant and different
00199     * from zero.
00200     */
00201    const BOOL parenthesize = !WN2F_CONTEXT_no_parenthesis(context);
00202    BOOL       is_const = TRUE;
00203    INT64      value;
00204    
00205    if (WN_opc_operator(wn) == OPR_INTCONST)
00206       value = WN_const_val(wn) + literal;
00207    else if (WN_opc_operator(wn) == OPR_CONST)
00208       value = Targ_To_Host(STC_val(WN_st(wn))) + literal;
00209    else
00210       is_const = FALSE;
00211    
00212    if (is_const)
00213    {
00214       TCON2F_translate(tokens,
00215            Host_To_Targ(WN_opc_rtype(wn), value),
00216            FALSE /*is_logical*/);
00217    }
00218    else
00219    {
00220       if (parenthesize)
00221       {
00222    reset_WN2F_CONTEXT_no_parenthesis(context);
00223    Append_Token_Special(tokens, '(');
00224       }
00225       WN2F_translate(tokens, wn, context);
00226       Append_Token_Special(tokens, '+');
00227       TCON2F_translate(tokens,
00228            Host_To_Targ(MTYPE_I4, 1),
00229            FALSE /*is_logical*/);
00230       if (parenthesize)
00231    Append_Token_Special(tokens, ')');
00232    }
00233 
00234    return is_const && (value != 0LL);
00235 } /* WN2F_Expr_Plus_Literal */
00236 
00237 
00238 static WN2F_STATUS
00239 WN2F_Denormalize_Array_Idx(TOKEN_BUFFER tokens, 
00240          WN          *idx_expr, 
00241          WN2F_CONTEXT context)
00242 {
00243    const BOOL   parenthesize = !WN2F_CONTEXT_no_parenthesis(context);
00244    TOKEN_BUFFER tmp_tokens;
00245    BOOL         non_zero, cexpr_is_lhs;
00246    WN          *nexpr, *cexpr;
00247    INT64        plus_value;
00248    
00249    /* Given an index expression, translate it to Fortran and append
00250     * the tokens to the given token-buffer.  If the value of the idx
00251     * expression is "v", then the appended tokens should represent
00252     * the value "v+1".  This denormalization moves the base of the
00253     * array from index zero to index one.
00254     */
00255    if (WN_opc_operator(idx_expr) == OPR_ADD && 
00256        (WN_is_constant_expr(WN_kid1(idx_expr)) || 
00257   WN_is_constant_expr(WN_kid0(idx_expr))))
00258    {
00259       /* Do the "e+c" ==> "e+(c+1)" translation, using the property
00260        * that addition is commutative.
00261        */
00262       if (WN_is_constant_expr(WN_kid1(idx_expr)))
00263       {
00264    cexpr = WN_kid1(idx_expr);
00265    nexpr = WN_kid0(idx_expr);
00266       }
00267       else /* if (WN_is_constant_expr(WN_kid0(idx_expr))) */
00268       {
00269    cexpr = WN_kid0(idx_expr);
00270    nexpr = WN_kid1(idx_expr);
00271       }
00272       tmp_tokens = New_Token_Buffer();
00273       non_zero = WN2F_Expr_Plus_Literal(tmp_tokens, cexpr, 1LL, context);
00274       if (non_zero)
00275       {
00276    if (parenthesize)
00277    {
00278       reset_WN2F_CONTEXT_no_parenthesis(context);
00279       Append_Token_Special(tokens, '(');
00280    }
00281    WN2F_translate(tokens, nexpr, context);
00282    Append_Token_Special(tokens, '+');
00283    Append_And_Reclaim_Token_List(tokens, &tmp_tokens);
00284    if (parenthesize)
00285       Append_Token_Special(tokens, ')');
00286       }
00287       else
00288       {
00289    Reclaim_Token_Buffer(&tmp_tokens);
00290    WN2F_translate(tokens, nexpr, context);
00291       }
00292    }
00293    else if (WN_opc_operator(idx_expr) == OPR_SUB && 
00294       (WN_is_constant_expr(WN_kid1(idx_expr)) || 
00295        WN_is_constant_expr(WN_kid0(idx_expr))))
00296    {
00297       /* Do the "e-c" ==> "e-(c-1)" or the  "c-e" ==> "(c+1)-e"
00298        * translation.
00299        */
00300       cexpr_is_lhs = WN_is_constant_expr(WN_kid0(idx_expr));
00301       if (!cexpr_is_lhs)
00302       {
00303    cexpr = WN_kid1(idx_expr);
00304    nexpr = WN_kid0(idx_expr);
00305    plus_value = -1LL;
00306       }
00307       else
00308       {
00309    cexpr = WN_kid0(idx_expr);
00310    nexpr = WN_kid1(idx_expr);
00311    plus_value = 1LL;
00312       }
00313   
00314       /* Do the "e-c" ==> "e-(c-1)" or the  "c-e" ==> "(c+1)-e"
00315        * translation.
00316        */
00317       tmp_tokens = New_Token_Buffer();
00318       non_zero = 
00319    WN2F_Expr_Plus_Literal(tmp_tokens, cexpr, plus_value, context);
00320       if (non_zero)
00321       {
00322    if (parenthesize)
00323    {
00324       reset_WN2F_CONTEXT_no_parenthesis(context);
00325       Append_Token_Special(tokens, '(');
00326    }
00327    if (!cexpr_is_lhs)
00328    {
00329       WN2F_translate(tokens, nexpr, context);
00330       Append_Token_Special(tokens, '-');
00331       Append_And_Reclaim_Token_List(tokens, &tmp_tokens);
00332    }
00333    else
00334    {
00335       Append_And_Reclaim_Token_List(tokens, &tmp_tokens);
00336       Append_Token_Special(tokens, '-');
00337       WN2F_translate(tokens, nexpr, context);
00338    }
00339    if (parenthesize)
00340       Append_Token_Special(tokens, ')');
00341       }
00342       else
00343       {
00344    Reclaim_Token_Buffer(&tmp_tokens); 
00345    if (cexpr_is_lhs)
00346    {
00347       if (parenthesize)
00348       {
00349          reset_WN2F_CONTEXT_no_parenthesis(context);
00350          Append_Token_Special(tokens, '(');
00351       }
00352       Append_Token_Special(tokens, '-');
00353       WN2F_translate(tokens, nexpr, context);
00354       if (parenthesize)
00355          Append_Token_Special(tokens, ')');
00356    }
00357    else
00358    {
00359       WN2F_translate(tokens, nexpr, context);
00360    }
00361       }
00362    }
00363    else
00364    {
00365       WN2F_Expr_Plus_Literal(tokens, idx_expr, 1LL, context);
00366    }
00367    return EMPTY_WN2F_STATUS;
00368 } /* WN2F_Denormalize_Array_Idx */
00369 
00370 
00371 static void
00372 WN2F_Normalize_Idx_To_Onedim(TOKEN_BUFFER tokens, 
00373            WN*          wn,
00374            WN2F_CONTEXT context)
00375 {
00376    INT32 dim1, dim2;
00377 
00378    /* Parenthesize the normalized index expressions */
00379    reset_WN2F_CONTEXT_no_parenthesis(context);
00380 
00381    for (dim1 = 0; dim1 < WN_num_dim(wn); dim1++)
00382    {
00383       if (dim1 > 0)
00384    Append_Token_Special(tokens, '+');
00385 
00386       /* Multiply the index expression with the product of the sizes
00387        * of subordinate dimensions, where a higher dimension-number
00388        * means a more subordinate dimension.  Do not parenthesize the
00389        * least significant index expression.
00390        */   
00391       if (dim1+1 == WN_num_dim(wn))
00392    set_WN2F_CONTEXT_no_parenthesis(context);
00393       WN2F_Denormalize_Array_Idx(tokens, WN_array_index(wn, dim1), context);
00394       for (dim2 = dim1+1; dim2 < WN_num_dim(wn); dim2++)
00395       {
00396    Append_Token_Special(tokens, '*');
00397    (void)WN2F_translate(tokens, WN_array_dim(wn, dim2), context);
00398       } /*for*/
00399    } /*for*/
00400 } /* WN2F_Normalize_Idx_To_Onedim */
00401 
00402 
00403 static void
00404 WN2F_Substring(TOKEN_BUFFER tokens, 
00405          INT64        string_size,
00406          WN          *lower_bnd,
00407          WN          *substring_size,
00408          WN2F_CONTEXT context)
00409 {
00410    /* Given a substring offset from the base of a character string 
00411     * (lower_bnd), the size of the whole string, and the size of the
00412     * substring, generate the notation necessary as a suffix to the
00413     * string reference to denote the substring.
00414     */
00415    if (WN_opc_operator(lower_bnd) != OPR_INTCONST      ||
00416        WN_const_val(lower_bnd) != 0                    ||
00417        WN_opc_operator(substring_size) != OPR_INTCONST ||
00418        WN_const_val(substring_size) != string_size)
00419    {
00420       /* Need to generate substring expression "(l+1:l+size)" */
00421       Append_Token_Special(tokens, '(');
00422       set_WN2F_CONTEXT_no_parenthesis(context);
00423       WN2F_Denormalize_Array_Idx(tokens, lower_bnd, context);
00424       reset_WN2F_CONTEXT_no_parenthesis(context);
00425       Append_Token_Special(tokens, ':');
00426       if (WN_opc_operator(lower_bnd) != OPR_INTCONST ||
00427     WN_const_val(lower_bnd) != 0)
00428       {
00429    WN2F_translate(tokens, lower_bnd, context);
00430    Append_Token_Special(tokens, '+');
00431       }
00432       WN2F_translate(tokens, substring_size, context);
00433       Append_Token_Special(tokens, ')');
00434    }
00435 } /* WN2F_Substring */
00436 
00437 
00438 static void
00439 WN2F_Get_Substring_Info(WN **base,         /* Possibly OPR_ARRAY node (in/out) */
00440       TY_IDX *string_ty, /* The string type (out) */
00441       WN **lower_bnd)    /* The lower bound index (out) */
00442 {
00443    /* There are two possibilities concerning the array base expressions.
00444     * It can be a pointer to a complete character-string (array) or it
00445     * can be a pointer to a character within a character-string (single
00446     * character).  In the first instance, the offset off the base of 
00447     * string is zero.  In the latter case, the offset is given by the
00448     * array indexing operation.
00449     */
00450    TY_IDX ptr_ty = WN_Tree_Type(*base);
00451 
00452    *string_ty = TY_pointed(ptr_ty);
00453 
00454    if (TY_size(*string_ty) == 1 && 
00455        !TY_Is_Array(*string_ty) &&
00456        WN_opc_operator(*base) == OPR_ARRAY)
00457    {
00458       /* Let the base of the string be denoted as the base of the array
00459        * expression.
00460        */
00461       *string_ty = TY_pointed(WN_Tree_Type(WN_kid0(*base)));
00462       *lower_bnd = WN_array_index(*base, 0);
00463       *base = WN_kid0(*base);
00464    }
00465    else if (WN_opc_operator(*base) == OPR_ARRAY &&
00466       TY_Is_Array(*string_ty)             &&
00467       TY_AR_ndims(*string_ty) == 1        &&
00468       TY_Is_Character_String(*string_ty)  &&
00469       !TY_ptr_as_array(Ty_Table[ptr_ty]))
00470    {
00471       /* Presumably, the lower bound is given by the array operator
00472        */
00473       *lower_bnd = WN_array_index(*base, 0);
00474       *base = WN_kid0(*base);
00475    }
00476    else
00477    {
00478       *lower_bnd = WN2F_INTCONST_ZERO;
00479    }
00480 } /* WN2F_Get_Substring_Info */
00481 
00482 static WN *
00483 WN2F_Find_Base(WN *addr)
00484 {
00485   /* utility to find base of address tree */
00486 
00487   WN *res = addr;
00488 
00489   switch (WN_operator(addr))
00490   {
00491     case OPR_ARRAY: 
00492     case OPR_ILOAD:
00493     res = WN2F_Find_Base(WN_kid0(addr));
00494     break;
00495 
00496     case OPR_ADD:
00497       if (WN_operator(WN_kid0(addr)) == OPR_INTCONST)
00498   res = WN2F_Find_Base(WN_kid1(addr));
00499       else
00500   res = WN2F_Find_Base(WN_kid0(addr));
00501     break;
00502 
00503   default:
00504     res = addr;
00505     break;
00506   }
00507   return res;
00508 }
00509 
00510 extern BOOL
00511 WN2F_Is_Address_Preg(WN * ad ,TY_IDX ptr_ty)
00512 {
00513   /* Does this look like a preg or variable being used as an address ? */
00514   /* These are propagated by opt/pfa                                   */
00515 
00516   BOOL is_somewhat_address_like = TY_kind(ptr_ty) == KIND_POINTER;
00517   
00518   if (TY_kind(ptr_ty) == KIND_SCALAR) 
00519   {
00520     TYPE_ID tid = TY_mtype(ptr_ty);
00521 
00522     is_somewhat_address_like |= (MTYPE_is_pointer(tid)) || (tid == MTYPE_I8) || (tid == MTYPE_I4) ;
00523   }
00524 
00525   if (is_somewhat_address_like)
00526   {
00527     WN * wn = WN2F_Find_Base(ad);
00528     
00529     if (WN_operator(wn) == OPR_LDID) 
00530     {
00531       ST * st = WN_st(wn) ;
00532       if (ST_class(st) == CLASS_PREG)
00533   return TRUE ;
00534       
00535       if (ST_class(st) == CLASS_VAR) 
00536       {
00537   if (TY_kind(ptr_ty) == KIND_SCALAR)
00538     return TRUE;
00539   
00540   if (TY_kind(WN_ty(wn)) == KIND_SCALAR)
00541   {
00542     TYPE_ID wtid = TY_mtype(WN_ty(wn));
00543     
00544     /* Looks like a Cray pointer (I4/I8) ? */
00545     
00546     if ((wtid == MTYPE_I8)|| (wtid == MTYPE_I4))
00547       if (ad != wn)
00548         return TRUE ;
00549     
00550     /* Looks like a VAR with a U4/U8? used  */
00551     /* only with offsets, or FORMALs would  */
00552     /* qualify, if intrinsic mtype          */
00553     
00554     if (MTYPE_is_pointer(wtid))
00555       if (TY_kind(ST_type(st)) != KIND_SCALAR)
00556         return TRUE;
00557   }
00558       }
00559     }
00560   }
00561   return FALSE;
00562 }
00563 
00564 /*---------------------- Prefetching Comments ------------------------*/
00565 /*--------------------------------------------------------------------*/
00566 
00567 static void
00568 WN2F_Append_Prefetch_Map(TOKEN_BUFFER tokens, WN *wn)
00569 {
00570    PF_POINTER* pfptr;
00571    const char *info_str;
00572    
00573    pfptr = (PF_POINTER*)WN_MAP_Get(WN_MAP_PREFETCH, wn);
00574    info_str = "prefetch (ptr, lrnum): ";
00575    if (pfptr->wn_pref_1L)
00576    {
00577       info_str = 
00578    Concat2_Strings(    info_str,
00579           Concat2_Strings(   "1st <", 
00580            Concat2_Strings(  Ptr_as_String(pfptr->wn_pref_1L),
00581             Concat2_Strings( ", ",
00582              Concat2_Strings(WHIRL2F_number_as_name(pfptr->lrnum_1L),
00583            ">")))));
00584    }
00585    if (pfptr->wn_pref_2L)
00586    {
00587       info_str = 
00588    Concat2_Strings(    info_str,
00589           Concat2_Strings(   "2nd <", 
00590            Concat2_Strings(  Ptr_as_String(pfptr->wn_pref_2L),
00591             Concat2_Strings( ", ",
00592              Concat2_Strings(WHIRL2F_number_as_name(pfptr->lrnum_2L),
00593            ">")))));
00594    }
00595    Append_Token_String(tokens, info_str);
00596 } /* WN2F_Append_Prefetch_Map */
00597 
00598 
00599 /*----------------------- Exported Functions ------------------------*/
00600 /*--------------------------------------------------------------------*/
00601 
00602 void WN2F_Load_Store_initialize(void)
00603 {
00604    /* Nothing to do at the moment */
00605 } /* WN2F_Load_Store_initialize */
00606 
00607 
00608 void WN2F_Load_Store_finalize(void)
00609 {
00610    /* Nothing to do at the moment */
00611 } /* WN2F_Load_Store_finalize */
00612 
00613 
00614 extern WN2F_STATUS 
00615 WN2F_istore(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00616 {
00617    TOKEN_BUFFER  lhs_tokens;
00618    TOKEN_BUFFER  rhs_tokens;
00619    TY_IDX        base_ty;
00620    
00621    ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_ISTORE, 
00622         (DIAG_W2F_UNEXPECTED_OPC, "WN2F_istore"));
00623 
00624    /* Get the base address into which we are storing a value */
00625    base_ty = WN_Tree_Type(WN_kid1(wn));
00626    if (!TY_Is_Pointer(base_ty))
00627       base_ty = WN_ty(wn);
00628 
00629    /* Get the lhs of the assignment (dereference address) */
00630    lhs_tokens = New_Token_Buffer();
00631    WN2F_Offset_Memref(lhs_tokens, 
00632           WN_kid1(wn),           /* base-symbol */
00633           base_ty,               /* base-type */
00634           TY_pointed(WN_ty(wn)), /* object-type */
00635           WN_store_offset(wn),   /* object-ofst */
00636           context);
00637    
00638    /* The rhs */
00639    rhs_tokens = New_Token_Buffer();
00640    if (TY_is_logical(Ty_Table[TY_pointed(WN_ty(wn))]))
00641    {
00642       set_WN2F_CONTEXT_has_logical_arg(context);
00643       WN2F_translate(rhs_tokens, WN_kid0(wn), context);
00644       reset_WN2F_CONTEXT_has_logical_arg(context);
00645    }
00646    else
00647       WN2F_translate(rhs_tokens, WN_kid0(wn), context);
00648 
00649    /* See if we need to apply a "char" conversion to the rhs
00650     */
00651    if (TY_Is_Character_String(W2F_TY_pointed(WN_ty(wn), "ISTORE lhs")) &&
00652        TY_Is_Integral(WN_Tree_Type(WN_kid0(wn))))
00653    {
00654       Prepend_Token_Special(rhs_tokens, '(');
00655       Prepend_Token_String(rhs_tokens, "char");
00656       Append_Token_Special(rhs_tokens, ')');
00657    }
00658 
00659    /* Assign the rhs to the lhs.
00660     */
00661    if (Identical_Token_Lists(lhs_tokens, rhs_tokens))
00662    {
00663       /* Ignore this redundant assignment statement! */
00664       Reclaim_Token_Buffer(&lhs_tokens);
00665       Reclaim_Token_Buffer(&rhs_tokens);
00666    }
00667    else
00668    {
00669       /* See if there is any prefetch information with this store,
00670        * and if so insert information about it as a comment preceeding
00671        * the store.
00672        */
00673       if (W2F_Emit_Prefetch && WN_MAP_Get(WN_MAP_PREFETCH, wn))
00674       {
00675    Append_F77_Comment_Newline(tokens, 1, TRUE/*indent*/);
00676    WN2F_Append_Prefetch_Map(tokens, wn);
00677       }
00678 
00679       /* The assignment statement on a new line */
00680       WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_linenum(wn), context);
00681       Append_And_Reclaim_Token_List(tokens, &lhs_tokens);
00682       Append_Token_Special(tokens, '=');
00683       Append_And_Reclaim_Token_List(tokens, &rhs_tokens);
00684    }
00685 
00686    return EMPTY_WN2F_STATUS;
00687 } /* WN2F_istore */
00688 
00689 WN2F_STATUS 
00690 WN2F_istorex(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00691 {
00692    ASSERT_DBG_WARN(FALSE, (DIAG_UNIMPLEMENTED, "WN2F_istorex"));
00693    WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_linenum(wn), context);
00694    Append_Token_String(tokens, WN_opc_name(wn));
00695 
00696    return EMPTY_WN2F_STATUS;
00697 } /* WN2F_istorex */
00698 
00699 WN2F_STATUS 
00700 WN2F_mstore(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00701 {
00702    TOKEN_BUFFER  lhs_tokens;
00703    TOKEN_BUFFER  rhs_tokens;
00704    TY_IDX        base_ty;
00705 
00706    /* Note that we make the assumption that this is just like an 
00707     * ISTORE, and handle it as though it were.  We do not handle
00708     * specially assignment-forms where the lhs is incompatible with
00709     * the rhs, since we assume this will never happen for Fortran
00710     * and we cannot easily get around this like we do in C (i.e.
00711     * with cast expressions.
00712     */
00713    ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_MSTORE, 
00714         (DIAG_W2F_UNEXPECTED_OPC, "WN2F_mstore"));
00715 #if 0
00716    ASSERT_DBG_WARN(WN_opc_operator(WN_kid0(wn)) == OPR_MLOAD,
00717         (DIAG_W2F_UNEXPECTED_OPC, "rhs of WN2F_mstore"));
00718 
00719    //TODO: scalar expression allowed, but array/structure assignment assumed
00720    // with constant ie: should put out doloop?... call OFFSET_Memref?
00721 #endif
00722 
00723    /* Get the base address into which we are storing a value */
00724    base_ty = WN_Tree_Type(WN_kid1(wn));
00725    if (!TY_Is_Pointer(base_ty))
00726       base_ty = WN_ty(wn);
00727 
00728    /* Get the lhs of the assignment (dereference address) */
00729    lhs_tokens = New_Token_Buffer();
00730    WN2F_Offset_Memref(lhs_tokens, 
00731           WN_kid1(wn),           /* base-symbol */
00732           base_ty,               /* base-type */
00733           TY_pointed(WN_ty(wn)), /* object-type */
00734           WN_store_offset(wn),   /* object-ofst */
00735           context);
00736    
00737    /* The rhs */
00738    rhs_tokens = New_Token_Buffer();
00739    WN2F_translate(rhs_tokens, WN_kid0(wn), context);
00740 
00741    /* Assign the rhs to the lhs.
00742     */
00743    if (Identical_Token_Lists(lhs_tokens, rhs_tokens))
00744    {
00745       /* Ignore this redundant assignment statement! */
00746       Reclaim_Token_Buffer(&lhs_tokens);
00747       Reclaim_Token_Buffer(&rhs_tokens);
00748    }
00749    else
00750    {
00751       /* The assignment statement on a new line */
00752       WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_linenum(wn), context);
00753       Append_And_Reclaim_Token_List(tokens, &lhs_tokens);
00754       Append_Token_Special(tokens, '=');
00755       Append_And_Reclaim_Token_List(tokens, &rhs_tokens);
00756    }
00757 
00758 
00759    return EMPTY_WN2F_STATUS;
00760 } /* WN2F_mstore */
00761 
00762 WN2F_STATUS 
00763 WN2F_stid(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00764 {
00765    TOKEN_BUFFER lhs_tokens, rhs_tokens;
00766    
00767    ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_STID, 
00768         (DIAG_W2F_UNEXPECTED_OPC, "WN2F_stid"));
00769 
00770    /* Get the lhs of the assignment */
00771    lhs_tokens = New_Token_Buffer();
00772    if (ST_class(WN_st(wn)) == CLASS_PREG)
00773    {
00774       ST2F_Use_Preg(lhs_tokens, ST_type(WN_st(wn)), WN_store_offset(wn));
00775    }
00776    else if (ST_sym_class(WN_st(wn))==CLASS_VAR && ST_is_not_used(WN_st(wn)))
00777    {
00778       /* This is a redundant assignment statement, so determined
00779        * by IPA, so just assign it to a temporary variable
00780        * instead.
00781        */
00782       UINT tmp_idx = Stab_Lock_Tmpvar(WN_ty(wn), &ST2F_Declare_Tempvar);
00783       Append_Token_String(lhs_tokens, W2CF_Symtab_Nameof_Tempvar(tmp_idx));
00784       Stab_Unlock_Tmpvar(tmp_idx);
00785    }
00786    else
00787    {
00788       WN2F_Offset_Symref(lhs_tokens, 
00789        WN_st(wn),                        /* base-symbol */
00790        Stab_Pointer_To(ST_type(WN_st(wn))),/* base-type */
00791        WN_ty(wn),                        /* object-type */
00792        WN_store_offset(wn),              /* object-ofst */
00793        context);
00794    }
00795    
00796    /* The rhs */
00797    rhs_tokens = New_Token_Buffer();
00798    if (TY_is_logical(Ty_Table[WN_ty(wn)]))
00799    {
00800       set_WN2F_CONTEXT_has_logical_arg(context);
00801       WN2F_translate(rhs_tokens, WN_kid0(wn), context);
00802       reset_WN2F_CONTEXT_has_logical_arg(context);
00803    }
00804    else
00805       WN2F_translate(rhs_tokens, WN_kid0(wn), context);
00806 
00807    /* See if we need to apply a "char" conversion to the rhs
00808     */
00809    if (TY_Is_Character_String(WN_ty(wn)) && 
00810        TY_Is_Integral(WN_Tree_Type(WN_kid0(wn))))
00811    {
00812       Prepend_Token_Special(rhs_tokens, '(');
00813       Prepend_Token_String(rhs_tokens, "char");
00814       Append_Token_Special(rhs_tokens, ')');
00815    }
00816 
00817    /* Assign the rhs to the lhs.
00818     */
00819    if (!WN2F_CONTEXT_emit_stid(context) &&
00820        Identical_Token_Lists(lhs_tokens, rhs_tokens))
00821    {
00822       /* Ignore this redundant assignment statement! */
00823       Reclaim_Token_Buffer(&lhs_tokens);
00824       Reclaim_Token_Buffer(&rhs_tokens);
00825    }
00826    else
00827    {
00828       /* The assignment statement on a new line */
00829       WN2F_Stmt_Newline(tokens, NULL/*label*/, WN_linenum(wn), context);
00830       Append_And_Reclaim_Token_List(tokens, &lhs_tokens);
00831       Append_Token_Special(tokens, '=');
00832       Append_And_Reclaim_Token_List(tokens, &rhs_tokens);
00833    }
00834 
00835    return EMPTY_WN2F_STATUS;
00836 } /* WN2F_stid */
00837 
00838 WN2F_STATUS 
00839 WN2F_iload(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00840 {
00841    TY_IDX base_ty;
00842    
00843    /* Note that we handle this just like we do the lhs of an ISTORE.
00844     */
00845    ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_ILOAD, 
00846         (DIAG_W2F_UNEXPECTED_OPC, "WN2F_iload"));
00847 
00848    /* Special case for Purple (address values have no meaning, so emit
00849     * symbolic values for them).
00850     */
00851    if (W2F_Only_Mark_Loads && !TY_Is_Pointer(WN_ty(wn)))
00852    {
00853       char buf[64];
00854       sprintf(buf, "#<%p>#", wn);
00855       Append_Token_String(tokens, buf);
00856       return EMPTY_WN2F_STATUS;
00857    }
00858 
00859    /* Get the type of the base from which we are loading */
00860    base_ty = WN_Tree_Type(WN_kid0(wn));
00861    if (!TY_Is_Pointer(base_ty))
00862       base_ty = WN_load_addr_ty(wn);
00863 
00864    /* Get the object to be loaded (dereference address) */
00865    WN2F_Offset_Memref(tokens, 
00866           WN_kid0(wn),                     /* base-symbol */
00867           base_ty,                         /* base-type */
00868           TY_pointed(WN_load_addr_ty(wn)), /* object-type */
00869           WN_load_offset(wn),              /* object-ofst */
00870           context);
00871 
00872    /* See if there is any prefetch information with this load, and 
00873     * if so insert information about it as a comment on a separate
00874     * continuation line.
00875     */
00876    if (W2F_Emit_Prefetch && WN_MAP_Get(WN_MAP_PREFETCH, wn))
00877    {
00878       Set_Current_Indentation(Current_Indentation()+3);
00879       Append_F77_Indented_Continuation(tokens);
00880       Append_Token_Special(tokens, '!');
00881       WN2F_Append_Prefetch_Map(tokens, wn);
00882       Set_Current_Indentation(Current_Indentation()-3); 
00883       Append_F77_Indented_Continuation(tokens);
00884    }
00885    
00886    return EMPTY_WN2F_STATUS;
00887 } /* WN2F_iload */
00888 
00889 WN2F_STATUS 
00890 WN2F_iloadx(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00891 {
00892    ASSERT_DBG_WARN(FALSE, (DIAG_UNIMPLEMENTED, "WN2F_iloadx"));
00893    Append_Token_String(tokens, WN_opc_name(wn));
00894 
00895    return EMPTY_WN2F_STATUS;
00896 } /* WN2F_iloadx */
00897 
00898 
00899 WN2F_STATUS 
00900 WN2F_mload(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00901 {
00902    TY_IDX base_ty;
00903    
00904    /* This should only appear the as the rhs of an ISTORE.  Treat
00905     * it just like an ILOAD.
00906     */
00907    ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_MLOAD, 
00908         (DIAG_W2F_UNEXPECTED_OPC, "WN2F_mload"));
00909 
00910    /* Special case for Purple (cannot be a pointer value) */
00911    if (W2F_Only_Mark_Loads)
00912    {
00913       char buf[64];
00914       sprintf(buf, "#<%p>#", wn);
00915       Append_Token_String(tokens, buf);
00916       return EMPTY_WN2F_STATUS;
00917    }
00918 
00919    /* Get the type of the base from which we are loading */
00920    base_ty = WN_Tree_Type(WN_kid0(wn));
00921    if (!TY_Is_Pointer(base_ty))
00922       base_ty = WN_ty(wn);
00923 
00924    /* Get the object to be loaded */
00925    WN2F_Offset_Memref(tokens, 
00926           WN_kid0(wn),                     /* base-symbol */
00927           base_ty,                         /* base-type */
00928           TY_pointed(WN_ty(wn)), /* object-type */
00929           WN_load_offset(wn),              /* object-ofst */
00930           context);
00931    return EMPTY_WN2F_STATUS;
00932 } /* WN2F_mload */
00933 
00934 
00935 WN2F_STATUS 
00936 WN2F_ldid(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
00937 {
00938    const BOOL deref = WN2F_CONTEXT_deref_addr(context);
00939    TY_IDX    base_ptr_ty;
00940    TY_IDX    object_ty;
00941    
00942    ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_LDID, 
00943         (DIAG_W2F_UNEXPECTED_OPC, "WN2F_ldid"));
00944 
00945    /* Special recognition of a LEN intrinsic call
00946     */
00947    if (WN_load_offset(wn) == 0             &&
00948        TY_Is_Integral(WN_ty(wn))           &&
00949        ST_sclass(WN_st(wn))==SCLASS_FORMAL &&
00950        ST_is_value_parm(WN_st(wn))         &&
00951        strncmp(ST_name(WN_st(wn)), ".length.", strlen(".length.")) == 0)
00952    {
00953       /* Search the current PU parameters for a name that matches the
00954        * part of the ST_name that follows the ".length." prefix.
00955        */
00956       ST *st_param = 
00957    WN2F_Get_Named_Param(PUinfo_current_func,
00958             ST_name(WN_st(wn)) + strlen(".length."));
00959 
00960       if (st_param != NULL)
00961       {
00962    WN2F_Translate_StringLEN(tokens, st_param);
00963    return EMPTY_WN2F_STATUS;
00964       }
00965    }
00966 
00967    /* Special case for Purple direct loads, except direct loads of
00968     * addresses (address values have no meaning in the purple output).
00969     */
00970    if (W2F_Only_Mark_Loads && !TY_Is_Pointer(WN_ty(wn)))
00971    {
00972       char buf[64];
00973       sprintf(buf, "#<%p>#", wn);
00974       Append_Token_String(tokens, buf);
00975       return EMPTY_WN2F_STATUS;
00976    }
00977 
00978    if (ST_class(WN_st(wn)) == CLASS_PREG)
00979    {
00980       char buffer[64];
00981       STAB_OFFSET addr_offset = WN_load_offset(wn);
00982       object_ty = PUinfo_Preg_Type(ST_type(WN_st(wn)), addr_offset);
00983       if (addr_offset == -1) {
00984          switch (TY_mtype(Ty_Table[WN_ty(wn)])) {
00985          case MTYPE_I8:
00986          case MTYPE_U8:
00987          case MTYPE_I1:
00988          case MTYPE_I2:
00989          case MTYPE_I4:
00990          case MTYPE_U1:
00991          case MTYPE_U2:
00992          case MTYPE_U4:
00993             sprintf(buffer, "reg%d", First_Int_Preg_Return_Offset);
00994             Append_Token_String(tokens, buffer);
00995             break;
00996          case MTYPE_F4:
00997          case MTYPE_F8:
00998          case MTYPE_FQ:
00999          case MTYPE_C4:
01000          case MTYPE_C8:
01001          case MTYPE_CQ:
01002             sprintf(buffer, "reg%d", First_Float_Preg_Return_Offset);
01003             Append_Token_String(tokens, buffer);
01004             break;
01005          case MTYPE_M:
01006             Fail_FmtAssertion ("MLDID of Return_Val_Preg not allowed in middle"
01007                " of expression");
01008             break;
01009          default:
01010             Fail_FmtAssertion ("Unexpected type in WN2C_ldid()");
01011       break;
01012          } 
01013       }
01014       else  
01015       {
01016          ST2F_Use_Preg(tokens, ST_type(WN_st(wn)), WN_load_offset(wn));
01017       } 
01018    } 
01019    else     
01020    {
01021       /* Get the base and object type symbols.
01022        */
01023       if (deref && TY_Is_Pointer(ST_type(WN_st(wn))))
01024       {
01025    /* Expect the loaded type to be a pointer to the type of object
01026     * to be dereferenced.  The only place (besides declaration sites)
01027     * where we expect to have to specially handle ptr_as_array 
01028     * objects.
01029     */
01030    if (TY_ptr_as_array(Ty_Table[WN_ty(wn)]))
01031       object_ty = Stab_Array_Of(TY_pointed(WN_ty(wn)), 0/*size*/);
01032    else
01033       object_ty = TY_pointed(WN_ty(wn));
01034 
01035    /* There are two possibilities for the base type:  A regular 
01036     * pointer or a pointer to be treated as a pointer to an array.
01037     * In either case, the "base_ptr_ty" is a pointer to the 
01038     * derefenced base type.  
01039     *
01040     * Note that this does not handle a pointer to a struct to be
01041     * treated as an array of structs, where the object type and
01042     * offset denote a member of the struct, since WN2F_Offset_Symref() 
01043     * cannot access a struct member through an array access.
01044     */
01045    if (TY_ptr_as_array(Ty_Table[ST_type(WN_st(wn))]))
01046       base_ptr_ty = 
01047          Stab_Pointer_To(Stab_Array_Of(TY_pointed(ST_type(WN_st(wn))),
01048               0/*size*/));
01049    else
01050       base_ptr_ty = ST_type(WN_st(wn));
01051       }
01052       else
01053       {
01054    /* Either not a dereference, or possibly a dereference off a 
01055     * record/map/common/equivalence field.  The base symbol is
01056     * not a pointer, and any dereferencing on a field will occur
01057     * in WN2F_Offset_Symref().
01058     */
01059    object_ty = WN_ty(wn);
01060    base_ptr_ty = Stab_Pointer_To(ST_type(WN_st(wn)));
01061       }
01062 
01063       if (!deref && STAB_IS_POINTER_REF_PARAM(WN_st(wn)))
01064       {
01065    /* Since we do not wish to dereference a load of a reference 
01066           * parameter, this must mean we are taking the address of the
01067           * parameter.
01068           */
01069    Append_Token_String(tokens, "%loc");
01070    Append_Token_Special(tokens, '(');
01071    set_WN2F_CONTEXT_no_parenthesis(context);
01072 
01073       }
01074 
01075       WN2F_Offset_Symref(tokens, 
01076        WN_st(wn),           /* base-symbol */
01077        base_ptr_ty,         /* base-type */
01078        object_ty,           /* object-type */
01079        WN_load_offset(wn),  /* object-ofst */
01080        context);
01081 
01082       if (!deref && STAB_IS_POINTER_REF_PARAM(WN_st(wn)))
01083       {
01084    Append_Token_Special(tokens, ')');
01085       }
01086    }
01087    return EMPTY_WN2F_STATUS;
01088 } /* WN2F_ldid */
01089 
01090 
01091 WN2F_STATUS 
01092 WN2F_lda(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
01093 {
01094   const BOOL deref = WN2F_CONTEXT_deref_addr(context);
01095   
01096   ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_LDA, 
01097        (DIAG_W2F_UNEXPECTED_OPC, "WN2F_lda"));
01098   ASSERT_DBG_FATAL(ST_class(WN_st(wn)) != CLASS_PREG, 
01099        (DIAG_W2F_CANNOT_LDA_PREG));
01100 
01101   TY_IDX object_ty;
01102   
01103   if (!deref)
01104     {
01105       /* A true address-of operation */
01106       Append_Token_String(tokens, "%loc");
01107       Append_Token_Special(tokens, '(');
01108       set_WN2F_CONTEXT_no_parenthesis(context);
01109     }
01110   
01111   /* Sometimes we need to deal with buggy WHIRL code, where the TY
01112    * associated with an LDA is not a pointer type.  For such cases
01113    * we infer a type here.
01114    */
01115 
01116   if (TY_Is_Pointer(WN_ty(wn)))
01117     {
01118       object_ty = TY_pointed(WN_ty(wn));
01119     }
01120   else
01121     {
01122       /* May be wrong, but the best we can do under these exceptional */
01123       /* circumstances. */
01124   
01125       object_ty = ST_type(WN_st(wn));
01126     }
01127 
01128   ST * st = WN_st(wn);
01129   TY_IDX ty ;
01130   reset_WN2F_CONTEXT_deref_addr(context);
01131 
01132   if (ST_sym_class(st) == CLASS_BLOCK)
01133   {
01134     WN2F_Block(tokens,st,WN_lda_offset(wn),context);
01135   }
01136   else 
01137   {
01138     ty = Stab_Pointer_To(ST_type(st));
01139 
01140     WN2F_Offset_Symref(tokens, 
01141            WN_st(wn),                           /* base-symbol */
01142            ty,                                  /* base type   */
01143            object_ty,                           /* object-type */
01144            WN_lda_offset(wn),                   /* object-ofst */
01145            context);
01146   }
01147   if (!deref)
01148     Append_Token_Special(tokens, ')');
01149 
01150   return EMPTY_WN2F_STATUS;
01151 } /* WN2F_lda */
01152 
01153 
01154 WN2F_STATUS
01155 WN2F_array(TOKEN_BUFFER tokens, WN *wn, WN2F_CONTEXT context)
01156 {
01157    /* Note that array indices have been normalized to assume the
01158     * array is based at index zero.  Since a base at index 1 is
01159     * the default for Fortran, we denormalize to base 1 here.
01160     */
01161    BOOL  deref = WN2F_CONTEXT_deref_addr(context);
01162    WN    * kid;
01163    TY_IDX ptr_ty;
01164    TY_IDX array_ty;
01165 
01166 
01167    ASSERT_DBG_FATAL(WN_opc_operator(wn) == OPR_ARRAY, 
01168         (DIAG_W2F_UNEXPECTED_OPC, "WN2F_array"));
01169 
01170    /* Only allow taking the address of an array element for F90!
01171     *
01172     */
01173    if (!deref) {
01174       Append_Token_String(tokens, "%loc(");
01175       set_WN2F_CONTEXT_deref_addr(context);
01176 
01177    }
01178 #if 0
01179  else
01180       ASSERT_DBG_WARN(deref,
01181           (DIAG_UNIMPLEMENTED, 
01182            "taking the address of an array element"));
01183 #endif
01184 
01185    /* Get the array or, for ptr-as-array types, the element type */
01186 
01187    kid    = WN_kid0(wn);
01188    ptr_ty = WN_Tree_Type(kid);
01189 
01190    if (WN2F_Is_Address_Preg(kid,ptr_ty))
01191    {
01192        /* a preg or sym has been used as an address, usually after optimization      */
01193        /* don't know base type, or anything else so use OPR_ARRAY to generate bounds */
01194 
01195      WN2F_translate(tokens, kid, context);
01196      WN2F_Array_Slots(tokens,wn,context,TRUE);     
01197    } 
01198    else 
01199    {
01200 
01201      array_ty = W2F_TY_pointed(ptr_ty, "base of OPC_ARRAY");
01202 
01203      if (WN_opc_operator(kid) == OPR_LDID       &&
01204    ST_sclass(WN_st(kid)) == SCLASS_FORMAL &&
01205    !ST_is_value_parm(WN_st(kid))          &&
01206    WN_element_size(wn) == TY_size(array_ty)       &&
01207    WN_num_dim(wn) == 1                            &&
01208    WN_opc_operator(WN_array_index(wn, 0)) == OPR_INTCONST &&
01209    WN_const_val(WN_array_index(wn, 0)) == 0       &&
01210    !TY_ptr_as_array(Ty_Table[WN_ty(kid)])           &&
01211    (!TY_Is_Array(array_ty) || 
01212     TY_size(TY_AR_etype(array_ty)) < TY_size(array_ty)))
01213      {
01214    /* This array access is just a weird representation for an implicit
01215     * reference parameter dereference.  Ignore the array indexing.
01216     */
01217 
01218        WN2F_translate(tokens, kid, context);
01219      }
01220      else if (!TY_ptr_as_array(Ty_Table[ptr_ty]) && TY_Is_Character_String(array_ty))
01221      {
01222    /* We assume that substring accesses are treated in the handling
01223     * of intrinsic functions, except when the substrings are to be
01224     * handled as integral types and thus are encountered here.
01225     */
01226 
01227        if (!WN2F_F90_pu)
01228        {
01229    Append_Token_String(tokens, "ichar");
01230    Append_Token_Special(tokens, '(');
01231        }
01232        WN2F_String_Argument(tokens, wn, WN2F_INTCONST_ONE, context);
01233        if (!WN2F_F90_pu)
01234    Append_Token_Special(tokens, ')');
01235      }
01236      else /* A regular array access */
01237      {
01238      /* Get the base of the object to be indexed into, still using
01239       * WN2F_CONTEXT_deref_addr(context).
01240       */
01241        WN2F_translate(tokens, kid, context);
01242        reset_WN2F_CONTEXT_deref_addr(context);
01243 
01244        WN2F_array_bounds(tokens,wn,array_ty,context);
01245      }
01246 
01247      if (!deref)
01248        Append_Token_Special(tokens, ')');
01249    }
01250    return EMPTY_WN2F_STATUS;
01251 } /* WN2F_array */
01252 
01253 
01254 void
01255 WN2F_Array_Slots(TOKEN_BUFFER tokens, WN *wn,WN2F_CONTEXT context,BOOL parens)
01256 {
01257   INT32 dim;
01258 
01259   /* Gets bounds from the slots of an OPC_ARRAY node  */
01260 
01261   /* Append the "denormalized" indexing expressions in reverse order
01262    * of the way they occur in the indexing expression, since Fortran
01263    * employs column-major array layout, meaning the leftmost indexing
01264    * expression represents array elements laid out in contiguous 
01265    * memory locations.
01266    */
01267 
01268   if (parens)
01269   {
01270     Append_Token_Special(tokens, '(');
01271     set_WN2F_CONTEXT_no_parenthesis(context);
01272   }
01273 
01274   for (dim = WN_num_dim(wn)-1; dim >= 0; dim--)
01275   {
01276     (void)WN2F_Denormalize_Array_Idx(tokens, 
01277              WN_array_index(wn, dim), 
01278              context);
01279    
01280     if (dim > 0)
01281       Append_Token_Special(tokens, ',');
01282   }
01283 
01284   if (parens)
01285     Append_Token_Special(tokens, ')');
01286 }
01287 
01288 void
01289 WN2F_array_bounds(TOKEN_BUFFER tokens, WN *wn, TY_IDX array_ty,WN2F_CONTEXT context)
01290 {
01291   /* This prints the array subscript expression. It was part of
01292    * WN2F_array, but was split so it could be used for bounds 
01293    * of structure components.
01294    */
01295  
01296   INT32 dim;
01297 
01298   Append_Token_Special(tokens, '(');
01299   set_WN2F_CONTEXT_no_parenthesis(context);
01300 
01301   if (TY_Is_Array(array_ty) && TY_AR_ndims(array_ty) >= WN_num_dim(wn))
01302     {
01303       /* Cannot currently handle differing element sizes at place of
01304        * array declaration versus place of array access (TODO?).
01305        */
01306 
01307       ASSERT_DBG_WARN((TY_size(TY_AR_etype(array_ty)) == WN_element_size(wn)) ||
01308           WN_element_size(wn) < 0 ||
01309           TY_size(TY_AR_etype(array_ty)) == 0,
01310           (DIAG_UNIMPLEMENTED, 
01311            "access/declaration mismatch in array element size"));
01312 
01313       WN2F_Array_Slots(tokens,wn,context,FALSE);
01314 
01315       /* We handle the case when an array is declared to have more 
01316        * dimensions than that given by this array addressing expression.
01317        */
01318       if (TY_AR_ndims(array_ty) > WN_num_dim(wn))
01319   {
01320     /* Substitute in '1' for the missing dimensions */
01321     for (dim = TY_AR_ndims(array_ty) - WN_num_dim(wn); dim > 0; dim--)
01322       {
01323         Append_Token_Special(tokens, ',');
01324         Append_Token_String(tokens, "1");
01325       }
01326   }
01327     }
01328   else /* Normalize array access to assume a single dimension */
01329     {
01330       ASSERT_DBG_WARN(!TY_Is_Array(array_ty) || TY_AR_ndims(array_ty) == 1,
01331           (DIAG_UNIMPLEMENTED, 
01332            "access/declaration mismatch in array dimensions"));
01333 
01334       WN2F_Normalize_Idx_To_Onedim(tokens, wn, context);
01335     }
01336   Append_Token_Special(tokens, ')');
01337 }
01338 
01339 /*----------- Character String Manipulation Translation ---------------*/
01340 /*---------------------------------------------------------------------*/
01341 
01342 void
01343 WN2F_String_Argument(TOKEN_BUFFER  tokens,
01344          WN           *base_parm,
01345          WN           *length,
01346          WN2F_CONTEXT  context)
01347 {
01348    /* Append the tokens denoting the substring expression represented
01349     * by the base-expression.
01350     *
01351     * There are two possibilities concerning the array base 
01352     * expressions.  It can be a pointer to a complete character-
01353     * string (array) or it can be a pointer to a character within 
01354     * a character-string (single character).  In the first instance,
01355     * the offset off the base of string is zero.  In the latter 
01356     * case, the offset is given by the array indexing operation.
01357     *
01358     * NOTE: In some cases (notably for IO_ITEMs), we may try to 
01359     * derive a substring off an OPC_VINTRINSIC_CALL node or a
01360     * VCALL node.  This should only happend when the returned value
01361     * is the first argument and the length is the second argument.
01362     */
01363    WN   *base = WN_Skip_Parm(base_parm);
01364    WN   *lower_bnd;
01365    WN   *arg_expr;
01366    TY_IDX str_ty;
01367    INT64 str_length;
01368 
01369    /* Skip any INTR_ADRTMP and INTR_VALTMP nodes */
01370    if (WN_opc_operator(base) == OPR_INTRINSIC_OP &&
01371        (INTR_is_adrtmp(WN_intrinsic(base)) || 
01372   INTR_is_valtmp(WN_intrinsic(base))))
01373    {
01374       base = WN_kid0(base);
01375    }
01376 
01377    if (WN_operator(base) == OPR_CVTL)  
01378    {
01379      /* probably CHAR(INT) within IO stmt. convert via CHAR & process rest elsewhere */
01380 
01381       Append_Token_Special(tokens, '(');
01382       Append_Token_String(tokens, "char");
01383       WN2F_translate(tokens,WN_kid0(base),context);
01384       Append_Token_Special(tokens, ')');
01385       return;
01386    }
01387    
01388    /* Handle VCALLs specially, since the string information is given
01389     * by the first two arguments to the call.  Note that we can 
01390     * always assume a lower bound of zero for these, as we never 
01391     * generate code for the return-address.  This should only occur
01392     * within an IO stmt.  Note that the type of VCALLs must be 
01393     * accessed in the context of an ADRTMP or VALTMP.
01394     */
01395    if (WN_opcode(base) == OPC_VCALL ||
01396        WN_opcode(base) == OPC_VINTRINSIC_CALL)
01397    {
01398       arg_expr  = WN_Skip_Parm(WN_kid1(base));
01399       lower_bnd = WN2F_INTCONST_ZERO;
01400 
01401       /* fixed size string? */
01402 
01403       if (WN_opc_operator(arg_expr) == OPR_INTCONST)
01404    str_length = WN_const_val(arg_expr);
01405       else
01406    str_length = -1 ;  
01407 
01408       set_WN2F_CONTEXT_deref_addr(context);
01409       WN2F_translate(tokens, base, context);
01410       reset_WN2F_CONTEXT_deref_addr(context);
01411 
01412    } 
01413    else 
01414    {
01415      /* A regular address expression as base */
01416 
01417       WN2F_Get_Substring_Info(&base, &str_ty, &lower_bnd);
01418 
01419       /* Was this a character component of an array of derived type? */
01420       /* eg: vvv(2)%ccc(:)(1:5) - offset to ccc is added above base, */
01421       /* ADD(8,ARRAY(2,LDA VVV)) with array section for CCC on top   */
01422       /* of the ADD, and the substring above the array section. Take */
01423       /* the substring off the top, and process the rest             */
01424 
01425       if (TY_kind(str_ty) == KIND_STRUCT) 
01426       {
01427   FLD_PATH_INFO *fld_path ;
01428   FLD_HANDLE fld;
01429   TY_IDX  ty_idx ; 
01430 
01431   TY & ty = New_TY(ty_idx);
01432 
01433   TY_Init (ty, 1, KIND_SCALAR, MTYPE_U1, Save_Str(".w2fch."));
01434   Set_TY_is_character(ty);
01435 
01436   fld_path = TY2F_Get_Fld_Path(str_ty, 
01437              ty_idx,
01438              WN2F_Sum_Offsets(base));
01439 
01440         fld = TY2F_Last_Fld(fld_path);
01441   TY2F_Free_Fld_Path(fld_path);
01442 
01443   /* call memref for FLD offset, otherwise the ADD is */
01444   /* just another binary op                           */
01445 
01446   WN2F_Offset_Memref(tokens, 
01447          WN_kid0(base),
01448          WN_Tree_Type(base),
01449                            FLD_type(fld),
01450          0,
01451          context);
01452       } 
01453       else 
01454       {
01455   str_length = TY_size(str_ty);
01456 
01457         /* with optimization, may not have useful address TY 
01458          * when TreeType will return array of U1 from SubstringInfo */
01459 
01460   ASSERT_DBG_WARN(TY_Is_Character_String(str_ty) || TY_Is_Array_Of_UChars(str_ty),
01461       (DIAG_W2F_EXPECTED_PTR_TO_CHARACTER,
01462        "WN2F_String_Argument"));
01463 
01464 
01465   /* Get the string base and substring notation for the argument.  */
01466 
01467   set_WN2F_CONTEXT_deref_addr(context);
01468   WN2F_translate(tokens, base, context);
01469   reset_WN2F_CONTEXT_deref_addr(context);
01470       }
01471 
01472       WN2F_Substring(tokens, 
01473          str_length,
01474          lower_bnd,
01475          WN_Skip_Parm(length),
01476          context);
01477       return ;
01478    }
01479 } /* WN2F_String_Argument */
01480 
01481 
01482 /*----------- Miscellaneous  routines ---------------------------------*/
01483 /*---------------------------------------------------------------------*/
01484 
01485 static void
01486 WN2F_Block(TOKEN_BUFFER tokens, ST * st, STAB_OFFSET offset,WN2F_CONTEXT context)
01487 {
01488   /* An ST of CLASS_BLOCK may appear in f90 IO, at -O2 */
01489   /* put out something for the whirl browser           */
01490 
01491   ST2F_use_translate(tokens,st);
01492 
01493   if (offset != 0)
01494   {
01495       Append_Token_Special(tokens, '+');
01496       Append_Token_String(tokens, Number_as_String(offset, "%lld"));
01497   }
01498 }
osprey/be/whirl2f/wn2f_load_store.cxx
