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

00001 /*
00002  * Copyright 2003, 2004 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: ty2f.c
00044  * $Revision: 1.1 $
00045  * $Date: 2005/07/27 02:13:43 $
00046  * $Author: kevinlo $
00047  * $Source: /depot/CVSROOT/javi/src/sw/cmplr/be/whirl2f/ty2f.cxx,v $
00048  *
00049  * Revision history:
00050  *  12-Apr-95 - Original Version
00051  *
00052  * Description:
00053  *
00054  *   Translates a TY entry to a Fortran type.
00055  *
00056  * ====================================================================
00057  * ====================================================================
00058  */
00059 #include "whirl2f_common.h"
00060 #include "PUinfo.h"
00061 #include "wn2f.h"
00062 #include "ty2f.h"
00063 #include "st2f.h"
00064 #include "tcon2f.h"
00065 #include "wn2f_load_store.h"
00066 
00067 BOOL Use_Purple_Array_Bnds_Placeholder = FALSE;
00068 
00069 /* TY2F_Handler[] maps a TY_kind to a function that translates
00070  * a type of the given kind into Fortran.  Should the ordinal
00071  * numbering of the KIND change in "../common/com/stab.h", then
00072  * a corresponding change must be made here.
00073  */
00074 
00075 typedef void (*TY2F_HANDLER_FUNC)(TOKEN_BUFFER, TY_IDX);
00076 static void TY2F_invalid(TOKEN_BUFFER decl_tokens, TY_IDX ty);
00077 static void TY2F_scalar(TOKEN_BUFFER decl_tokens, TY_IDX ty);
00078 static void TY2F_array(TOKEN_BUFFER decl_tokens, TY_IDX ty);
00079 static void TY2F_struct(TOKEN_BUFFER decl_tokens, TY_IDX ty);
00080 static void TY2F_pointer(TOKEN_BUFFER decl_tokens, TY_IDX ty);
00081 static void TY2F_void(TOKEN_BUFFER decl_tokens, TY_IDX ty) ;
00082 
00083 static const TY2F_HANDLER_FUNC 
00084    TY2F_Handler[KIND_LAST/*TY_KIND*/] =
00085 {
00086    &TY2F_invalid,   /* KIND_INVALID */
00087    &TY2F_scalar,    /* KIND_SCALAR */
00088    &TY2F_array,     /* KIND_ARRAY */
00089    &TY2F_struct,    /* KIND_STRUCT */
00090    &TY2F_pointer,   /* KIND_POINTER */
00091    &TY2F_invalid,   /* KIND_FUNCTION */
00092    &TY2F_void,      /* KIND_VOID */
00093 }; /* TY2F_Handler */
00094 
00095 /* detect parts of f90 dope vectors which should be output. Most are I4 boundaries */
00096 /* except the bofst >16 - just for num_dims */
00097 
00098 #define NOT_BITFIELD_OR_IS_FIRST_OF_BITFIELD(f) \
00099   (!FLD_is_bit_field(f) || (FLD_is_bit_field(f) && (FLD_bofst(f) == 0) || FLD_bofst(f) > 16))
00100 
00101 /*---------------------- A few utility routines -----------------------*/
00102 /*---------------------------------------------------------------------*/
00103 
00104   
00105 void
00106 WN2F_Append_Purple_Xsym(TOKEN_BUFFER tokens, ST *st)
00107 {
00108    const char * const name   = W2F_Object_Name(st);
00109    mUINT32      const id     = ST_st_idx(st);
00110    ST_SCLASS    const sclass = ST_sclass(st);
00111    ST_EXPORT    const export_class = (ST_EXPORT) ST_export(st);
00112 
00113    Append_Token_String(tokens, name);
00114    Append_Token_Special(tokens, ',');
00115    Append_Token_String(tokens, Number_as_String(id, "%llu"));
00116    Append_Token_Special(tokens, ',');
00117    Append_Token_String(tokens, Number_as_String(sclass, "%lld"));
00118    Append_Token_Special(tokens, ',');
00119    Append_Token_String(tokens, Number_as_String(export_class, "%lld"));
00120    Append_Token_Special(tokens, ',');
00121    Append_Token_String(tokens, "0"); /* Flags */
00122 } /* WN2F_Append_Purple_Xsym */
00123 
00124 
00125 static void
00126 TY2F_Append_Array_Bnd_Ph(TOKEN_BUFFER decl_tokens, 
00127        ST_IDX       arbnd,
00128        BOOL         purple_assumed_size)
00129 {
00130    char ptr_string[128];
00131    const char * p = "%s";
00132 
00133    if (purple_assumed_size)
00134    {
00135       /* We are already within a placeholder for an assumed-sized array */
00136 
00137      p = "[%s]";
00138    }
00139    
00140    // Would prefer
00141    //   sprintf(ptr_string, p, W2CF_Symtab_Nameof_St(ST_ptr(arbnd)));
00142    // but mfef77 assigns auto varbls of same name in skip list. So 
00143    // assignments to bounds  don't get printed & the bounds look a 
00144    // little odd. eg: try
00145    //   subroutine xxx(bbb,k1,k2)
00146    //   integer bbb(k1,3:k2)
00147    //
00148    // mfef90 uses unique names, so ST_name is ok.
00149 
00150    sprintf(ptr_string, p, ST_name(ST_ptr(arbnd)));
00151    Append_Token_String(decl_tokens, ptr_string);
00152 
00153 } /* TY2F_Append_Array_Bnd_Ph */
00154 
00155 static void
00156 TY2F_Append_ARB(TOKEN_BUFFER decl_tokens, ARB_HANDLE arb, BOOL purple_assumed_size)
00157 {
00158    WN2F_CONTEXT context = INIT_WN2F_CONTEXT;
00159    
00160    /* All array acceses have been normalized to assume arrays with
00161     * bounds based at 1 (Fortran default), so we do the same thing here.
00162     * There is no need to emit the lower bound, since 1 is the default
00163     * anyway:
00164     *
00165     *   TCON2F_translate(decl_tokens, 
00166     *                  Host_To_Targ(MTYPE_I8, 1LL),
00167     *                  FALSE *is_logical*);
00168     * Append_Token_Special(decl_tokens, ':');
00169     */
00170 
00171    /* Append the upper-bound */
00172    if (ARB_const_lbnd(arb) && /* Constant lower bound */
00173        ARB_const_ubnd(arb))   /* Constant upper bound */
00174    {
00175       if (ARB_ubnd_val(arb) - ARB_lbnd_val(arb) >= 0)
00176    TCON2F_translate(decl_tokens, 
00177         Host_To_Targ(MTYPE_I8, 
00178                ARB_ubnd_val(arb) - 
00179                ARB_lbnd_val(arb) + 1LL),
00180         FALSE /*is_logical*/);
00181       else
00182    Append_Token_Special(decl_tokens, '*');
00183    
00184    }
00185    else
00186    {
00187       /* We have some combination of non-constant bounds, so we try to
00188        * normalize these to account for index-expressions that have been
00189        * normalized to "1" based indices.
00190        */
00191       if ((!ARB_const_lbnd(arb) && ARB_lbnd_var(arb) == (ST_IDX) 0) ||
00192                (!ARB_const_ubnd(arb) && ARB_ubnd_var(arb) == (ST_IDX) 0))
00193       {
00194    Append_Token_Special(decl_tokens, '*');
00195       }
00196       else if (ARB_const_ubnd(arb))
00197       {
00198    TCON2F_translate(decl_tokens, 
00199         Host_To_Targ(MTYPE_I8,
00200                ARB_ubnd_val(arb) + 1LL),
00201         FALSE /*is_logical*/);
00202          Append_Token_Special(decl_tokens, '-');
00203          Append_Token_Special(decl_tokens, '(');
00204    set_WN2F_CONTEXT_no_parenthesis(context);
00205    TY2F_Append_Array_Bnd_Ph(decl_tokens, 
00206           ARB_lbnd_var(arb), 
00207           purple_assumed_size);
00208    Append_Token_Special(decl_tokens, ')');
00209       }
00210       else if (ARB_const_lbnd(arb))
00211       {
00212    BOOL zero_lbnd = (ARB_lbnd_val(arb) - 1LL == 0LL);
00213 
00214          if (!zero_lbnd)
00215    {
00216       Append_Token_Special(decl_tokens, '(');
00217       set_WN2F_CONTEXT_no_parenthesis(context);
00218    }
00219    TY2F_Append_Array_Bnd_Ph(decl_tokens, 
00220           ARB_ubnd_var(arb), 
00221           purple_assumed_size);
00222          if (!zero_lbnd)
00223    {
00224       Append_Token_Special(decl_tokens, ')');
00225       Append_Token_Special(decl_tokens, '-');
00226       TCON2F_translate(decl_tokens, 
00227            Host_To_Targ(MTYPE_I8,
00228             ARB_lbnd_val(arb) - 1LL),
00229            FALSE /*is_logical*/);
00230    }
00231       }
00232       else
00233       {
00234          set_WN2F_CONTEXT_no_parenthesis(context);
00235          Append_Token_String(decl_tokens, "1");
00236          Append_Token_Special(decl_tokens, '+');
00237          Append_Token_Special(decl_tokens, '(');
00238    TY2F_Append_Array_Bnd_Ph(decl_tokens,
00239           ARB_ubnd_var(arb), 
00240           purple_assumed_size);
00241          Append_Token_Special(decl_tokens, ')');
00242          Append_Token_Special(decl_tokens, '-');
00243          Append_Token_Special(decl_tokens, '(');
00244    TY2F_Append_Array_Bnd_Ph(decl_tokens,
00245           ARB_lbnd_var(arb), 
00246           purple_assumed_size);
00247          Append_Token_Special(decl_tokens, ')');
00248       }
00249    } /* Constant bounds */
00250 } /* TY2F_Append_ARB */
00251 
00252 static void
00253 TY2F_Append_Assumed_Single_Dim(TOKEN_BUFFER decl_tokens,
00254              ST          *st,
00255              TY_IDX       element_ty)
00256 {
00257    /* Insert a purple placeholder to represent a one-dimensional array:
00258     *
00259     *  <#PRP_XSYM:ASSUMED_ARRAY name, id, sclass, exports, flags, 
00260     *                           1<>, element_size#>
00261     */
00262    Append_Token_String(decl_tokens, "<#PRP_XSYM:ASSUMED");
00263    WN2F_Append_Purple_Xsym(decl_tokens, st);
00264    Append_Token_Special(decl_tokens, ',');
00265    Append_Token_String(decl_tokens, Number_as_String(1, "%llu"));
00266    Append_Token_Special(decl_tokens, '<');
00267    Append_Token_Special(decl_tokens, '>');
00268    Append_Token_Special(decl_tokens, ',');
00269    Append_Token_String(decl_tokens, 
00270            Number_as_String(TY_size(element_ty), "%llu"));
00271    Append_Token_String(decl_tokens, "#>");
00272 } /* TY2F_Append_Assumed_Single_Dim */
00273 
00274 static void
00275 TY2F_Purple_Ptr_As_Array(TOKEN_BUFFER decl_tokens, ST *st, TY_IDX element_ty)
00276 {
00277    if (TY_is_character(element_ty))
00278    {
00279       TOKEN_BUFFER tokens = New_Token_Buffer();
00280 
00281       Append_Token_String(tokens, "CHARACTER*(");
00282       TY2F_Append_Assumed_Single_Dim(tokens, st, element_ty);
00283       Append_Token_Special(tokens, ')');
00284       Prepend_And_Reclaim_Token_List(decl_tokens, &tokens);
00285    }
00286    else
00287    {
00288       Append_Token_Special(decl_tokens, '(');
00289       TY2F_Append_Assumed_Single_Dim(decl_tokens, st, element_ty);
00290       Append_Token_Special(decl_tokens, ')');
00291    }
00292 } /* TY2F_Purple_Ptr_As_Array */
00293 
00294 
00295 static void
00296 TY2F_Purple_Assumed_Sized_Array(TOKEN_BUFFER decl_tokens, ST *st, TY_IDX ty)
00297 {
00298    ASSERT_DBG_FATAL(TY_kind(ty) == KIND_ARRAY,
00299         (DIAG_W2F_UNEXPECTED_TYPE_KIND,
00300          TY_kind(ty), "TY2F_Purple_Assumed_Sized_Array"));
00301 
00302    if (TY_is_character(ty))
00303    {
00304       TOKEN_BUFFER tokens = New_Token_Buffer();
00305 
00306       Append_Token_String(tokens, "CHARACTER*(");
00307       TY2F_Append_Assumed_Single_Dim(tokens, st, TY_AR_etype(ty));
00308       Append_Token_Special(tokens, ')');
00309       Prepend_And_Reclaim_Token_List(decl_tokens, &tokens);
00310    }
00311    else
00312    {
00313       /* A regular assumed sized array, so insert a purple placeholder:
00314        *
00315        *  <#PRP_XSYM:ASSUMED_ARRAY name, id, sclass, exports, flags, 
00316        *                           num_bounds<bnds>, esize#>
00317        *
00318        * where "bnds" is a sequence of known bounds (B) or adjustable
00319        * bounds ([id]) for dimensions 0 -> (TY_AR_ndims(ty) - 2). Hence,
00320        * the number of comma-separated elements in bnds is one less than
00321        * num_bounds.
00322        */
00323 
00324       ARB_HANDLE  arb_base  = TY_arb(ty);
00325       INT32        dim  = ARB_dimension(arb_base) -1 ; 
00326 
00327       /* Prepend the element-type.
00328        */
00329       TY2F_translate(decl_tokens, TY_AR_etype(ty));
00330 
00331       /* Append a placeholder for the array bounds.
00332        */
00333       Append_Token_Special(decl_tokens, '(');
00334       Append_Token_String(decl_tokens, "<#PRP_XSYM:ASSUMED");
00335       WN2F_Append_Purple_Xsym(decl_tokens, st);
00336       Append_Token_Special(decl_tokens, ',');
00337       Append_Token_String(decl_tokens,
00338         Number_as_String(TY_AR_ndims(ty), "%llu"));
00339       Append_Token_Special(decl_tokens, '<');
00340       
00341       while ( dim >= 0)
00342       {
00343   ARB_HANDLE arb = arb_base[dim];
00344   
00345   if (dim-- > 0) 
00346     Append_Token_Special(decl_tokens, ',');
00347 
00348   TY2F_Append_ARB(decl_tokens,arb,TRUE);
00349 
00350       } 
00351 
00352       Append_Token_Special(decl_tokens, '>');
00353       Append_Token_Special(decl_tokens, ',');
00354       Append_Token_String(decl_tokens, 
00355         Number_as_String(TY_size(TY_AR_etype(ty)), "%llu"));
00356       Append_Token_String(decl_tokens, "#>");
00357       Append_Token_Special(decl_tokens, ')');
00358    }
00359 } /* TY2F_Purple_Assumed_Sized_Array */
00360 
00361 static BOOL
00362 TY2F_is_character(TY_IDX ty)
00363 {
00364   while (TY_kind(ty) == KIND_ARRAY)
00365     ty = TY_etype(ty);
00366 
00367   return TY_is_character(ty);
00368 }
00369 /*------ Utilities for accessing and declaring KIND_STRUCT FLDs ------
00370  *---------------------------------------------------------------------*/
00371 
00372 #define FLD_INFO_ALLOC_CHUNK 16
00373 static FLD_PATH_INFO *Free_Fld_Path_Info = NULL;
00374 
00375 
00376 static BOOL
00377 TY2F_Pointer_To_Dope(TY_IDX ty)
00378 {
00379   /* Is this a pointer to a dope vector base */
00380 
00381   return (strcmp(TY_name(TY_pointed(ty)),".base.") == 0) ;
00382 
00383 }
00384 static FLD_PATH_INFO *
00385 New_Fld_Path_Info(FLD_HANDLE fld)
00386 {
00387    /* Allocates a new FLD_PATH_INFO, reusing any that have earlier
00388     * been freed up.  Dynamic allocation occurs in chunks of 16
00389     * (FLD_INFO_ALLOC_CHUNK) FLD_PATH_INFOs at a time.
00390     */
00391    FLD_PATH_INFO *fld_info;
00392    
00393    if (Free_Fld_Path_Info != NULL)
00394    {
00395       fld_info = Free_Fld_Path_Info;
00396       Free_Fld_Path_Info = fld_info->next;
00397    }
00398    else
00399    {
00400       INT info_idx;
00401       
00402       /* Allocate a new chunk of path infos, and put all except the
00403        * first one on the free-list.
00404        */
00405       fld_info = TYPE_ALLOC_N(FLD_PATH_INFO, FLD_INFO_ALLOC_CHUNK);
00406       fld_info[FLD_INFO_ALLOC_CHUNK-1].next = Free_Fld_Path_Info;
00407       for (info_idx = FLD_INFO_ALLOC_CHUNK-2; info_idx > 0; info_idx--)
00408    fld_info[info_idx].next = &fld_info[info_idx+1];
00409       Free_Fld_Path_Info = &fld_info[1];
00410    }
00411 
00412    fld_info->next = NULL;
00413    fld_info->arr_elt = FALSE;
00414    fld_info->arr_ofst = 0;
00415    fld_info->arr_wn = NULL;
00416    fld_info->fld = fld;
00417    return fld_info;
00418 } /* New_Fld_Path_Info */
00419 
00420 static STAB_OFFSET
00421 TY2F_Fld_Size(FLD_HANDLE this_fld, mUINT64  max_size)
00422 {
00423   /* Returns the size of the field, taking into account the offset
00424    * to the next (non-equivalence) field and the maximum field-size
00425    * (based on the structure size).
00426    */
00427   
00428   mUINT64 fld_size = TY_size(FLD_type(this_fld));
00429 
00430   /* Restrict the fld_size to the max_size */
00431   if (fld_size > max_size)
00432     fld_size = max_size;
00433   
00434   /* If this_fld is an equivalence field, then just return the current
00435    * fld_size (cannot be any different), otherwise search for a non-
00436    * equivalent next_fld at a higher offset.
00437    * TODO: mfef90 & mfef77 set the flag slightly differently in COMMON.
00438    * this really works only for mfef77.
00439    */
00440 
00441   if (!FLD_equivalence(this_fld))
00442     {
00443       FLD_ITER fld_iter = Make_fld_iter(this_fld);
00444 
00445       if (!FLD_last_field (fld_iter)) 
00446       {
00447   ++fld_iter;
00448   BOOL found = FALSE;
00449   mUINT64 noffset = 0; 
00450 
00451   do
00452   {
00453      FLD_HANDLE next_fld (fld_iter);
00454 
00455      if (!FLD_is_bit_field(next_fld)) 
00456        if (!(FLD_equivalence(next_fld) || FLD_ofst(this_fld) >= FLD_ofst(next_fld)))
00457        {
00458          found  = TRUE;
00459          noffset =  FLD_ofst(next_fld) ;
00460          break ;
00461        }
00462    } while (!FLD_last_field (fld_iter ++ )) ;
00463 
00464   if (found) 
00465     if (fld_size > noffset - FLD_ofst(this_fld))
00466       fld_size = noffset - FLD_ofst(this_fld) ;
00467       }
00468     }
00469   return fld_size;
00470 } /* TY2F_Fld_Size */
00471 
00472 
00473 static FLD_PATH_INFO *
00474 Select_Best_Fld_Path(FLD_PATH_INFO *path1,
00475          FLD_PATH_INFO *path2,
00476          TY_IDX         desired_ty,
00477          mUINT64        desired_offset)
00478 {
00479    /* PRECONDITION: Both paths must be non-NULL and lead to a field
00480     *    at the desired_offset.
00481     *
00482     * Try to find the best of two paths to a field.  This routine
00483     * will be called for EVERY field at every place where a struct,
00484     * union, or equivalence field is accessed, so efficiency is of
00485     * uttmost importance.  The best path is returned, while the other
00486     * on is freed up.
00487     */
00488    FLD_PATH_INFO *best_path;
00489    mUINT64        offs1, offs2;
00490    FLD_PATH_INFO *p1, *p2;
00491    TY_IDX         t1,  t2;
00492    
00493    ASSERT_DBG_FATAL(path1 != NULL && path2 != NULL,
00494         (DIAG_W2F_UNEXPEXTED_NULL_PTR, 
00495          "path1 or path2", "Select_Best_Fld_Path"));
00496    
00497    /* Find the last field on each path */
00498    offs1 = FLD_ofst(path1->fld) + path1->arr_ofst;
00499    for (p1 = path1; p1->next != NULL; p1 = p1->next)
00500       offs1 += FLD_ofst(p1->next->fld) + p1->next->arr_ofst;
00501    offs2 = FLD_ofst(path2->fld) + path2->arr_ofst;
00502    for (p2 = path2; p2->next != NULL; p2 = p2->next)
00503       offs2 += FLD_ofst(p2->next->fld) + p2->next->arr_ofst;
00504 
00505    ASSERT_DBG_FATAL(offs1 == desired_offset && offs2 == desired_offset,
00506         (DIAG_W2F_UNEXPEXTED_OFFSET,
00507          offs1, "Select_Best_Fld_Path"));
00508 
00509    /* Get the element type (either the field type or the type of an
00510     * array element.
00511     */
00512    if (p1->arr_elt)
00513       t1 = TY_AR_etype(FLD_type(p1->fld));
00514    else
00515       t1 = FLD_type(p1->fld);
00516    if (p2->arr_elt)
00517       t2 = TY_AR_etype(FLD_type(p2->fld));
00518    else
00519       t2 = FLD_type(p2->fld);
00520 
00521    /* Compare types, in order of increasing accuracy */
00522    if (TY_mtype(t1) == TY_mtype(desired_ty) &&
00523        TY_mtype(t2) != TY_mtype(desired_ty))
00524       best_path = path1;
00525    else if (TY_mtype(t2) == TY_mtype(desired_ty) &&
00526       TY_mtype(t1) != TY_mtype(desired_ty))
00527       best_path = path2;
00528    else if (Stab_Identical_Types(t1, desired_ty,
00529          FALSE,  /* check_quals */
00530          TRUE,   /* check_scalars */
00531          FALSE)) /* ptrs_as_scalars */
00532       best_path = path1; /* path2 cannot possibly be any better */
00533    else if (Stab_Identical_Types(t2, desired_ty,
00534          FALSE,  /* check_quals */
00535          TRUE,   /* check_scalars */
00536          FALSE)) /* ptrs_as_scalars */
00537       best_path = path2;
00538    else
00539       best_path = path1;
00540 
00541    /* Free up the path not chosen */
00542    if (best_path == path1)
00543       TY2F_Free_Fld_Path(path2);
00544    else
00545       TY2F_Free_Fld_Path(path1);
00546 
00547    return best_path;
00548 } /* Select_Best_Fld_Path */
00549 
00550 
00551 static FLD_PATH_INFO *
00552 Construct_Fld_Path(FLD_HANDLE   fld,
00553        TY_IDX    struct_ty,
00554        TY_IDX    desired_ty,
00555        mUINT64   desired_offset,
00556        mUINT64   max_fld_size)
00557 {
00558    /* Returns the field path through "fld" found to best match the 
00559     * given offset and type.  As a minimum requirement, the offset 
00560     * must be as desired and the type must have the desired size
00561     * and alignment (with some concessions allowed for substrings).
00562     * The path is terminate with a NULL next pointer.  When no 
00563     * field matches the desired type and offset, NULL is returned.
00564     */
00565    FLD_PATH_INFO    *fld_path;
00566    const mUINT64     fld_offset = FLD_ofst(fld);
00567    TY_IDX            fld_ty = FLD_type(fld);
00568    BOOL              is_array_elt = FALSE;
00569    STAB_OFFSET       ofst_in_fld = 0;
00570 
00571    /* This field cannot be on the path to a field with the given
00572     * attributes, unless the desired_offset is somewhere within
00573     * the field.
00574     */
00575 #if DBGPATH
00576    printf (" Construct: fld %s, struct %s, desired %s , des off %d \n",
00577      FLD_name(fld),
00578      TY_name(struct_ty),
00579      TY_name(desired_ty),
00580      desired_offset);
00581 #endif
00582 
00583    if (desired_offset < fld_offset ||
00584        desired_offset >= (fld_offset + TY_size(fld_ty)))
00585    {
00586       /* This field cannot be on the path to a field with the given
00587        * attributes, since the desired_offset is nowhere within
00588        * the field.
00589        */
00590       fld_path = NULL;
00591 #if DBGPATH
00592       printf ("     found NULL\n");
00593 #endif
00594    }
00595    else if (TY_Is_Array(fld_ty) && TY_is_character(fld_ty) &&
00596       TY_Is_Array(desired_ty) && TY_is_character(desired_ty))
00597    {
00598 #if DBGPATH
00599       printf ("     found char substring\n");
00600 #endif
00601       /* A match is found! */
00602       ofst_in_fld = (desired_offset - fld_offset)/TY_size(TY_AR_etype(fld_ty));
00603       ofst_in_fld *= TY_size(TY_AR_etype(fld_ty));
00604       if ((ofst_in_fld + TY_size(desired_ty)) > TY_size(fld_ty))
00605       {
00606    fld_path = NULL; /* The string does not fit */
00607       }
00608       else
00609       {
00610    fld_path = New_Fld_Path_Info(fld);
00611    if (TY_size(fld_ty) != TY_size(desired_ty))
00612    {
00613       fld_path->arr_elt = TRUE;
00614       fld_path->arr_ofst = ofst_in_fld;
00615    } 
00616       }
00617    }
00618    else
00619    {
00620       /* See if the field we are looking for may be an array element */
00621       is_array_elt = (TY_Is_Array(fld_ty) &&
00622           (TY_Is_Structured(TY_AR_etype(fld_ty))||
00623            TY2F_is_character(fld_ty) ||
00624            Stab_Identical_Types(TY_AR_etype(fld_ty), desired_ty,
00625               FALSE,   /* check_quals */
00626               FALSE,   /* check_scalars */
00627               TRUE))); /* ptrs_as_scalars */
00628 #if DBGPATH
00629       printf ("     is_array = %d, fld_ty %s \n",is_array_elt,TY_name(fld_ty));
00630 #endif
00631 
00632       if (is_array_elt)
00633       {
00634    fld_ty = TY_AR_etype(fld_ty);
00635    ofst_in_fld =
00636       ((desired_offset - fld_offset)/TY_size(fld_ty)) * TY_size(fld_ty);
00637       }
00638 
00639       if (TY_Is_Structured(fld_ty) &&
00640     !Stab_Identical_Types(fld_ty, desired_ty,
00641         FALSE,  /* check_quals */
00642         FALSE,  /* check_scalars */
00643         TRUE))  /* ptrs_as_scalars */
00644       {
00645 #if DBGPATH
00646   printf ("     recurse \n");
00647 #endif
00648    FLD_PATH_INFO *fld_path2 = 
00649       TY2F_Get_Fld_Path(fld_ty, desired_ty, 
00650             desired_offset - (fld_offset+ofst_in_fld));
00651    
00652    /* If a matching path was found, attach "fld" to the path */
00653    if (fld_path2 != NULL)
00654    {
00655       if (TY_split(Ty_Table[fld_ty]))
00656          fld_path = fld_path2; /* A stransparent substructure */
00657       else
00658       {
00659          fld_path = New_Fld_Path_Info(fld);
00660          fld_path->arr_elt = is_array_elt;
00661          fld_path->arr_ofst = ofst_in_fld;
00662          fld_path->next = fld_path2;
00663       }
00664    }
00665    else
00666    {
00667       fld_path = NULL;
00668    }
00669       }
00670       else /* This may be a field we want to take into account */
00671       {
00672    const STAB_OFFSET fld_size = TY2F_Fld_Size(fld, max_fld_size);
00673 
00674    /* We only match a field with the expected size, offset
00675     * and alignment.
00676     */
00677          
00678    if (desired_offset != fld_offset+ofst_in_fld || /* unexpected ofst */
00679        fld_size < (TY_size(fld_ty)+ofst_in_fld) || /* unexpected size */
00680        TY_align(struct_ty) < TY_align(fld_ty))     /* unexpected align */
00681    {
00682 #if DBGPATH
00683       printf ("     account - miss\n");
00684 #endif
00685       fld_path = NULL;
00686    }
00687    else /* A match is found! */
00688    {
00689 #if DBGPATH
00690      printf ("     account - match\n");
00691 #endif
00692       fld_path = New_Fld_Path_Info(fld);
00693       fld_path->arr_elt = is_array_elt;
00694       fld_path->arr_ofst = ofst_in_fld;
00695    }/*if*/
00696       } /*if*/
00697    } /*if*/
00698 
00699    return fld_path;
00700 } /* Construct_Fld_Path */
00701 
00702 
00703 static const char * 
00704 TY2F_Fld_Name(FLD_HANDLE fld, 
00705         BOOL       common_or_equivalence,
00706         BOOL       alt_return_name)
00707 {
00708    /* Since fields may be accessed in an unqualified manner in Fortran,
00709     * e.g. for common block members and equivalences, so we need to treat
00710     * them similar to the way we would treat regular objects.
00711     */
00712    const char *fld_name;
00713 
00714    if (common_or_equivalence && !alt_return_name)
00715       fld_name = W2CF_Symtab_Nameof_Fld(fld);
00716    else
00717    {
00718       fld_name = WHIRL2F_make_valid_name(FLD_name(fld),FALSE);
00719       if (fld_name == NULL || *fld_name == '\0')
00720    fld_name = W2CF_Symtab_Nameof_Fld(fld);
00721    }
00722    return fld_name;
00723 } /* TY2F_Fld_Name */
00724 
00725 
00726 /*------ Utilities for accessing and declaring KIND_STRUCTs ------
00727  *----------------------------------------------------------------*/
00728 
00729 /* Local buffer to hold Fortran STRUCTURE declarations, which
00730  * should be appended to this buffer in the order in which
00731  * they are encountered.
00732  */
00733 static TOKEN_BUFFER TY2F_Structure_Decls = NULL;
00734 
00735 
00736 static void
00737 TY2F_Equivalence(TOKEN_BUFFER tokens, 
00738      const char  *equiv_name, 
00739      const char  *fld_name,
00740      STAB_OFFSET  fld_ofst)
00741 {
00742    /* Append one equivalence statement to the tokens buffer,
00743     * keeping in mind that the equiv_name is based at index 1.
00744     */
00745    Append_Token_String(tokens, "EQUIVALENCE");
00746    Append_Token_Special(tokens, '(');
00747    Append_Token_String(tokens, equiv_name); /* equiv_name at given offset */
00748    Append_Token_Special(tokens, '(');
00749    Append_Token_String(tokens, Number_as_String(fld_ofst+1, "%lld"));
00750    Append_Token_Special(tokens, ')');
00751    Append_Token_Special(tokens, ',');
00752    Append_Token_String(tokens, fld_name);   /* fld_name at offset zero */
00753    Append_Token_Special(tokens, ')');
00754 } /* TY2F_Equivalence */
00755 
00756 
00757 static void
00758 TY2F_Equivalence_FldList(TOKEN_BUFFER tokens, 
00759                          FLD_HANDLE   fldlist,
00760                          UINT         equiv_var_idx,
00761                          mUINT64      ofst,
00762                          BOOL        *common_block_equivalenced)
00763 {
00764   FLD_ITER fld_iter = Make_fld_iter(fldlist);
00765 
00766   do 
00767     {
00768       FLD_HANDLE fld (fld_iter);
00769 
00770       if (TY_split(Ty_Table[FLD_type(fld)]))
00771   {
00772     TY2F_Equivalence_FldList(tokens, 
00773            TY_flist(Ty_Table[FLD_type(fld)]),
00774            equiv_var_idx,
00775            ofst + FLD_ofst(fld),
00776            common_block_equivalenced);
00777   }
00778       else if (FLD_equivalence(fld) || !*common_block_equivalenced)
00779   {
00780     Append_F77_Indented_Newline(tokens, 1, NULL/*label*/);
00781     TY2F_Equivalence(tokens,
00782          W2CF_Symtab_Nameof_Tempvar(equiv_var_idx),
00783          TY2F_Fld_Name(fld_iter, TRUE/*equiv*/, FALSE/*alt_ret*/),
00784          ofst + FLD_ofst(fld));
00785     if (!FLD_equivalence(fld))
00786       *common_block_equivalenced = TRUE;
00787   }
00788 
00789     }
00790   while (!FLD_last_field (fld_iter++)) ;
00791 
00792 } /* TY2F_Equivalence_FldList */
00793 
00794 
00795 static void
00796 TY2F_Equivalence_List(TOKEN_BUFFER tokens, 
00797           const TY_IDX struct_ty)
00798 {
00799    /* Append a nameless EQUIVALENCE specification statement for
00800     * each equivalence field in the given struct.  Declare a 
00801     * dummy symbol as an array of INTEGER*1 elements to represent
00802     * the structure and each EQUIVALENCE specification will then 
00803     * equivalence a field to this dummy-symbol at the field offset.
00804     *
00805     * Group these declarations together by prepending each 
00806     * declaration (including the first one) with a newline.
00807     *
00808     * For COMMON blocks, it is also necessary to emit one element
00809     * that is not an equivalence!
00810     */
00811    TY_IDX     equiv_ty;
00812    UINT       equiv_var_idx;
00813    BOOL       common_block_equivalenced = FALSE;
00814 
00815    /* Declare an INTEGER*1 array (or CHARACTER string?) variable
00816     * to represent the whole equivalenced structure. Don't unlock
00817     * the tmpvar, or a similar equivalence group (ie: TY) will 
00818     * get the same temp.
00819     */
00820 
00821    equiv_ty = Stab_Array_Of(Stab_Mtype_To_Ty(MTYPE_I1), TY_size(struct_ty));
00822    equiv_var_idx = Stab_Lock_Tmpvar(equiv_ty, &ST2F_Declare_Tempvar);
00823 
00824    /* Relate every equivalence field to the temporary variable.
00825     */
00826    TY2F_Equivalence_FldList(tokens, 
00827                             TY_flist(Ty_Table[struct_ty]),
00828                             equiv_var_idx,
00829                             0, /* Initial offset */
00830                             &common_block_equivalenced);
00831 
00832 } /* TY2F_Equivalence_List */
00833 
00834 static void
00835 TY2F_Translate_Structure(TY_IDX ty)
00836 {
00837    TOKEN_BUFFER fld_tokens, struct_tokens;
00838    FLD_ITER     fld_iter;
00839    const UINT   current_indent = Current_Indentation();
00840    TY& ty_rt  = Ty_Table[ty];
00841    
00842    ASSERT_DBG_FATAL(TY_kind(ty_rt) == KIND_STRUCT, 
00843         (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
00844          TY_kind(ty_rt), "TY2F_Translate_Structure"));
00845 
00846    /* Emit structure header */
00847    Set_Current_Indentation(PUinfo_local_decls_indent);
00848    struct_tokens = New_Token_Buffer();
00849 
00850    if (WN2F_F90_pu) {
00851       Append_Token_String(struct_tokens, "TYPE ");
00852       Append_Token_String(struct_tokens, W2CF_Symtab_Nameof_Ty(ty));
00853    } else {
00854       Append_Token_String(struct_tokens, "STRUCTURE");
00855       Append_Token_String(struct_tokens, 
00856         Concat3_Strings("/", W2CF_Symtab_Nameof_Ty(ty), "/"));
00857    }
00858 
00859    /* Emit structure body */
00860    Increment_Indentation();
00861    FLD_IDX flist = ty_rt.Fld();
00862 
00863    if (flist != 0) {
00864      fld_iter = Make_fld_iter(TY_flist(ty_rt));
00865      do
00866        {
00867    FLD_HANDLE fld (fld_iter);
00868 
00869    /* if it's a bitfield, then assume it's part of a dope vector & */
00870    /* just put out the name of the first bitfield in this I4       */
00871 
00872    if(NOT_BITFIELD_OR_IS_FIRST_OF_BITFIELD(fld_iter))
00873      {
00874        /* See if this field starts a map or a union */
00875 
00876        Append_F77_Indented_Newline(struct_tokens, 1, NULL/*label*/);
00877        if (FLD_begin_union(fld))
00878          {
00879      Append_Token_String(struct_tokens, "UNION");
00880      Increment_Indentation();
00881      Append_F77_Indented_Newline(struct_tokens, 1, NULL/*label*/);
00882          }
00883        else if (FLD_begin_map(fld))
00884          {
00885      Append_Token_String(struct_tokens, "MAP");
00886      Increment_Indentation();
00887      Append_F77_Indented_Newline(struct_tokens, 1, NULL/*label*/);
00888          }
00889 
00890        /* Declare this field */
00891 
00892        fld_tokens = New_Token_Buffer();
00893        Append_Token_String(fld_tokens, 
00894          TY2F_Fld_Name(fld_iter,
00895                  FALSE/*common*/, 
00896                  FALSE/*alt_ret_name*/));
00897 
00898          TY2F_translate(fld_tokens, FLD_type(fld));
00899 
00900        Append_And_Reclaim_Token_List(struct_tokens, &fld_tokens);
00901 
00902        /* See if this field terminates a map or union */
00903        if (FLD_end_union(fld))
00904          {
00905      Decrement_Indentation();
00906      Append_F77_Indented_Newline(struct_tokens, 1, NULL/*label*/);
00907      Append_Token_String(struct_tokens, "END UNION");
00908          }
00909        else if (FLD_end_map(fld))
00910          {
00911      Decrement_Indentation();
00912      Append_F77_Indented_Newline(struct_tokens, 1, NULL/*label*/);
00913      Append_Token_String(struct_tokens, "END MAP");
00914          }
00915      }       
00916        } while (!FLD_last_field (fld_iter++)) ;
00917    }
00918    /* Emit structure tail */
00919    Decrement_Indentation();
00920 
00921    Append_F77_Indented_Newline(struct_tokens, 1, NULL/*label*/);
00922    if (WN2F_F90_pu) {
00923       Append_Token_String(struct_tokens, "END TYPE");
00924    } else {
00925       Append_Token_String(struct_tokens, "END STRUCTURE");
00926    }
00927    Append_F77_Indented_Newline(struct_tokens, 1, NULL/*label*/);
00928    
00929    if (TY2F_Structure_Decls == NULL)
00930       TY2F_Structure_Decls = New_Token_Buffer();
00931 
00932    Set_Current_Indentation(current_indent);
00933    Append_And_Reclaim_Token_List(TY2F_Structure_Decls, &struct_tokens);
00934 
00935 } /* TY2F_Translate_Structure */
00936 
00937 
00938 static void
00939 TY2F_Translate_EquivCommon_PtrFld(TOKEN_BUFFER tokens, FLD_HANDLE fld)
00940 {
00941    /* Declare the pointee and the pointer field of the common/eqivalence
00942     * block.
00943     */
00944    TOKEN_BUFFER decl_tokens = New_Token_Buffer();
00945    const char  *pointee_name = W2CF_Symtab_Nameof_Fld_Pointee(fld);
00946    const char  *fld_name = TY2F_Fld_Name(fld, 
00947            TRUE/*comm,equiv*/, 
00948            FALSE/*alt_ret_name*/);
00949 
00950    Append_Token_String(decl_tokens, pointee_name);
00951    TY2F_translate(decl_tokens, TY_pointed(FLD_type(fld)));
00952    Append_F77_Indented_Newline(decl_tokens, 1, NULL/*label*/);
00953 
00954    /* Declare the pointer type */
00955    Append_Token_String(decl_tokens, "POINTER");
00956    Append_Token_Special(decl_tokens, '(');
00957    Append_Token_String(decl_tokens, fld_name);
00958    Append_Token_Special(decl_tokens, ',');
00959    Append_Token_String(decl_tokens, pointee_name);
00960    Append_Token_Special(decl_tokens, ')');
00961    Append_And_Reclaim_Token_List(tokens, &decl_tokens);
00962 } /* TY2F_Translate_EquivCommon_PtrFld */
00963 
00964 static void
00965 TY2F_Declare_Common_Flds(TOKEN_BUFFER tokens,
00966        FLD_HANDLE   fldlist, 
00967        BOOL         alt_return, /* Alternate return points */
00968        BOOL        *is_equiv)   /* out */
00969 {
00970   FLD_ITER fld_iter = Make_fld_iter(fldlist);
00971 
00972   /* Emit specification statements for every element of the
00973    * common block, including equivalences.
00974    */  
00975 
00976   do
00977     {
00978       FLD_HANDLE fld (fld_iter);
00979       TY_IDX ty = FLD_type(fld);
00980 
00981       /* Determine whether or not the common-block contains any
00982        * equivalences (must all be at the top level).
00983        */
00984 
00985       *is_equiv = *is_equiv || FLD_equivalence(fld);
00986       
00987       /* Declare as specified in the symbol table */
00988       if (TY_split(Ty_Table[ty]))
00989   {
00990     /* Treat a full split element as a transparent data-structure */
00991 
00992     TY2F_Declare_Common_Flds(tokens,
00993            TY_flist(Ty_Table[ty]),
00994            alt_return,
00995            is_equiv);
00996   }
00997       else if (TY_Is_Pointer(ty))
00998   {
00999     TY2F_Translate_EquivCommon_PtrFld(tokens, fld_iter);
01000   }
01001       else /* Non-pointer common field */
01002   {
01003     TOKEN_BUFFER decl_tokens = New_Token_Buffer();
01004     Append_Token_String(decl_tokens, 
01005             TY2F_Fld_Name(fld_iter,
01006               TRUE/*common/equivalence*/, 
01007               alt_return/*alt_ret_name*/));
01008     TY2F_translate(decl_tokens, FLD_type(fld));
01009     Append_And_Reclaim_Token_List(tokens, &decl_tokens);
01010   }
01011       Append_F77_Indented_Newline(tokens, 1, NULL/*label*/);
01012 
01013     } while (!FLD_last_field (fld_iter++)) ;
01014 } /* TY2F_Declare_Common_Flds */
01015 
01016 static void
01017 TY2F_List_Common_Flds(TOKEN_BUFFER tokens, FLD_HANDLE fldlist)
01018 {
01019   FLD_ITER fld_iter = Make_fld_iter(fldlist);
01020 
01021   do
01022     {
01023       FLD_HANDLE fld (fld_iter);
01024       TY & ty  = Ty_Table[FLD_type(fld)];       
01025 
01026       if (TY_split(ty))
01027   {
01028     /* Treat a full split element as a transparent data-structure */
01029 
01030     TY2F_List_Common_Flds(tokens, TY_flist(ty));
01031   }
01032       else if (!FLD_equivalence(fld))
01033       {
01034   Append_Token_String(tokens, 
01035           TY2F_Fld_Name(fld_iter,
01036             TRUE/*common*/, 
01037             FALSE/*alt_ret_name*/));
01038       }
01039       
01040       if (!FLD_last_field(fld)) 
01041       {
01042   FLD_ITER  next_iter = fld_iter ;
01043   FLD_HANDLE next (++next_iter);
01044         if (!FLD_equivalence(next))
01045     Append_Token_Special(tokens, ',');
01046       }
01047 
01048     } while (!FLD_last_field (fld_iter++)) ;
01049 
01050 } /* TY2F_List_Common_Flds */
01051 
01052 /*------------- Hidden routines to declare variable types -------------*/
01053 /*---------------------------------------------------------------------*/
01054 
01055 static void
01056 TY2F_invalid(TOKEN_BUFFER decl_tokens, TY_IDX ty)
01057 {
01058    ASSERT_DBG_FATAL(FALSE, 
01059         (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01060          TY_kind(Ty_Table[ty]), 
01061          "TY2F_invalid"));
01062    Prepend_Token_String(decl_tokens, "<TY2F_invalid>");
01063 } /* TY2F_invalid */
01064 
01065 static void
01066 TY2F_scalar(TOKEN_BUFFER decl_tokens, TY_IDX ty_idx)
01067 {
01068    const char *base_name;
01069    INT64 kind_type;
01070    const char * kind_spec;
01071    TY&   ty = Ty_Table[ty_idx];
01072    MTYPE mt = TY_mtype(ty);
01073 
01074    ASSERT_DBG_FATAL(TY_kind(ty) == KIND_SCALAR, 
01075         (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01076          TY_kind(ty), 
01077          "TY2F_scalar"));
01078 
01079    if (TY_is_character(ty))
01080    {
01081       base_name = "CHARACTER";
01082    }
01083    else if (TY_is_logical(ty))
01084    {
01085       base_name = "LOGICAL";
01086    }
01087    else switch(mt)
01088    {
01089    case MTYPE_U1:
01090    case MTYPE_U2:
01091    case MTYPE_U4:
01092    case MTYPE_U8:
01093       /* Strictly speaking unsigned integers not supported in Fortran,
01094        * but we are lenient and treat them as the signed equivalent.
01095        */
01096    case MTYPE_I1:
01097    case MTYPE_I2:
01098    case MTYPE_I4:
01099    case MTYPE_I8:
01100       base_name = "INTEGER";
01101       break;
01102       
01103    case MTYPE_F4:
01104    case MTYPE_F8:
01105    case MTYPE_FQ:
01106       base_name = "REAL";
01107       break;
01108       
01109    case MTYPE_C4:
01110    case MTYPE_C8:
01111    case MTYPE_CQ:
01112       base_name = "COMPLEX";
01113       break;
01114       
01115    case MTYPE_M:
01116       base_name = "memory block";
01117       break;
01118 
01119 #ifdef KEY
01120 #if defined(TARG_X8664)
01121    case MTYPE_V16I1:
01122    case MTYPE_V16I2:
01123    case MTYPE_V16I4:
01124    case MTYPE_V16I8:
01125    case MTYPE_V16F4:
01126    case MTYPE_V16F8:
01127       base_name = "REAL";
01128       break;
01129 #endif
01130 #endif /* KEY */
01131    default:
01132       ASSERT_DBG_FATAL(FALSE,
01133            (DIAG_W2F_UNEXPECTED_BTYPE, 
01134       MTYPE_name(mt), 
01135       "TY2F_scalar"));
01136    } /* switch(TY_btype(ty) */
01137 
01138    if (TY_size(ty) > 0)
01139    {
01140       if (WN2F_F90_pu) {
01141    if (MTYPE_is_complex(mt)) {
01142       kind_type = TY_size(ty) / 2;
01143    } else {
01144       kind_type = TY_size(ty);
01145    }
01146    kind_spec = Concat3_Strings("(",Number_as_String(kind_type, "%lld"),")");
01147    Prepend_Token_String(decl_tokens,Concat2_Strings(base_name,kind_spec));
01148       } else {
01149    Prepend_Token_String(
01150             decl_tokens, 
01151             Concat3_Strings(base_name,
01152                 "*", 
01153                 Number_as_String(TY_size(ty), "%lld")));
01154       }
01155    }
01156    else
01157    {
01158      if (mt == MTYPE_M)
01159       Prepend_Token_String(decl_tokens, ".mblock.");
01160      else
01161     {
01162        
01163       ASSERT_DBG_FATAL(TY_is_character(ty),
01164            (DIAG_W2F_UNEXPECTED_TYPE_SIZE,
01165       TY_size(ty),"TY2F_scalar"));
01166       Prepend_Token_String(decl_tokens, "CHARACTER*(*)");
01167     }
01168    }
01169 } /* TY2F_scalar */
01170 
01171 
01172 static void
01173 TY2F_array(TOKEN_BUFFER decl_tokens, TY_IDX ty_idx)
01174 {
01175   TY& ty = Ty_Table[ty_idx] ;
01176 
01177    ASSERT_DBG_FATAL(TY_kind(ty) == KIND_ARRAY,
01178         (DIAG_W2F_UNEXPECTED_TYPE_KIND,
01179          TY_kind(ty), "TY2F_array"));
01180 
01181    if (TY_is_character(ty))
01182    {
01183       /* A character string...
01184        */
01185       if (TY_size(ty) > 0) /* ... of known size */
01186    Prepend_Token_String(
01187       decl_tokens,
01188       Concat2_Strings("CHARACTER*",
01189           Number_as_String(TY_size(ty), "%lld")));
01190       else /* ... of unknown size */
01191    Prepend_Token_String(decl_tokens, "CHARACTER*(*)");
01192    }
01193    else
01194    {
01195       /* A regular array, so prepend the element type and append
01196        * the index bounds.
01197        */
01198   
01199      ARB_HANDLE arb_base = TY_arb(ty);
01200      INT32       dim = ARB_dimension(arb_base) - 1  ;
01201 
01202       /* Do not permit pointers as elements of arrays, so just use
01203        * the corresponding integral type instead.  We do not expect
01204        * such pointers to be dereferenced anywhere.
01205        */
01206       if (TY_Is_Pointer(TY_AR_etype(ty)))
01207    TY2F_translate(decl_tokens,
01208       Stab_Mtype_To_Ty(TY_mtype(TY_AR_etype(ty))));
01209       else
01210    TY2F_translate(decl_tokens, TY_AR_etype(ty));
01211 
01212       Append_Token_Special(decl_tokens, '(');
01213 
01214       while (dim >= 0) 
01215       {
01216   ARB_HANDLE arb = arb_base[dim];
01217 
01218   TY2F_Append_ARB(decl_tokens, arb , FALSE);
01219 
01220   if (dim-- > 0) 
01221     Append_Token_Special(decl_tokens, ',');
01222       } 
01223 
01224       Append_Token_Special(decl_tokens, ')');
01225    }
01226 } /* TY2F_array */
01227 
01228 
01229 static void
01230 TY2F_struct(TOKEN_BUFFER decl_tokens, TY_IDX ty)
01231 {
01232   /* Structs are supported by VAX-Fortran and Fortran-90.  Note
01233    * that we here emit a RECORD declaration, while we expect
01234    * the STRUCTURE to have been declared through a call to
01235    * TY2F_Translate_Structure().
01236    */
01237   TY & ty_rt = Ty_Table[ty];
01238 
01239   ASSERT_DBG_FATAL(TY_kind(ty_rt) == KIND_STRUCT, 
01240        (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01241         TY_kind(ty_rt), "TY2F_struct"));
01242 
01243   if (!TY_is_translated_to_c(ty))
01244     {
01245       TY2F_Translate_Structure(ty);
01246       Set_TY_is_translated_to_c(ty); /* Really, translated to Fortran, not C */
01247     }
01248 
01249   if (!WN2F_F90_pu) {
01250     Prepend_Token_String(decl_tokens, 
01251        Concat3_Strings("/", W2CF_Symtab_Nameof_Ty(ty), "/"));
01252     Prepend_Token_String(decl_tokens, "RECORD");
01253   } else {
01254     Prepend_Token_String(decl_tokens, 
01255        Concat3_Strings("(", W2CF_Symtab_Nameof_Ty(ty), ")"));
01256     Prepend_Token_String(decl_tokens, "TYPE");
01257   }      
01258 } /* TY2F_struct */
01259 
01260 
01261 static void
01262 TY2F_pointer(TOKEN_BUFFER decl_tokens, TY_IDX ty)
01263 {
01264    if (!WN2F_F90_pu) {
01265       /* Pointer types in Fortran can only occur in a Pointer specification
01266        * statement.  We do not expect this routine to be called, since we
01267        * expect pointer types to be handled by ST2F_decl_var().
01268        */
01269       ASSERT_DBG_WARN(FALSE, 
01270           (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01271            TY_kind(ty), "TY2F_pointer"));
01272       
01273       Append_Token_Special(decl_tokens, ')');
01274       Prepend_Token_Special(decl_tokens, '(');
01275       Prepend_Token_String(decl_tokens, "POINTER");
01276 
01277    } else {
01278 
01279       /* Is a dope vector base address? Put out an integer large enough */
01280       /* to hold an address for now. Don't really want POINTER because  */
01281       /* implies cray/f90 pointer instead of address slot               */
01282 
01283       if (TY2F_Pointer_To_Dope(ty))
01284       {
01285 #if 0
01286   Prepend_Token_String(decl_tokens,",POINTER ::");
01287 #endif
01288   TY2F_translate(decl_tokens,Be_Type_Tbl(Pointer_Mtype));
01289       } 
01290       else
01291       {
01292   /* avoid recursive type declarations */
01293 
01294   if (TY_kind(TY_pointed(ty)) == KIND_STRUCT)
01295   {
01296 #if 0
01297     Prepend_Token_String(decl_tokens,",POINTER ::");
01298     Prepend_Token_String(decl_tokens,W2CF_Symtab_Nameof_Ty(TY_pointed(ty)));
01299 #endif
01300     TY2F_translate(decl_tokens,Be_Type_Tbl(Pointer_Mtype));
01301 
01302   } else
01303     TY2F_translate(decl_tokens,TY_pointed(ty));
01304       }
01305    }
01306 } /* TY2F_pointer */
01307 
01308 static void
01309 TY2F_void(TOKEN_BUFFER decl_tokens, TY_IDX ty_idx)
01310 {
01311   TY& ty = Ty_Table[ty_idx];
01312 
01313   ASSERT_DBG_FATAL(TY_kind(ty) == KIND_VOID, 
01314         (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01315          TY_kind(ty), 
01316          "TY2F_void"));
01317 
01318    Prepend_F77_Indented_Newline(decl_tokens, 1, NULL/*label*/);
01319    Prepend_Token_String(decl_tokens, "! <Void Type>");
01320 } /* TY2F_void */
01321 
01322 /*------------------------ exported routines --------------------------*/
01323 /*---------------------------------------------------------------------*/
01324 
01325 void
01326 TY2F_translate(TOKEN_BUFFER tokens, TY_IDX ty)
01327 {
01328    /* Dispatch the translation-task to the appropriate handler function.
01329     */
01330    TY2F_Handler[TY_kind(Ty_Table[ty])](tokens, ty);
01331 } /* TY2F_translate */
01332 
01333 void 
01334 TY2F_Translate_Purple_Array(TOKEN_BUFFER tokens, ST *st, TY_IDX ty)
01335 {
01336    if (TY_Is_Pointer(ty) && TY_ptr_as_array(Ty_Table[ty]))
01337    {
01338       TY2F_Purple_Ptr_As_Array(tokens, st, TY_pointed(ty));
01339    }
01340    else if (Stab_Is_Assumed_Sized_Array(ty))
01341    {
01342       TY2F_Purple_Assumed_Sized_Array(tokens, st, ty);
01343    }
01344    else
01345    {
01346       /* Our regular translator inserts placeholders for adjstable bounds.
01347        */
01348       TY2F_translate(tokens, ty);
01349    }
01350 } /* TY2F_Translate_Purple_Array */
01351 
01352 void 
01353 TY2F_Translate_ArrayElt(TOKEN_BUFFER tokens, 
01354       TY_IDX       arr_ty_idx,
01355       STAB_OFFSET  arr_ofst)
01356 {
01357   TOKEN_BUFFER idx_tokens = New_Token_Buffer();
01358   STAB_OFFSET  idx;
01359   INT32        dim;
01360   ARB_HANDLE   arb;
01361   
01362   ASSERT_FATAL(TY_Is_Array(arr_ty_idx), 
01363          (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01364     TY_kind(arr_ty_idx), "TY2F_Translate_ArrayElt"));
01365   
01366   Append_Token_Special(tokens, '(');
01367   if (TY_Is_Character_String(arr_ty_idx))
01368     {
01369       /* Character strings can only be indexed using the substring notation
01370   */
01371       Append_Token_String(tokens, Number_as_String(arr_ofst+1, "%lld"));
01372       Append_Token_Special(tokens, ':');
01373       Append_Token_String(tokens, Number_as_String(arr_ofst+1, "%lld"));
01374     }
01375   else /* Regular array indexing */
01376     {
01377       /* Emit the indexing expressions for each dimension, taking note
01378        * that Fortran employs column-major array layout, meaning the 
01379        * leftmost indexing expression (dim==0) represents array elements
01380        * layed out in contiguous memory locations.
01381        */
01382 
01383       ARB_HANDLE arb_base = TY_arb(arr_ty_idx);
01384       dim = ARB_dimension(arb_base) - 1 ; 
01385 
01386       while ( dim >= 0)
01387       {
01388   ARB_HANDLE arb = arb_base[dim];
01389 
01390   if (arr_ofst == 0)
01391     {
01392       Prepend_Token_String(idx_tokens, Number_as_String(1LL, "%lld"));
01393     }
01394   else if (ARB_const_stride(arb)) /* Constant stride */
01395     {
01396       idx = arr_ofst/ARB_stride_val(arb) + 1;
01397       Prepend_Token_String(idx_tokens, Number_as_String(idx, "%lld"));
01398       arr_ofst -= (arr_ofst/ARB_stride_val(arb))*ARB_stride_val(arb);
01399     }
01400   else
01401     {
01402       Append_Token_String(idx_tokens, "*");
01403     }
01404   if (dim-- > 0)
01405     Prepend_Token_Special(idx_tokens, ',');
01406       }
01407   Append_And_Reclaim_Token_List(tokens, &idx_tokens);
01408 }
01409 Append_Token_Special(tokens, ')');
01410 } /* TY2F_Translate_ArrayElt */
01411 
01412 void
01413 TY2F_Translate_Common(TOKEN_BUFFER tokens, const char *name, TY_IDX ty_idx)
01414 {
01415   TY& ty = Ty_Table[ty_idx];
01416 
01417   BOOL  is_equiv = FALSE;
01418   
01419   ASSERT_DBG_FATAL(TY_kind(ty) == KIND_STRUCT, 
01420        (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01421         TY_kind(ty), "TY2F_Translate_Common"));
01422 
01423   /* Emit specification statements for every element of the
01424    * common block, including equivalences.
01425    */
01426   TY2F_Declare_Common_Flds(tokens, 
01427          TY_flist(ty),
01428          FALSE, /*alt_return*/
01429          &is_equiv);
01430 
01431   /* Emit the common block specification statement, excluding
01432    * equivalences, where the name is already in a valid form and 
01433    * can be emitted as is without a call to W2CF_Symtab_Nameof_Ty().
01434    */
01435 
01436   Append_Token_String(tokens, "COMMON");
01437   if (name != NULL && *name != '\0')
01438     Append_Token_String(tokens, Concat3_Strings("/", name, "/"));
01439   TY2F_List_Common_Flds(tokens, TY_flist(ty));
01440   
01441   /* Emit equivalences, if there are any */
01442 
01443   if (is_equiv)
01444     TY2F_Equivalence_List(tokens, ty_idx /*struct_ty*/);
01445 
01446 } /* TY2F_Translate_Common */
01447 
01448 
01449 void
01450 TY2F_Translate_Equivalence(TOKEN_BUFFER tokens, TY_IDX ty_idx, BOOL alt_return)
01451 {
01452    /* When alt_return==TRUE, this represents an alternate return variable,
01453     * in which case we should declare the elements of the equivalence
01454     * with unmangled names and ignore the fact that they are in an
01455     * equivalence.  The first element in such an alternate return is
01456     * the function/subprogram return-variable, which we should never
01457     * declare.
01458     */
01459 
01460   TY& ty = Ty_Table[ty_idx];
01461 
01462   FLD_HANDLE first_fld;
01463   BOOL is_equiv;
01464    
01465    ASSERT_DBG_FATAL(TY_kind(ty) == KIND_STRUCT, 
01466         (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01467          TY_kind(ty), "TY2F_Translate_Equivalence"));
01468 
01469    if (alt_return)
01470    {
01471       first_fld = FLD_next(TY_flist(ty)); /* skip func_entry return var */
01472    }
01473    else
01474    {
01475       first_fld = TY_flist(ty);
01476    }
01477 
01478    /* Emit specification statements for every element of the
01479     * equivalence block.
01480     */  
01481    TY2F_Declare_Common_Flds(tokens, 
01482           first_fld,
01483           alt_return,
01484           &is_equiv);  /* Redundant in this call */
01485 
01486    if (!alt_return)
01487       TY2F_Equivalence_List(tokens, ty_idx /*struct_ty*/);
01488 
01489 } /* TY2F_Translate_Equivalence */
01490 
01491 void 
01492 TY2F_Prepend_Structures(TOKEN_BUFFER tokens)
01493 {
01494    if (TY2F_Structure_Decls != NULL)
01495       Prepend_And_Reclaim_Token_List(tokens, &TY2F_Structure_Decls);
01496 } /* TY2F_Prepend_Structures */
01497 
01498 
01499 FLD_PATH_INFO * 
01500 TY2F_Free_Fld_Path(FLD_PATH_INFO *fld_path)
01501 {
01502    FLD_PATH_INFO *free_list;
01503    
01504    if (fld_path != NULL)
01505    {
01506       free_list = Free_Fld_Path_Info;
01507       Free_Fld_Path_Info = fld_path;
01508       while (fld_path->next != NULL)
01509    fld_path = fld_path->next;
01510       fld_path->next = free_list;
01511    }
01512    return NULL;
01513 } /* TY2F_Free_Fld_Path */
01514 
01515 
01516 FLD_PATH_INFO * 
01517 TY2F_Get_Fld_Path(const TY_IDX struct_ty, 
01518       const TY_IDX object_ty,
01519       STAB_OFFSET offset)
01520 {
01521   FLD_PATH_INFO  *fld_path;
01522   FLD_PATH_INFO  *fld_path2 = NULL;
01523   TY & s_ty = Ty_Table[struct_ty] ;
01524   FLD_ITER fld_iter ;
01525   
01526   
01527   ASSERT_DBG_FATAL(TY_kind(s_ty) == KIND_STRUCT,
01528        (DIAG_W2F_UNEXPECTED_TYPE_KIND, 
01529         TY_kind(s_ty),
01530         "TY2F_Get_Fld_Path"));
01531   
01532   /* Get the best matching field path into fld_path2 */
01533 
01534   fld_iter = Make_fld_iter(TY_flist(s_ty));
01535 
01536   do 
01537     {
01538       FLD_HANDLE fld (fld_iter);
01539 
01540       if (NOT_BITFIELD_OR_IS_FIRST_OF_BITFIELD(fld_iter)) 
01541       {
01542   fld_path = Construct_Fld_Path(fld_iter,
01543               struct_ty,
01544               object_ty,
01545               offset,
01546               TY_size(s_ty));
01547   if (fld_path2 == NULL)
01548     fld_path2 = fld_path;
01549   else if (fld_path != NULL)
01550     fld_path2 = Select_Best_Fld_Path(fld_path2,
01551              fld_path,
01552              object_ty,
01553              offset);
01554       }
01555     } while (!FLD_last_field (fld_iter++)) ;
01556 
01557   /* POSTCONDITION: fld_path2 points to the best match found */
01558 
01559   return fld_path2;
01560 
01561 } /* TY2F_Get_Fld_Path */
01562 
01563 void
01564 TY2F_Translate_Fld_Path(TOKEN_BUFFER   tokens,
01565       FLD_PATH_INFO *fld_path, 
01566       BOOL           deref, 
01567       BOOL           member_of_common, 
01568       BOOL           alt_ret_name,
01569       WN2F_CONTEXT   context)
01570 {
01571    /* Append the name of each field to the tokens, separated them
01572     * from each other by the field-selection operator ('.').  The
01573     * first name on the path may optionally be emitted in unclobbered 
01574     * form, as it may represent an alternate return point.
01575     */
01576    while (fld_path != NULL)
01577    {
01578       FLD_HANDLE f (fld_path->fld);
01579       if (deref && TY_Is_Pointer(FLD_type(f)))
01580    Append_Token_String(tokens, W2CF_Symtab_Nameof_Fld_Pointee(f));
01581       else
01582     Append_Token_String(tokens, 
01583             TY2F_Fld_Name(f,
01584               member_of_common,
01585               alt_ret_name));
01586 
01587       member_of_common = FALSE; /* Can only be true first time around */
01588 
01589       /* if an array element, form the subscript list. If an OPC_ARRAY */
01590       /* provides the subscripts, use it o/w use offset                */
01591 
01592       if (fld_path->arr_elt) 
01593   {
01594     if (fld_path->arr_wn != NULL)
01595         WN2F_array_bounds(tokens,fld_path->arr_wn,FLD_type(f),context);   
01596     else
01597         TY2F_Translate_ArrayElt(tokens,FLD_type(f),fld_path->arr_ofst);
01598   }
01599 
01600       /* Separate fields with the dot-notation. */
01601 
01602       fld_path = fld_path->next;
01603       if (fld_path != NULL)
01604       {
01605    TY2F_Fld_Separator(tokens) ;
01606    alt_ret_name = FALSE; /* Only applies to first field on the path */
01607       }
01608     } /* while */
01609 
01610 } /* TY2F_Translate_Fld_Path */
01611 
01612 
01613 
01614 extern void
01615 TY2F_Fld_Separator(TOKEN_BUFFER tokens)
01616 {
01617   /* puts out the appropriate structure component separator*/
01618 
01619   char p = '.' ;
01620 
01621   if (WN2F_F90_pu) 
01622        p =  '%';
01623 
01624   Append_Token_Special(tokens,p);
01625 }
01626 
01627 extern FLD_HANDLE
01628 TY2F_Last_Fld(FLD_PATH_INFO *fld_path)
01629 {
01630   FLD_HANDLE f = FLD_HANDLE () ;
01631 
01632   while (fld_path != NULL)
01633     {
01634       f = fld_path->fld;
01635       fld_path = fld_path->next ;
01636     }
01637 
01638   return f ;
01639 }
01640 
01641 extern FLD_PATH_INFO * 
01642 TY2F_Point_At_Path(FLD_PATH_INFO * path, STAB_OFFSET off)
01643 {
01644   /* given a fld path, return a pointer to */
01645   /* the slot at the given offset          */
01646 
01647   while (path != NULL)
01648   {
01649     if (FLD_ofst(path->fld) >= off)
01650       break ;
01651 
01652     path=path->next;
01653   }
01654   return path;
01655 }
01656 
01657 extern void
01658 TY2F_Dump_Fld_Path(FLD_PATH_INFO *fld_path)
01659 {
01660   printf ("path ::");
01661   while (fld_path != NULL)
01662     {
01663       FLD_HANDLE f = fld_path->fld;
01664 
01665       printf ("%s(#%d)",TY2F_Fld_Name(f,FALSE,FALSE),f.Idx ());
01666 
01667       if (fld_path->arr_elt)
01668   printf (" array");
01669 
01670       if (fld_path->arr_ofst)
01671   printf (" offset 0x%x",(mINT32) fld_path->arr_ofst);
01672 
01673       if (fld_path->arr_wn != NULL)
01674   printf (" tree 0x%p",fld_path->arr_wn);
01675 
01676       printf (" ::");
01677       fld_path = fld_path->next ;
01678     }
01679   printf ("\n");
01680 }
01681