osprey/kgccfe/gnu/f/com.c

Go to the documentation of this file.

/* com.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

   Related Modules:
      None

   Description:
      Contains compiler-specific functions.

   Modifications:
*/

/* Understanding this module means understanding the interface between
   the g77 front end and the gcc back end (or, perhaps, some other
   back end).  In here are the functions called by the front end proper
   to notify whatever back end is in place about certain things, and
   also the back-end-specific functions.  It's a bear to deal with, so
   lately I've been trying to simplify things, especially with regard
   to the gcc-back-end-specific stuff.

   Building expressions generally seems quite easy, but building decls
   has been challenging and is undergoing revision.  gcc has several
   kinds of decls:

   TYPE_DECL -- a type (int, float, struct, function, etc.)
   CONST_DECL -- a constant of some type other than function
   LABEL_DECL -- a variable or a constant?
   PARM_DECL -- an argument to a function (a variable that is a dummy)
   RESULT_DECL -- the return value of a function (a variable)
   VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
   FUNCTION_DECL -- a function (either the actual function or an extern ref)
   FIELD_DECL -- a field in a struct or union (goes into types)

   g77 has a set of functions that somewhat parallels the gcc front end
   when it comes to building decls:

   Internal Function (one we define, not just declare as extern):
   if (is_nested) push_f_function_context ();
   start_function (get_identifier ("function_name"), function_type,
       is_nested, is_public);
   // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
   store_parm_decls (is_main_program);
   ffecom_start_compstmt ();
   // for stmts and decls inside function, do appropriate things;
   ffecom_end_compstmt ();
   finish_function (is_nested);
   if (is_nested) pop_f_function_context ();

   Everything Else:
   tree d;
   tree init;
   // fill in external, public, static, &c for decl, and
   // set DECL_INITIAL to error_mark_node if going to initialize
   // set is_top_level TRUE only if not at top level and decl
   // must go in top level (i.e. not within current function decl context)
   d = start_decl (decl, is_top_level);
   init = ...;  // if have initializer
   finish_decl (d, init, is_top_level);

*/

/* Include files. */

#include "proj.h"
#include "flags.h"
#include "rtl.h"
#include "toplev.h"
#include "tree.h"
#include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
#include "convert.h"
#include "ggc.h"
#include "diagnostic.h"
#include "intl.h"
#include "langhooks.h"
#include "langhooks-def.h"

/* VMS-specific definitions */
#ifdef VMS
#include <descrip.h>
#define O_RDONLY  0 /* Open arg for Read/Only  */
#define O_WRONLY  1 /* Open arg for Write/Only */
#define read(fd,buf,size) VMS_read (fd,buf,size)
#define write(fd,buf,size)  VMS_write (fd,buf,size)
#define open(fname,mode,prot) VMS_open (fname,mode,prot)
#define fopen(fname,mode) VMS_fopen (fname,mode)
#define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
#define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
#define fstat(fd,stbuf)   VMS_fstat (fd,stbuf)
static int VMS_fstat (), VMS_stat ();
static char * VMS_strncat ();
static int VMS_read ();
static int VMS_write ();
static int VMS_open ();
static FILE * VMS_fopen ();
static FILE * VMS_freopen ();
static void hack_vms_include_specification ();
typedef struct { unsigned :16, :16, :16; } vms_ino_t;
#define ino_t vms_ino_t
#define INCLUDE_LEN_FUDGE 10  /* leave room for VMS syntax conversion */
#endif /* VMS */

#define FFECOM_DETERMINE_TYPES 1 /* for com.h */
#include "com.h"
#include "bad.h"
#include "bld.h"
#include "equiv.h"
#include "expr.h"
#include "implic.h"
#include "info.h"
#include "malloc.h"
#include "src.h"
#include "st.h"
#include "storag.h"
#include "symbol.h"
#include "target.h"
#include "top.h"
#include "type.h"

/* Externals defined here.  */

/* Stream for reading from the input file.  */
FILE *finput;

/* These definitions parallel those in c-decl.c so that code from that
   module can be used pretty much as is.  Much of these defs aren't
   otherwise used, i.e. by g77 code per se, except some of them are used
   to build some of them that are.  The ones that are global (i.e. not
   "static") are those that ste.c and such might use (directly
   or by using com macros that reference them in their definitions).  */

tree string_type_node;

/* The rest of these are inventions for g77, though there might be
   similar things in the C front end.  As they are found, these
   inventions should be renamed to be canonical.  Note that only
   the ones currently required to be global are so.  */

static tree ffecom_tree_fun_type_void;

tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
tree ffecom_integer_one_node; /* " */
tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];

/* _fun_type things are the f2c-specific versions.  For -fno-f2c,
   just use build_function_type and build_pointer_type on the
   appropriate _tree_type array element.  */

static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
static tree ffecom_tree_subr_type;
static tree ffecom_tree_ptr_to_subr_type;
static tree ffecom_tree_blockdata_type;

static tree ffecom_tree_xargc_;

ffecomSymbol ffecom_symbol_null_
=
{
  NULL_TREE,
  NULL_TREE,
  NULL_TREE,
  NULL_TREE,
  false
};
ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;

int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
tree ffecom_f2c_integer_type_node;
tree ffecom_f2c_ptr_to_integer_type_node;
tree ffecom_f2c_address_type_node;
tree ffecom_f2c_real_type_node;
tree ffecom_f2c_ptr_to_real_type_node;
tree ffecom_f2c_doublereal_type_node;
tree ffecom_f2c_complex_type_node;
tree ffecom_f2c_doublecomplex_type_node;
tree ffecom_f2c_longint_type_node;
tree ffecom_f2c_logical_type_node;
tree ffecom_f2c_flag_type_node;
tree ffecom_f2c_ftnlen_type_node;
tree ffecom_f2c_ftnlen_zero_node;
tree ffecom_f2c_ftnlen_one_node;
tree ffecom_f2c_ftnlen_two_node;
tree ffecom_f2c_ptr_to_ftnlen_type_node;
tree ffecom_f2c_ftnint_type_node;
tree ffecom_f2c_ptr_to_ftnint_type_node;

/* Simple definitions and enumerations. */

#ifndef FFECOM_sizeMAXSTACKITEM
#define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
             larger than this # bytes
             off stack if possible. */
#endif

/* For systems that have large enough stacks, they should define
   this to 0, and here, for ease of use later on, we just undefine
   it if it is 0.  */

#if FFECOM_sizeMAXSTACKITEM == 0
#undef FFECOM_sizeMAXSTACKITEM
#endif

typedef enum
  {
    FFECOM_rttypeVOID_,
    FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
    FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
    FFECOM_rttypeINTEGER_,  /* f2c's `integer' type. */
    FFECOM_rttypeLONGINT_,  /* f2c's `longint' type. */
    FFECOM_rttypeLOGICAL_,  /* f2c's `logical' type. */
    FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
    FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
    FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
    FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
    FFECOM_rttypeDOUBLE_, /* C's `double' type. */
    FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
    FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
    FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
    FFECOM_rttypeCHARACTER_,  /* f2c `char *'/`ftnlen' pair. */
    FFECOM_rttype_
  } ffecomRttype_;

/* Internal typedefs. */

typedef struct _ffecom_concat_list_ ffecomConcatList_;

/* Private include files. */


/* Internal structure definitions. */

struct _ffecom_concat_list_
  {
    ffebld *exprs;
    int count;
    int max;
    ffetargetCharacterSize minlen;
    ffetargetCharacterSize maxlen;
  };

/* Static functions (internal). */

static void ffecom_init_decl_processing PARAMS ((void));
static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
static tree ffecom_widest_expr_type_ (ffebld list);
static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
           tree dest_size, tree source_tree,
           ffebld source, bool scalar_arg);
static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
              tree args, tree callee_commons,
              bool scalar_args);
static tree ffecom_build_f2c_string_ (int i, const char *s);
static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
        bool is_f2c_complex, tree type,
        tree args, tree dest_tree,
        ffebld dest, bool *dest_used,
        tree callee_commons, bool scalar_args, tree hook);
static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
        bool is_f2c_complex, tree type,
        ffebld left, ffebld right,
        tree dest_tree, ffebld dest,
        bool *dest_used, tree callee_commons,
        bool scalar_args, bool ref, tree hook);
static void ffecom_char_args_x_ (tree *xitem, tree *length,
         ffebld expr, bool with_null);
static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
static ffecomConcatList_
  ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
            ffebld expr,
            ffetargetCharacterSize max);
static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
            ffetargetCharacterSize max);
static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
          ffesymbol member, tree member_type,
          ffetargetOffset offset);
static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
        bool *dest_used, bool assignp, bool widenp);
static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
            ffebld dest, bool *dest_used);
static tree ffecom_expr_power_integer_ (ffebld expr);
static void ffecom_expr_transform_ (ffebld expr);
static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
              int code);
static ffeglobal ffecom_finish_global_ (ffeglobal global);
static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
static tree ffecom_get_appended_identifier_ (char us, const char *text);
static tree ffecom_get_external_identifier_ (ffesymbol s);
static tree ffecom_get_identifier_ (const char *text);
static tree ffecom_gen_sfuncdef_ (ffesymbol s,
          ffeinfoBasictype bt,
          ffeinfoKindtype kt);
static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
static tree ffecom_init_zero_ (tree decl);
static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
             tree *maybe_tree);
static tree ffecom_intrinsic_len_ (ffebld expr);
static void ffecom_let_char_ (tree dest_tree,
            tree dest_length,
            ffetargetCharacterSize dest_size,
            ffebld source);
static void ffecom_make_gfrt_ (ffecomGfrt ix);
static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
              ffebld source);
static void ffecom_push_dummy_decls_ (ffebld dumlist,
              bool stmtfunc);
static void ffecom_start_progunit_ (void);
static ffesymbol ffecom_sym_transform_ (ffesymbol s);
static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
static void ffecom_transform_common_ (ffesymbol s);
static void ffecom_transform_equiv_ (ffestorag st);
static tree ffecom_transform_namelist_ (ffesymbol s);
static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
               tree t);
static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
               tree *size, tree tree);
static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
         tree dest_tree, ffebld dest,
         bool *dest_used, tree hook);
static tree ffecom_type_localvar_ (ffesymbol s,
           ffeinfoBasictype bt,
           ffeinfoKindtype kt);
static tree ffecom_type_namelist_ (void);
static tree ffecom_type_vardesc_ (void);
static tree ffecom_vardesc_ (ffebld expr);
static tree ffecom_vardesc_array_ (ffesymbol s);
static tree ffecom_vardesc_dims_ (ffesymbol s);
static tree ffecom_convert_narrow_ (tree type, tree expr);
static tree ffecom_convert_widen_ (tree type, tree expr);

/* These are static functions that parallel those found in the C front
   end and thus have the same names.  */

static tree bison_rule_compstmt_ (void);
static void bison_rule_pushlevel_ (void);
static void delete_block (tree block);
static int duplicate_decls (tree newdecl, tree olddecl);
static void finish_decl (tree decl, tree init, bool is_top_level);
static void finish_function (int nested);
static const char *lang_printable_name (tree decl, int v);
static tree lookup_name_current_level (tree name);
static struct binding_level *make_binding_level (void);
static void pop_f_function_context (void);
static void push_f_function_context (void);
static void push_parm_decl (tree parm);
static tree pushdecl_top_level (tree decl);
static int kept_level_p (void);
static tree storedecls (tree decls);
static void store_parm_decls (int is_main_program);
static tree start_decl (tree decl, bool is_top_level);
static void start_function (tree name, tree type, int nested, int public);
static void ffecom_file_ (const char *name);
static void ffecom_close_include_ (FILE *f);
static int ffecom_decode_include_option_ (char *spec);
static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
           ffewhereColumn c);

/* Static objects accessed by functions in this module. */

static ffesymbol ffecom_primary_entry_ = NULL;
static ffesymbol ffecom_nested_entry_ = NULL;
static ffeinfoKind ffecom_primary_entry_kind_;
static bool ffecom_primary_entry_is_proc_;
static tree ffecom_outer_function_decl_;
static tree ffecom_previous_function_decl_;
static tree ffecom_which_entrypoint_decl_;
static tree ffecom_float_zero_ = NULL_TREE;
static tree ffecom_float_half_ = NULL_TREE;
static tree ffecom_double_zero_ = NULL_TREE;
static tree ffecom_double_half_ = NULL_TREE;
static tree ffecom_func_result_;/* For functions. */
static tree ffecom_func_length_;/* For CHARACTER fns. */
static ffebld ffecom_list_blockdata_;
static ffebld ffecom_list_common_;
static ffebld ffecom_master_arglist_;
static ffeinfoBasictype ffecom_master_bt_;
static ffeinfoKindtype ffecom_master_kt_;
static ffetargetCharacterSize ffecom_master_size_;
static int ffecom_num_fns_ = 0;
static int ffecom_num_entrypoints_ = 0;
static bool ffecom_is_altreturning_ = FALSE;
static tree ffecom_multi_type_node_;
static tree ffecom_multi_retval_;
static tree
  ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
static bool ffecom_doing_entry_ = FALSE;
static bool ffecom_transform_only_dummies_ = FALSE;
static int ffecom_typesize_pointer_;
static int ffecom_typesize_integer1_;

/* Holds pointer-to-function expressions.  */

static tree ffecom_gfrt_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
#include "com-rt.def"
#undef DEFGFRT
};

/* Holds the external names of the functions.  */

static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
#include "com-rt.def"
#undef DEFGFRT
};

/* Whether the function returns.  */

static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
#include "com-rt.def"
#undef DEFGFRT
};

/* Whether the function returns type complex.  */

static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
#include "com-rt.def"
#undef DEFGFRT
};

/* Whether the function is const
   (i.e., has no side effects and only depends on its arguments).  */

static const bool ffecom_gfrt_const_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
#include "com-rt.def"
#undef DEFGFRT
};

/* Type code for the function return value.  */

static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
#include "com-rt.def"
#undef DEFGFRT
};

/* String of codes for the function's arguments.  */

static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
#include "com-rt.def"
#undef DEFGFRT
};

/* Internal macros. */

/* We let tm.h override the types used here, to handle trivial differences
   such as the choice of unsigned int or long unsigned int for size_t.
   When machines start needing nontrivial differences in the size type,
   it would be best to do something here to figure out automatically
   from other information what type to use.  */

#ifndef SIZE_TYPE
#define SIZE_TYPE "long unsigned int"
#endif

#define ffecom_concat_list_count_(catlist) ((catlist).count)
#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)

#define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)

/* For each binding contour we allocate a binding_level structure
 * which records the names defined in that contour.
 * Contours include:
 *  0) the global one
 *  1) one for each function definition,
 *     where internal declarations of the parameters appear.
 *
 * The current meaning of a name can be found by searching the levels from
 * the current one out to the global one.
 */

/* Note that the information in the `names' component of the global contour
   is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */

struct binding_level
  {
    /* A chain of _DECL nodes for all variables, constants, functions,
       and typedef types.  These are in the reverse of the order supplied.
     */
    tree names;

    /* For each level (except not the global one),
       a chain of BLOCK nodes for all the levels
       that were entered and exited one level down.  */
    tree blocks;

    /* The BLOCK node for this level, if one has been preallocated.
       If 0, the BLOCK is allocated (if needed) when the level is popped.  */
    tree this_block;

    /* The binding level which this one is contained in (inherits from).  */
    struct binding_level *level_chain;

    /* 0: no ffecom_prepare_* functions called at this level yet;
       1: ffecom_prepare* functions called, except not ffecom_prepare_end;
       2: ffecom_prepare_end called.  */
    int prep_state;
  };

#define NULL_BINDING_LEVEL (struct binding_level *) NULL

/* The binding level currently in effect.  */

static struct binding_level *current_binding_level;

/* A chain of binding_level structures awaiting reuse.  */

static struct binding_level *free_binding_level;

/* The outermost binding level, for names of file scope.
   This is created when the compiler is started and exists
   through the entire run.  */

static struct binding_level *global_binding_level;

/* Binding level structures are initialized by copying this one.  */

static const struct binding_level clear_binding_level
=
{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};

/* Language-dependent contents of an identifier.  */

struct lang_identifier
  {
    struct tree_identifier ignore;
    tree global_value, local_value, label_value;
    bool invented;
  };

/* Macros for access to language-specific slots in an identifier.  */
/* Each of these slots contains a DECL node or null.  */

/* This represents the value which the identifier has in the
   file-scope namespace.  */
#define IDENTIFIER_GLOBAL_VALUE(NODE) \
  (((struct lang_identifier *)(NODE))->global_value)
/* This represents the value which the identifier has in the current
   scope.  */
#define IDENTIFIER_LOCAL_VALUE(NODE)  \
  (((struct lang_identifier *)(NODE))->local_value)
/* This represents the value which the identifier has as a label in
   the current label scope.  */
#define IDENTIFIER_LABEL_VALUE(NODE)  \
  (((struct lang_identifier *)(NODE))->label_value)
/* This is nonzero if the identifier was "made up" by g77 code.  */
#define IDENTIFIER_INVENTED(NODE) \
  (((struct lang_identifier *)(NODE))->invented)

/* In identifiers, C uses the following fields in a special way:
   TREE_PUBLIC        to record that there was a previous local extern decl.
   TREE_USED        to record that such a decl was used.
   TREE_ADDRESSABLE   to record that the address of such a decl was used.  */

/* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
   that have names.  Here so we can clear out their names' definitions
   at the end of the function.  */

static tree named_labels;

/* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */

static tree shadowed_labels;

/* Return the subscript expression, modified to do range-checking.

   `array' is the array to be checked against.
   `element' is the subscript expression to check.
   `dim' is the dimension number (starting at 0).
   `total_dims' is the total number of dimensions (0 for CHARACTER substring).
*/

static tree
ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
       const char *array_name)
{
  tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
  tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
  tree cond;
  tree die;
  tree args;

  if (element == error_mark_node)
    return element;

  if (TREE_TYPE (low) != TREE_TYPE (element))
    {
      if (TYPE_PRECISION (TREE_TYPE (low))
    > TYPE_PRECISION (TREE_TYPE (element)))
  element = convert (TREE_TYPE (low), element);
      else
  {
    low = convert (TREE_TYPE (element), low);
    if (high)
      high = convert (TREE_TYPE (element), high);
  }
    }

  element = ffecom_save_tree (element);
  if (total_dims == 0)
    {
      /* Special handling for substring range checks.  Fortran allows the
         end subscript < begin subscript, which means that expressions like
       string(1:0) are valid (and yield a null string).  In view of this,
       enforce two simpler conditions:
          1) element<=high for end-substring;
          2) element>=low for start-substring.
       Run-time character movement will enforce remaining conditions.

       More complicated checks would be better, but present structure only
       provides one index element at a time, so it is not possible to
       enforce a check of both i and j in string(i:j).  If it were, the
       complete set of rules would read,
         if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
              ((low<=i<=high) && (low<=j<=high)) )
           ok ;
         else
           range error ;
      */
      if (dim)
        cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
      else
        cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
    }
  else
    {
      /* Array reference substring range checking.  */

      cond = ffecom_2 (LE_EXPR, integer_type_node,
                     low,
                     element);
      if (high)
        {
          cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
                         cond,
                         ffecom_2 (LE_EXPR, integer_type_node,
                                   element,
                                   high));
        }
    }

  {
    int len;
    char *proc;
    char *var;
    tree arg3;
    tree arg2;
    tree arg1;
    tree arg4;

    switch (total_dims)
      {
      case 0:
  var = concat (array_name, "[", (dim ? "end" : "start"),
          "-substring]", NULL);
  len = strlen (var) + 1;
  arg1 = build_string (len, var);
  free (var);
  break;

      case 1:
  len = strlen (array_name) + 1;
  arg1 = build_string (len, array_name);
  break;

      default:
  var = xmalloc (strlen (array_name) + 40);
  sprintf (var, "%s[subscript-%d-of-%d]",
     array_name,
     dim + 1, total_dims);
  len = strlen (var) + 1;
  arg1 = build_string (len, var);
  free (var);
  break;
      }

    TREE_TYPE (arg1)
      = build_type_variant (build_array_type (char_type_node,
                build_range_type
                (integer_type_node,
                 integer_one_node,
                 build_int_2 (len, 0))),
          1, 0);
    TREE_CONSTANT (arg1) = 1;
    TREE_STATIC (arg1) = 1;
    arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
         arg1);

    /* s_rnge adds one to the element to print it, so bias against
       that -- want to print a faithful *subscript* value.  */
    arg2 = convert (ffecom_f2c_ftnint_type_node,
        ffecom_2 (MINUS_EXPR,
            TREE_TYPE (element),
            element,
            convert (TREE_TYPE (element),
               integer_one_node)));

    proc = concat (input_filename, "/",
       IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
       NULL);
    len = strlen (proc) + 1;
    arg3 = build_string (len, proc);

    free (proc);

    TREE_TYPE (arg3)
      = build_type_variant (build_array_type (char_type_node,
                build_range_type
                (integer_type_node,
                 integer_one_node,
                 build_int_2 (len, 0))),
          1, 0);
    TREE_CONSTANT (arg3) = 1;
    TREE_STATIC (arg3) = 1;
    arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
         arg3);

    arg4 = convert (ffecom_f2c_ftnint_type_node,
        build_int_2 (lineno, 0));

    arg1 = build_tree_list (NULL_TREE, arg1);
    arg2 = build_tree_list (NULL_TREE, arg2);
    arg3 = build_tree_list (NULL_TREE, arg3);
    arg4 = build_tree_list (NULL_TREE, arg4);
    TREE_CHAIN (arg3) = arg4;
    TREE_CHAIN (arg2) = arg3;
    TREE_CHAIN (arg1) = arg2;

    args = arg1;
  }
  die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
        args, NULL_TREE);
  TREE_SIDE_EFFECTS (die) = 1;

  element = ffecom_3 (COND_EXPR,
          TREE_TYPE (element),
          cond,
          element,
          die);

  return element;
}

/* Return the computed element of an array reference.

   `item' is NULL_TREE, or the transformed pointer to the array.
   `expr' is the original opARRAYREF expression, which is transformed
     if `item' is NULL_TREE.
   `want_ptr' is non-zero if a pointer to the element, instead of
     the element itself, is to be returned.  */

static tree
ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
{
  ffebld dims[FFECOM_dimensionsMAX];
  int i;
  int total_dims;
  int flatten = ffe_is_flatten_arrays ();
  int need_ptr;
  tree array;
  tree element;
  tree tree_type;
  tree tree_type_x;
  const char *array_name;
  ffetype type;
  ffebld list;

  if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
    array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
  else
    array_name = "[expr?]";

  /* Build up ARRAY_REFs in reverse order (since we're column major
     here in Fortran land). */

  for (i = 0, list = ffebld_right (expr);
       list != NULL;
       ++i, list = ffebld_trail (list))
    {
      dims[i] = ffebld_head (list);
      type = ffeinfo_type (ffebld_basictype (dims[i]),
         ffebld_kindtype (dims[i]));
      if (! flatten
    && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
    && ffetype_size (type) > ffecom_typesize_integer1_)
  /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
     pointers and 32-bit integers.  Do the full 64-bit pointer
     arithmetic, for codes using arrays for nonstandard heap-like
     work.  */
  flatten = 1;
    }

  total_dims = i;

  need_ptr = want_ptr || flatten;

  if (! item)
    {
      if (need_ptr)
  item = ffecom_ptr_to_expr (ffebld_left (expr));
      else
  item = ffecom_expr (ffebld_left (expr));

      if (item == error_mark_node)
  return item;

      if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
    && ! mark_addressable (item))
  return error_mark_node;
    }

  if (item == error_mark_node)
    return item;

  if (need_ptr)
    {
      tree min;

      for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
     i >= 0;
     --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
  {
    min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
    element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
    if (flag_bounds_check)
      element = ffecom_subscript_check_ (array, element, i, total_dims,
                 array_name);
    if (element == error_mark_node)
      return element;

    /* Widen integral arithmetic as desired while preserving
       signedness.  */
    tree_type = TREE_TYPE (element);
    tree_type_x = tree_type;
    if (tree_type
        && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
        && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
      tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);

    if (TREE_TYPE (min) != tree_type_x)
      min = convert (tree_type_x, min);
    if (TREE_TYPE (element) != tree_type_x)
      element = convert (tree_type_x, element);

    item = ffecom_2 (PLUS_EXPR,
         build_pointer_type (TREE_TYPE (array)),
         item,
         size_binop (MULT_EXPR,
               size_in_bytes (TREE_TYPE (array)),
               convert (sizetype,
            fold (build (MINUS_EXPR,
                   tree_type_x,
                   element, min)))));
  }
      if (! want_ptr)
  {
    item = ffecom_1 (INDIRECT_REF,
         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
         item);
  }
    }
  else
    {
      for (--i;
     i >= 0;
     --i)
  {
    array = TYPE_MAIN_VARIANT (TREE_TYPE (item));

    element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
    if (flag_bounds_check)
      element = ffecom_subscript_check_ (array, element, i, total_dims,
                 array_name);
    if (element == error_mark_node)
      return element;

    /* Widen integral arithmetic as desired while preserving
       signedness.  */
    tree_type = TREE_TYPE (element);
    tree_type_x = tree_type;
    if (tree_type
        && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
        && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
      tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);

    element = convert (tree_type_x, element);

    item = ffecom_2 (ARRAY_REF,
         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
         item,
         element);
  }
    }

  return item;
}

/* This is like gcc's stabilize_reference -- in fact, most of the code
   comes from that -- but it handles the situation where the reference
   is going to have its subparts picked at, and it shouldn't change
   (or trigger extra invocations of functions in the subtrees) due to
   this.  save_expr is a bit overzealous, because we don't need the
   entire thing calculated and saved like a temp.  So, for DECLs, no
   change is needed, because these are stable aggregates, and ARRAY_REF
   and such might well be stable too, but for things like calculations,
   we do need to calculate a snapshot of a value before picking at it.  */

static tree
ffecom_stabilize_aggregate_ (tree ref)
{
  tree result;
  enum tree_code code = TREE_CODE (ref);

  switch (code)
    {
    case VAR_DECL:
    case PARM_DECL:
    case RESULT_DECL:
      /* No action is needed in this case.  */
      return ref;

    case NOP_EXPR:
    case CONVERT_EXPR:
    case FLOAT_EXPR:
    case FIX_TRUNC_EXPR:
    case FIX_FLOOR_EXPR:
    case FIX_ROUND_EXPR:
    case FIX_CEIL_EXPR:
      result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
      break;

    case INDIRECT_REF:
      result = build_nt (INDIRECT_REF,
       stabilize_reference_1 (TREE_OPERAND (ref, 0)));
      break;

    case COMPONENT_REF:
      result = build_nt (COMPONENT_REF,
       stabilize_reference (TREE_OPERAND (ref, 0)),
       TREE_OPERAND (ref, 1));
      break;

    case BIT_FIELD_REF:
      result = build_nt (BIT_FIELD_REF,
       stabilize_reference (TREE_OPERAND (ref, 0)),
       stabilize_reference_1 (TREE_OPERAND (ref, 1)),
       stabilize_reference_1 (TREE_OPERAND (ref, 2)));
      break;

    case ARRAY_REF:
      result = build_nt (ARRAY_REF,
       stabilize_reference (TREE_OPERAND (ref, 0)),
       stabilize_reference_1 (TREE_OPERAND (ref, 1)));
      break;

    case COMPOUND_EXPR:
      result = build_nt (COMPOUND_EXPR,
       stabilize_reference_1 (TREE_OPERAND (ref, 0)),
       stabilize_reference (TREE_OPERAND (ref, 1)));
      break;

    case RTL_EXPR:
      abort ();


    default:
      return save_expr (ref);

    case ERROR_MARK:
      return error_mark_node;
    }

  TREE_TYPE (result) = TREE_TYPE (ref);
  TREE_READONLY (result) = TREE_READONLY (ref);
  TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
  TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);

  return result;
}

/* A rip-off of gcc's convert.c convert_to_complex function,
   reworked to handle complex implemented as C structures
   (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */

static tree
ffecom_convert_to_complex_ (tree type, tree expr)
{
  register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
  tree subtype;

  assert (TREE_CODE (type) == RECORD_TYPE);

  subtype = TREE_TYPE (TYPE_FIELDS (type));

  if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
    {
      expr = convert (subtype, expr);
      return ffecom_2 (COMPLEX_EXPR, type, expr,
           convert (subtype, integer_zero_node));
    }

  if (form == RECORD_TYPE)
    {
      tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
      if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
  return expr;
      else
  {
    expr = save_expr (expr);
    return ffecom_2 (COMPLEX_EXPR,
         type,
         convert (subtype,
            ffecom_1 (REALPART_EXPR,
                TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
                expr)),
         convert (subtype,
            ffecom_1 (IMAGPART_EXPR,
                TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
                expr)));
  }
    }

  if (form == POINTER_TYPE || form == REFERENCE_TYPE)
    error ("pointer value used where a complex was expected");
  else
    error ("aggregate value used where a complex was expected");

  return ffecom_2 (COMPLEX_EXPR, type,
       convert (subtype, integer_zero_node),
       convert (subtype, integer_zero_node));
}

/* Like gcc's convert(), but crashes if widening might happen.  */

static tree
ffecom_convert_narrow_ (type, expr)
     tree type, expr;
{
  register tree e = expr;
  register enum tree_code code = TREE_CODE (type);

  if (type == TREE_TYPE (e)
      || TREE_CODE (e) == ERROR_MARK)
    return e;
  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
    return fold (build1 (NOP_EXPR, type, e));
  if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
      || code == ERROR_MARK)
    return error_mark_node;
  if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
    {
      assert ("void value not ignored as it ought to be" == NULL);
      return error_mark_node;
    }
  assert (code != VOID_TYPE);
  if ((code != RECORD_TYPE)
      && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
    assert ("converting COMPLEX to REAL" == NULL);
  assert (code != ENUMERAL_TYPE);
  if (code == INTEGER_TYPE)
    {
      assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
         && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
        || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
      && (TYPE_PRECISION (type)
          == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
      return fold (convert_to_integer (type, e));
    }
  if (code == POINTER_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
      return fold (convert_to_pointer (type, e));
    }
  if (code == REAL_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
      assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
      return fold (convert_to_real (type, e));
    }
  if (code == COMPLEX_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
      assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
      return fold (convert_to_complex (type, e));
    }
  if (code == RECORD_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
      /* Check that at least the first field name agrees.  */
      assert (DECL_NAME (TYPE_FIELDS (type))
        == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
      assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
        <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
      if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
    == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
  return e;
      return fold (ffecom_convert_to_complex_ (type, e));
    }

  assert ("conversion to non-scalar type requested" == NULL);
  return error_mark_node;
}

/* Like gcc's convert(), but crashes if narrowing might happen.  */

static tree
ffecom_convert_widen_ (type, expr)
     tree type, expr;
{
  register tree e = expr;
  register enum tree_code code = TREE_CODE (type);

  if (type == TREE_TYPE (e)
      || TREE_CODE (e) == ERROR_MARK)
    return e;
  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
    return fold (build1 (NOP_EXPR, type, e));
  if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
      || code == ERROR_MARK)
    return error_mark_node;
  if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
    {
      assert ("void value not ignored as it ought to be" == NULL);
      return error_mark_node;
    }
  assert (code != VOID_TYPE);
  if ((code != RECORD_TYPE)
      && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
    assert ("narrowing COMPLEX to REAL" == NULL);
  assert (code != ENUMERAL_TYPE);
  if (code == INTEGER_TYPE)
    {
      assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
         && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
        || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
      && (TYPE_PRECISION (type)
          == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
      return fold (convert_to_integer (type, e));
    }
  if (code == POINTER_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
      return fold (convert_to_pointer (type, e));
    }
  if (code == REAL_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
      assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
      return fold (convert_to_real (type, e));
    }
  if (code == COMPLEX_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
      assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
      return fold (convert_to_complex (type, e));
    }
  if (code == RECORD_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
      /* Check that at least the first field name agrees.  */
      assert (DECL_NAME (TYPE_FIELDS (type))
        == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
      assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
        >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
      if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
    == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
  return e;
      return fold (ffecom_convert_to_complex_ (type, e));
    }

  assert ("conversion to non-scalar type requested" == NULL);
  return error_mark_node;
}

/* Handles making a COMPLEX type, either the standard
   (but buggy?) gbe way, or the safer (but less elegant?)
   f2c way.  */

static tree
ffecom_make_complex_type_ (tree subtype)
{
  tree type;
  tree realfield;
  tree imagfield;

  if (ffe_is_emulate_complex ())
    {
      type = make_node (RECORD_TYPE);
      realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
      imagfield = ffecom_decl_field (type, realfield, "i", subtype);
      TYPE_FIELDS (type) = realfield;
      layout_type (type);
    }
  else
    {
      type = make_node (COMPLEX_TYPE);
      TREE_TYPE (type) = subtype;
      layout_type (type);
    }

  return type;
}

/* Chooses either the gbe or the f2c way to build a
   complex constant.  */

static tree
ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
{
  tree bothparts;

  if (ffe_is_emulate_complex ())
    {
      bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
      TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
      bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
    }
  else
    {
      bothparts = build_complex (type, realpart, imagpart);
    }

  return bothparts;
}

static tree
ffecom_arglist_expr_ (const char *c, ffebld expr)
{
  tree list;
  tree *plist = &list;
  tree trail = NULL_TREE; /* Append char length args here. */
  tree *ptrail = &trail;
  tree length;
  ffebld exprh;
  tree item;
  bool ptr = FALSE;
  tree wanted = NULL_TREE;
  static const char zed[] = "0";

  if (c == NULL)
    c = &zed[0];

  while (expr != NULL)
    {
      if (*c != '\0')
  {
    ptr = FALSE;
    if (*c == '&')
      {
        ptr = TRUE;
        ++c;
      }
    switch (*(c++))
      {
      case '\0':
        ptr = TRUE;
        wanted = NULL_TREE;
        break;

      case 'a':
        assert (ptr);
        wanted = NULL_TREE;
        break;

      case 'c':
        wanted = ffecom_f2c_complex_type_node;
        break;

      case 'd':
        wanted = ffecom_f2c_doublereal_type_node;
        break;

      case 'e':
        wanted = ffecom_f2c_doublecomplex_type_node;
        break;

      case 'f':
        wanted = ffecom_f2c_real_type_node;
        break;

      case 'i':
        wanted = ffecom_f2c_integer_type_node;
        break;

      case 'j':
        wanted = ffecom_f2c_longint_type_node;
        break;

      default:
        assert ("bad argstring code" == NULL);
        wanted = NULL_TREE;
        break;
      }
  }

      exprh = ffebld_head (expr);
      if (exprh == NULL)
  wanted = NULL_TREE;

      if ((wanted == NULL_TREE)
    || (ptr
        && (TYPE_MODE
      (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
       [ffeinfo_kindtype (ffebld_info (exprh))])
       == TYPE_MODE (wanted))))
  *plist
    = build_tree_list (NULL_TREE,
           ffecom_arg_ptr_to_expr (exprh,
                 &length));
      else
  {
    item = ffecom_arg_expr (exprh, &length);
    item = ffecom_convert_widen_ (wanted, item);
    if (ptr)
      {
        item = ffecom_1 (ADDR_EXPR,
             build_pointer_type (TREE_TYPE (item)),
             item);
      }
    *plist
      = build_tree_list (NULL_TREE,
             item);
  }

      plist = &TREE_CHAIN (*plist);
      expr = ffebld_trail (expr);
      if (length != NULL_TREE)
  {
    *ptrail = build_tree_list (NULL_TREE, length);
    ptrail = &TREE_CHAIN (*ptrail);
  }
    }

  /* We've run out of args in the call; if the implementation expects
     more, supply null pointers for them, which the implementation can
     check to see if an arg was omitted. */

  while (*c != '\0' && *c != '0')
    {
      if (*c == '&')
  ++c;
      else
  assert ("missing arg to run-time routine!" == NULL);

      switch (*(c++))
  {
  case '\0':
  case 'a':
  case 'c':
  case 'd':
  case 'e':
  case 'f':
  case 'i':
  case 'j':
    break;

  default:
    assert ("bad arg string code" == NULL);
    break;
  }
      *plist
  = build_tree_list (NULL_TREE,
         null_pointer_node);
      plist = &TREE_CHAIN (*plist);
    }

  *plist = trail;

  return list;
}

static tree
ffecom_widest_expr_type_ (ffebld list)
{
  ffebld item;
  ffebld widest = NULL;
  ffetype type;
  ffetype widest_type = NULL;
  tree t;

  for (; list != NULL; list = ffebld_trail (list))
    {
      item = ffebld_head (list);
      if (item == NULL)
  continue;
      if ((widest != NULL)
    && (ffeinfo_basictype (ffebld_info (item))
        != ffeinfo_basictype (ffebld_info (widest))))
  continue;
      type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
         ffeinfo_kindtype (ffebld_info (item)));
      if ((widest == FFEINFO_kindtypeNONE)
    || (ffetype_size (type)
        > ffetype_size (widest_type)))
  {
    widest = item;
    widest_type = type;
  }
    }

  assert (widest != NULL);
  t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
    [ffeinfo_kindtype (ffebld_info (widest))];
  assert (t != NULL_TREE);
  return t;
}

/* Check whether a partial overlap between two expressions is possible.

   Can *starting* to write a portion of expr1 change the value
   computed (perhaps already, *partially*) by expr2?

   Currently, this is a concern only for a COMPLEX expr1.  But if it
   isn't in COMMON or local EQUIVALENCE, since we don't support
   aliasing of arguments, it isn't a concern.  */

static bool
ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
{
  ffesymbol sym;
  ffestorag st;

  switch (ffebld_op (expr1))
    {
    case FFEBLD_opSYMTER:
      sym = ffebld_symter (expr1);
      break;

    case FFEBLD_opARRAYREF:
      if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
  return FALSE;
      sym = ffebld_symter (ffebld_left (expr1));
      break;

    default:
      return FALSE;
    }

  if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
      && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
    || ! (st = ffesymbol_storage (sym))
    || ! ffestorag_parent (st)))
    return FALSE;

  /* It's in COMMON or local EQUIVALENCE.  */

  return TRUE;
}

/* Check whether dest and source might overlap.  ffebld versions of these
   might or might not be passed, will be NULL if not.

   The test is really whether source_tree is modifiable and, if modified,
   might overlap destination such that the value(s) in the destination might
   change before it is finally modified.  dest_* are the canonized
   destination itself.  */

static bool
ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
     tree source_tree, ffebld source UNUSED,
     bool scalar_arg)
{
  tree source_decl;
  tree source_offset;
  tree source_size;
  tree t;

  if (source_tree == NULL_TREE)
    return FALSE;

  switch (TREE_CODE (source_tree))
    {
    case ERROR_MARK:
    case IDENTIFIER_NODE:
    case INTEGER_CST:
    case REAL_CST:
    case COMPLEX_CST:
    case STRING_CST:
    case CONST_DECL:
    case VAR_DECL:
    case RESULT_DECL:
    case FIELD_DECL:
    case MINUS_EXPR:
    case MULT_EXPR:
    case TRUNC_DIV_EXPR:
    case CEIL_DIV_EXPR:
    case FLOOR_DIV_EXPR:
    case ROUND_DIV_EXPR:
    case TRUNC_MOD_EXPR:
    case CEIL_MOD_EXPR:
    case FLOOR_MOD_EXPR:
    case ROUND_MOD_EXPR:
    case RDIV_EXPR:
    case EXACT_DIV_EXPR:
    case FIX_TRUNC_EXPR:
    case FIX_CEIL_EXPR:
    case FIX_FLOOR_EXPR:
    case FIX_ROUND_EXPR:
    case FLOAT_EXPR:
    case NEGATE_EXPR:
    case MIN_EXPR:
    case MAX_EXPR:
    case ABS_EXPR:
    case FFS_EXPR:
    case LSHIFT_EXPR:
    case RSHIFT_EXPR:
    case LROTATE_EXPR:
    case RROTATE_EXPR:
    case BIT_IOR_EXPR:
    case BIT_XOR_EXPR:
    case BIT_AND_EXPR:
    case BIT_ANDTC_EXPR:
    case BIT_NOT_EXPR:
    case TRUTH_ANDIF_EXPR:
    case TRUTH_ORIF_EXPR:
    case TRUTH_AND_EXPR:
    case TRUTH_OR_EXPR:
    case TRUTH_XOR_EXPR:
    case TRUTH_NOT_EXPR:
    case LT_EXPR:
    case LE_EXPR:
    case GT_EXPR:
    case GE_EXPR:
    case EQ_EXPR:
    case NE_EXPR:
    case COMPLEX_EXPR:
    case CONJ_EXPR:
    case REALPART_EXPR:
    case IMAGPART_EXPR:
    case LABEL_EXPR:
    case COMPONENT_REF:
      return FALSE;

    case COMPOUND_EXPR:
      return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
            TREE_OPERAND (source_tree, 1), NULL,
            scalar_arg);

    case MODIFY_EXPR:
      return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
            TREE_OPERAND (source_tree, 0), NULL,
            scalar_arg);

    case CONVERT_EXPR:
    case NOP_EXPR:
    case NON_LVALUE_EXPR:
    case PLUS_EXPR:
      if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
  return TRUE;

      ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
         source_tree);
      source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
      break;

    case COND_EXPR:
      return
  ffecom_overlap_ (dest_decl, dest_offset, dest_size,
       TREE_OPERAND (source_tree, 1), NULL,
       scalar_arg)
    || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
            TREE_OPERAND (source_tree, 2), NULL,
            scalar_arg);


    case ADDR_EXPR:
      ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
         &source_size,
         TREE_OPERAND (source_tree, 0));
      break;

    case PARM_DECL:
      if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
  return TRUE;

      source_decl = source_tree;
      source_offset = bitsize_zero_node;
      source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
      break;

    case SAVE_EXPR:
    case REFERENCE_EXPR:
    case PREDECREMENT_EXPR:
    case PREINCREMENT_EXPR:
    case POSTDECREMENT_EXPR:
    case POSTINCREMENT_EXPR:
    case INDIRECT_REF:
    case ARRAY_REF:
    case CALL_EXPR:
    default:
      return TRUE;
    }

  /* Come here when source_decl, source_offset, and source_size filled
     in appropriately.  */

  if (source_decl == NULL_TREE)
    return FALSE;   /* No decl involved, so no overlap. */

  if (source_decl != dest_decl)
    return FALSE;   /* Different decl, no overlap. */

  if (TREE_CODE (dest_size) == ERROR_MARK)
    return TRUE;    /* Assignment into entire assumed-size
           array?  Shouldn't happen.... */

  t = ffecom_2 (LE_EXPR, integer_type_node,
    ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
        dest_offset,
        convert (TREE_TYPE (dest_offset),
           dest_size)),
    convert (TREE_TYPE (dest_offset),
       source_offset));

  if (integer_onep (t))
    return FALSE;   /* Destination precedes source. */

  if (!scalar_arg
      || (source_size == NULL_TREE)
      || (TREE_CODE (source_size) == ERROR_MARK)
      || integer_zerop (source_size))
    return TRUE;    /* No way to tell if dest follows source. */

  t = ffecom_2 (LE_EXPR, integer_type_node,
    ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
        source_offset,
        convert (TREE_TYPE (source_offset),
           source_size)),
    convert (TREE_TYPE (source_offset),
       dest_offset));

  if (integer_onep (t))
    return FALSE;   /* Destination follows source. */

  return TRUE;    /* Destination and source overlap. */
}

/* Check whether dest might overlap any of a list of arguments or is
   in a COMMON area the callee might know about (and thus modify).  */

static bool
ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
        tree args, tree callee_commons,
        bool scalar_args)
{
  tree arg;
  tree dest_decl;
  tree dest_offset;
  tree dest_size;

  ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
           dest_tree);

  if (dest_decl == NULL_TREE)
    return FALSE;   /* Seems unlikely! */

  /* If the decl cannot be determined reliably, or if its in COMMON
     and the callee isn't known to not futz with COMMON via other
     means, overlap might happen.  */

  if ((TREE_CODE (dest_decl) == ERROR_MARK)
      || ((callee_commons != NULL_TREE)
    && TREE_PUBLIC (dest_decl)))
    return TRUE;

  for (; args != NULL_TREE; args = TREE_CHAIN (args))
    {
      if (((arg = TREE_VALUE (args)) != NULL_TREE)
    && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
            arg, NULL, scalar_args))
  return TRUE;
    }

  return FALSE;
}

/* Build a string for a variable name as used by NAMELIST.  This means that
   if we're using the f2c library, we build an uppercase string, since
   f2c does this.  */

static tree
ffecom_build_f2c_string_ (int i, const char *s)
{
  if (!ffe_is_f2c_library ())
    return build_string (i, s);

  {
    char *tmp;
    const char *p;
    char *q;
    char space[34];
    tree t;

    if (((size_t) i) > ARRAY_SIZE (space))
      tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
    else
      tmp = &space[0];

    for (p = s, q = tmp; *p != '\0'; ++p, ++q)
      *q = TOUPPER (*p);
    *q = '\0';

    t = build_string (i, tmp);

    if (((size_t) i) > ARRAY_SIZE (space))
      malloc_kill_ks (malloc_pool_image (), tmp, i);

    return t;
  }
}

/* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
   type to just get whatever the function returns), handling the
   f2c value-returning convention, if required, by prepending
   to the arglist a pointer to a temporary to receive the return value.  */

static tree
ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
        tree type, tree args, tree dest_tree,
        ffebld dest, bool *dest_used, tree callee_commons,
        bool scalar_args, tree hook)
{
  tree item;
  tree tempvar;

  if (dest_used != NULL)
    *dest_used = FALSE;

  if (is_f2c_complex)
    {
      if ((dest_used == NULL)
    || (dest == NULL)
    || (ffeinfo_basictype (ffebld_info (dest))
        != FFEINFO_basictypeCOMPLEX)
    || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
    || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
    || ffecom_args_overlapping_ (dest_tree, dest, args,
               callee_commons,
               scalar_args))
  {
#ifdef HOHO
    tempvar = ffecom_make_tempvar (ffecom_tree_type
           [FFEINFO_basictypeCOMPLEX][kt],
           FFETARGET_charactersizeNONE,
           -1);
#else
    tempvar = hook;
    assert (tempvar);
#endif
  }
      else
  {
    *dest_used = TRUE;
    tempvar = dest_tree;
    type = NULL_TREE;
  }

      item
  = build_tree_list (NULL_TREE,
         ffecom_1 (ADDR_EXPR,
             build_pointer_type (TREE_TYPE (tempvar)),
             tempvar));
      TREE_CHAIN (item) = args;

      item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
      item, NULL_TREE);

      if (tempvar != dest_tree)
  item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
    }
  else
    item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
          args, NULL_TREE);

  if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
    item = ffecom_convert_narrow_ (type, item);

  return item;
}

/* Given two arguments, transform them and make a call to the given
   function via ffecom_call_.  */

static tree
ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
        tree type, ffebld left, ffebld right,
        tree dest_tree, ffebld dest, bool *dest_used,
        tree callee_commons, bool scalar_args, bool ref, tree hook)
{
  tree left_tree;
  tree right_tree;
  tree left_length;
  tree right_length;

  if (ref)
    {
      /* Pass arguments by reference.  */
      left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
      right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
    }
  else
    {
      /* Pass arguments by value.  */
      left_tree = ffecom_arg_expr (left, &left_length);
      right_tree = ffecom_arg_expr (right, &right_length);
    }


  left_tree = build_tree_list (NULL_TREE, left_tree);
  right_tree = build_tree_list (NULL_TREE, right_tree);
  TREE_CHAIN (left_tree) = right_tree;

  if (left_length != NULL_TREE)
    {
      left_length = build_tree_list (NULL_TREE, left_length);
      TREE_CHAIN (right_tree) = left_length;
    }

  if (right_length != NULL_TREE)
    {
      right_length = build_tree_list (NULL_TREE, right_length);
      if (left_length != NULL_TREE)
  TREE_CHAIN (left_length) = right_length;
      else
  TREE_CHAIN (right_tree) = right_length;
    }

  return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
           dest_tree, dest, dest_used, callee_commons,
           scalar_args, hook);
}

/* Return ptr/length args for char subexpression

   Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
   subexpressions by constructing the appropriate trees for the ptr-to-
   character-text and length-of-character-text arguments in a calling
   sequence.

   Note that if with_null is TRUE, and the expression is an opCONTER,
   a null byte is appended to the string.  */

static void
ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
{
  tree item;
  tree high;
  ffetargetCharacter1 val;
  ffetargetCharacterSize newlen;

  switch (ffebld_op (expr))
    {
    case FFEBLD_opCONTER:
      val = ffebld_constant_character1 (ffebld_conter (expr));
      newlen = ffetarget_length_character1 (val);
      if (with_null)
  {
    /* Begin FFETARGET-NULL-KLUDGE.  */
    if (newlen != 0)
      ++newlen;
  }
      *length = build_int_2 (newlen, 0);
      TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
      high = build_int_2 (newlen, 0);
      TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
      item = build_string (newlen,
         ffetarget_text_character1 (val));
      /* End FFETARGET-NULL-KLUDGE.  */
      TREE_TYPE (item)
  = build_type_variant
    (build_array_type
     (char_type_node,
      build_range_type
      (ffecom_f2c_ftnlen_type_node,
       ffecom_f2c_ftnlen_one_node,
       high)),
     1, 0);
      TREE_CONSTANT (item) = 1;
      TREE_STATIC (item) = 1;
      item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
           item);
      break;

    case FFEBLD_opSYMTER:
      {
  ffesymbol s = ffebld_symter (expr);

  item = ffesymbol_hook (s).decl_tree;
  if (item == NULL_TREE)
    {
      s = ffecom_sym_transform_ (s);
      item = ffesymbol_hook (s).decl_tree;
    }
  if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
    {
      if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
        *length = ffesymbol_hook (s).length_tree;
      else
        {
    *length = build_int_2 (ffesymbol_size (s), 0);
    TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
        }
    }
  else if (item == error_mark_node)
    *length = error_mark_node;
  else
    /* FFEINFO_kindFUNCTION.  */
    *length = NULL_TREE;
  if (!ffesymbol_hook (s).addr
      && (item != error_mark_node))
    item = ffecom_1 (ADDR_EXPR,
         build_pointer_type (TREE_TYPE (item)),
         item);
      }
      break;

    case FFEBLD_opARRAYREF:
      {
  ffecom_char_args_ (&item, length, ffebld_left (expr));

  if (item == error_mark_node || *length == error_mark_node)
    {
      item = *length = error_mark_node;
      break;
    }

  item = ffecom_arrayref_ (item, expr, 1);
      }
      break;

    case FFEBLD_opSUBSTR:
      {
  ffebld start;
  ffebld end;
  ffebld thing = ffebld_right (expr);
  tree start_tree;
  tree end_tree;
  const char *char_name;
  ffebld left_symter;
  tree array;

  assert (ffebld_op (thing) == FFEBLD_opITEM);
  start = ffebld_head (thing);
  thing = ffebld_trail (thing);
  assert (ffebld_trail (thing) == NULL);
  end = ffebld_head (thing);

  /* Determine name for pretty-printing range-check errors.  */
  for (left_symter = ffebld_left (expr);
       left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
       left_symter = ffebld_left (left_symter))
    ;
  if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
    char_name = ffesymbol_text (ffebld_symter (left_symter));
  else
    char_name = "[expr?]";

  ffecom_char_args_ (&item, length, ffebld_left (expr));

  if (item == error_mark_node || *length == error_mark_node)
    {
      item = *length = error_mark_node;
      break;
    }

  array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));

  /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */

  if (start == NULL)
    {
      if (end == NULL)
        ;
      else
        {
    end_tree = ffecom_expr (end);
    if (flag_bounds_check)
      end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
                  char_name);
    end_tree = convert (ffecom_f2c_ftnlen_type_node,
            end_tree);

    if (end_tree == error_mark_node)
      {
        item = *length = error_mark_node;
        break;
      }

    *length = end_tree;
        }
    }
  else
    {
      start_tree = ffecom_expr (start);
      if (flag_bounds_check)
        start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
                char_name);
      start_tree = convert (ffecom_f2c_ftnlen_type_node,
          start_tree);

      if (start_tree == error_mark_node)
        {
    item = *length = error_mark_node;
    break;
        }

      start_tree = ffecom_save_tree (start_tree);

      item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
           item,
           ffecom_2 (MINUS_EXPR,
               TREE_TYPE (start_tree),
               start_tree,
               ffecom_f2c_ftnlen_one_node));

      if (end == NULL)
        {
    *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
            ffecom_f2c_ftnlen_one_node,
            ffecom_2 (MINUS_EXPR,
                ffecom_f2c_ftnlen_type_node,
                *length,
                start_tree));
        }
      else
        {
    end_tree = ffecom_expr (end);
    if (flag_bounds_check)
      end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
                  char_name);
    end_tree = convert (ffecom_f2c_ftnlen_type_node,
            end_tree);

    if (end_tree == error_mark_node)
      {
        item = *length = error_mark_node;
        break;
      }

    *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
            ffecom_f2c_ftnlen_one_node,
            ffecom_2 (MINUS_EXPR,
                ffecom_f2c_ftnlen_type_node,
                end_tree, start_tree));
        }
    }
      }
      break;

    case FFEBLD_opFUNCREF:
      {
  ffesymbol s = ffebld_symter (ffebld_left (expr));
  tree tempvar;
  tree args;
  ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
  ffecomGfrt ix;

  if (size == FFETARGET_charactersizeNONE)
    /* ~~Kludge alert!  This should someday be fixed. */
    size = 24;

  *length = build_int_2 (size, 0);
  TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;

  if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
      == FFEINFO_whereINTRINSIC)
    {
      if (size == 1)
        {
    /* Invocation of an intrinsic returning CHARACTER*1.  */
    item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
                 NULL, NULL);
    break;
        }
      ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
      assert (ix != FFECOM_gfrt);
      item = ffecom_gfrt_tree_ (ix);
    }
  else
    {
      ix = FFECOM_gfrt;
      item = ffesymbol_hook (s).decl_tree;
      if (item == NULL_TREE)
        {
    s = ffecom_sym_transform_ (s);
    item = ffesymbol_hook (s).decl_tree;
        }
      if (item == error_mark_node)
        {
    item = *length = error_mark_node;
    break;
        }

      if (!ffesymbol_hook (s).addr)
        item = ffecom_1_fn (item);
    }

#ifdef HOHO
  tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
#else
  tempvar = ffebld_nonter_hook (expr);
  assert (tempvar);
#endif
  tempvar = ffecom_1 (ADDR_EXPR,
          build_pointer_type (TREE_TYPE (tempvar)),
          tempvar);

  args = build_tree_list (NULL_TREE, tempvar);

  if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
    TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
  else
    {
      TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
      if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
        {
    TREE_CHAIN (TREE_CHAIN (args))
      = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
            ffebld_right (expr));
        }
      else
        {
    TREE_CHAIN (TREE_CHAIN (args))
      = ffecom_list_ptr_to_expr (ffebld_right (expr));
        }
    }

  item = ffecom_3s (CALL_EXPR,
        TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
        item, args, NULL_TREE);
  item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
       tempvar);
      }
      break;

    case FFEBLD_opCONVERT:

      ffecom_char_args_ (&item, length, ffebld_left (expr));

      if (item == error_mark_node || *length == error_mark_node)
  {
    item = *length = error_mark_node;
    break;
  }

      if ((ffebld_size_known (ffebld_left (expr))
     == FFETARGET_charactersizeNONE)
    || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
  {     /* Possible blank-padding needed, copy into
           temporary. */
    tree tempvar;
    tree args;
    tree newlen;

#ifdef HOHO
    tempvar = ffecom_make_tempvar (char_type_node,
           ffebld_size (expr), -1);
#else
    tempvar = ffebld_nonter_hook (expr);
    assert (tempvar);
#endif
    tempvar = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (tempvar)),
            tempvar);

    newlen = build_int_2 (ffebld_size (expr), 0);
    TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;

    args = build_tree_list (NULL_TREE, tempvar);
    TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
    TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
    TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
      = build_tree_list (NULL_TREE, *length);

    item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
    TREE_SIDE_EFFECTS (item) = 1;
    item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
         tempvar);
    *length = newlen;
  }
      else
  {     /* Just truncate the length. */
    *length = build_int_2 (ffebld_size (expr), 0);
    TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
  }
      break;

    default:
      assert ("bad op for single char arg expr" == NULL);
      item = NULL_TREE;
      break;
    }

  *xitem = item;
}

/* Check the size of the type to be sure it doesn't overflow the
   "portable" capacities of the compiler back end.  `dummy' types
   can generally overflow the normal sizes as long as the computations
   themselves don't overflow.  A particular target of the back end
   must still enforce its size requirements, though, and the back
   end takes care of this in stor-layout.c.  */

static tree
ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
{
  if (TREE_CODE (type) == ERROR_MARK)
    return type;

  if (TYPE_SIZE (type) == NULL_TREE)
    return type;

  if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
    return type;

  /* An array is too large if size is negative or the type_size overflows
     or its "upper half" is larger than 3 (which would make the signed
     byte size and offset computations overflow).  */

  if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
      || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
               || TREE_OVERFLOW (TYPE_SIZE (type)))))
    {
      ffebad_start (FFEBAD_ARRAY_LARGE);
      ffebad_string (ffesymbol_text (s));
      ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
      ffebad_finish ();

      return error_mark_node;
    }

  return type;
}

/* Builds a length argument (PARM_DECL).  Also wraps type in an array type
   where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
   known, length_arg if not known (FFETARGET_charactersizeNONE).  */

static tree
ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
{
  ffetargetCharacterSize sz = ffesymbol_size (s);
  tree highval;
  tree tlen;
  tree type = *xtype;

  if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
    tlen = NULL_TREE;   /* A statement function, no length passed. */
  else
    {
      if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
  tlen = ffecom_get_invented_identifier ("__g77_length_%s",
                 ffesymbol_text (s));
      else
  tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
      tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
      DECL_ARTIFICIAL (tlen) = 1;
    }

  if (sz == FFETARGET_charactersizeNONE)
    {
      assert (tlen != NULL_TREE);
      highval = variable_size (tlen);
    }
  else
    {
      highval = build_int_2 (sz, 0);
      TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
    }

  type = build_array_type (type,
         build_range_type (ffecom_f2c_ftnlen_type_node,
               ffecom_f2c_ftnlen_one_node,
               highval));

  *xtype = type;
  return tlen;
}

/* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs

   ffecomConcatList_ catlist;
   ffebld expr;  // expr of CHARACTER basictype.
   ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
   catlist = ffecom_concat_list_gather_(catlist,expr,max);

   Scans expr for character subexpressions, updates and returns catlist
   accordingly.  */

static ffecomConcatList_
ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
          ffetargetCharacterSize max)
{
  ffetargetCharacterSize sz;

 recurse:

  if (expr == NULL)
    return catlist;

  if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
    return catlist;   /* Don't append any more items. */

  switch (ffebld_op (expr))
    {
    case FFEBLD_opCONTER:
    case FFEBLD_opSYMTER:
    case FFEBLD_opARRAYREF:
    case FFEBLD_opFUNCREF:
    case FFEBLD_opSUBSTR:
    case FFEBLD_opCONVERT:  /* Callers should strip this off beforehand
           if they don't need to preserve it. */
      if (catlist.count == catlist.max)
  {     /* Make a (larger) list. */
    ffebld *newx;
    int newmax;

    newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
    newx = malloc_new_ks (malloc_pool_image (), "catlist",
        newmax * sizeof (newx[0]));
    if (catlist.max != 0)
      {
        memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
        malloc_kill_ks (malloc_pool_image (), catlist.exprs,
            catlist.max * sizeof (newx[0]));
      }
    catlist.max = newmax;
    catlist.exprs = newx;
  }
      if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
  catlist.minlen += sz;
      else
  ++catlist.minlen; /* Not true for F90; can be 0 length. */
      if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
  catlist.maxlen = sz;
      else
  catlist.maxlen += sz;
      if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
  {     /* This item overlaps (or is beyond) the end
           of the destination. */
    switch (ffebld_op (expr))
      {
      case FFEBLD_opCONTER:
      case FFEBLD_opSYMTER:
      case FFEBLD_opARRAYREF:
      case FFEBLD_opFUNCREF:
      case FFEBLD_opSUBSTR:
        /* ~~Do useful truncations here. */
        break;

      default:
        assert ("op changed or inconsistent switches!" == NULL);
        break;
      }
  }
      catlist.exprs[catlist.count++] = expr;
      return catlist;

    case FFEBLD_opPAREN:
      expr = ffebld_left (expr);
      goto recurse;   /* :::::::::::::::::::: */

    case FFEBLD_opCONCATENATE:
      catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
      expr = ffebld_right (expr);
      goto recurse;   /* :::::::::::::::::::: */

#if 0       /* Breaks passing small actual arg to larger
           dummy arg of sfunc */
    case FFEBLD_opCONVERT:
      expr = ffebld_left (expr);
      {
  ffetargetCharacterSize cmax;

  cmax = catlist.len + ffebld_size_known (expr);

  if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
    max = cmax;
      }
      goto recurse;   /* :::::::::::::::::::: */
#endif

    case FFEBLD_opANY:
      return catlist;

    default:
      assert ("bad op in _gather_" == NULL);
      return catlist;
    }
}

/* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs

   ffecomConcatList_ catlist;
   ffecom_concat_list_kill_(catlist);

   Anything allocated within the list info is deallocated.  */

static void
ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
{
  if (catlist.max != 0)
    malloc_kill_ks (malloc_pool_image (), catlist.exprs,
        catlist.max * sizeof (catlist.exprs[0]));
}

/* Make list of concatenated string exprs.

   Returns a flattened list of concatenated subexpressions given a
   tree of such expressions.  */

static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
{
  ffecomConcatList_ catlist;

  catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
  return ffecom_concat_list_gather_ (catlist, expr, max);
}

/* Provide some kind of useful info on member of aggregate area,
   since current g77/gcc technology does not provide debug info
   on these members.  */

static void
ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
          tree member_type UNUSED, ffetargetOffset offset)
{
  tree value;
  tree decl;
  int len;
  char *buff;
  char space[120];
#if 0
  tree type_id;

  for (type_id = member_type;
       TREE_CODE (type_id) != IDENTIFIER_NODE;
       )
    {
      switch (TREE_CODE (type_id))
  {
  case INTEGER_TYPE:
  case REAL_TYPE:
    type_id = TYPE_NAME (type_id);
    break;

  case ARRAY_TYPE:
  case COMPLEX_TYPE:
    type_id = TREE_TYPE (type_id);
    break;

  default:
    assert ("no IDENTIFIER_NODE for type!" == NULL);
    type_id = error_mark_node;
    break;
  }
    }
#endif

  if (ffecom_transform_only_dummies_
      || !ffe_is_debug_kludge ())
    return; /* Can't do this yet, maybe later. */

  len = 60
    + strlen (aggr_type)
    + IDENTIFIER_LENGTH (DECL_NAME (aggr));
#if 0
    + IDENTIFIER_LENGTH (type_id);
#endif

  if (((size_t) len) >= ARRAY_SIZE (space))
    buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
  else
    buff = &space[0];

  sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
     aggr_type,
     IDENTIFIER_POINTER (DECL_NAME (aggr)),
     (long int) offset);

  value = build_string (len, buff);
  TREE_TYPE (value)
    = build_type_variant (build_array_type (char_type_node,
              build_range_type
              (integer_type_node,
               integer_one_node,
               build_int_2 (strlen (buff), 0))),
        1, 0);
  decl = build_decl (VAR_DECL,
         ffecom_get_identifier_ (ffesymbol_text (member)),
         TREE_TYPE (value));
  TREE_CONSTANT (decl) = 1;
  TREE_STATIC (decl) = 1;
  DECL_INITIAL (decl) = error_mark_node;
  DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
  decl = start_decl (decl, FALSE);
  finish_decl (decl, value, FALSE);

  if (buff != &space[0])
    malloc_kill_ks (malloc_pool_image (), buff, len + 1);
}

/* ffecom_do_entry_ -- Do compilation of a particular entrypoint

   ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
   int i;  // entry# for this entrypoint (used by master fn)
   ffecom_do_entrypoint_(s,i);

   Makes a public entry point that calls our private master fn (already
   compiled).  */

static void
ffecom_do_entry_ (ffesymbol fn, int entrynum)
{
  ffebld item;
  tree type;      /* Type of function. */
  tree multi_retval;    /* Var holding return value (union). */
  tree result;      /* Var holding result. */
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffeglobal g;
  ffeglobalType gt;
  bool charfunc;    /* All entry points return same type
           CHARACTER. */
  bool cmplxfunc;   /* Use f2c way of returning COMPLEX. */
  bool multi;     /* Master fn has multiple return types. */
  bool altreturning = FALSE;  /* This entry point has alternate returns. */
  int old_lineno = lineno;
  const char *old_input_filename = input_filename;

  input_filename = ffesymbol_where_filename (fn);
  lineno = ffesymbol_where_filelinenum (fn);

  ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */

  switch (ffecom_primary_entry_kind_)
    {
    case FFEINFO_kindFUNCTION:

      /* Determine actual return type for function. */

      gt = FFEGLOBAL_typeFUNC;
      bt = ffesymbol_basictype (fn);
      kt = ffesymbol_kindtype (fn);
      if (bt == FFEINFO_basictypeNONE)
  {
    ffeimplic_establish_symbol (fn);
    if (ffesymbol_funcresult (fn) != NULL)
      ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
    bt = ffesymbol_basictype (fn);
    kt = ffesymbol_kindtype (fn);
  }

      if (bt == FFEINFO_basictypeCHARACTER)
  charfunc = TRUE, cmplxfunc = FALSE;
      else if ((bt == FFEINFO_basictypeCOMPLEX)
         && ffesymbol_is_f2c (fn))
  charfunc = FALSE, cmplxfunc = TRUE;
      else
  charfunc = cmplxfunc = FALSE;

      if (charfunc)
  type = ffecom_tree_fun_type_void;
      else if (ffesymbol_is_f2c (fn))
  type = ffecom_tree_fun_type[bt][kt];
      else
  type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);

      if ((type == NULL_TREE)
    || (TREE_TYPE (type) == NULL_TREE))
  type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */

      multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
      break;

    case FFEINFO_kindSUBROUTINE:
      gt = FFEGLOBAL_typeSUBR;
      bt = FFEINFO_basictypeNONE;
      kt = FFEINFO_kindtypeNONE;
      if (ffecom_is_altreturning_)
  {     /* Am _I_ altreturning? */
    for (item = ffesymbol_dummyargs (fn);
         item != NULL;
         item = ffebld_trail (item))
      {
        if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
    {
      altreturning = TRUE;
      break;
    }
      }
    if (altreturning)
      type = ffecom_tree_subr_type;
    else
      type = ffecom_tree_fun_type_void;
  }
      else
  type = ffecom_tree_fun_type_void;
      charfunc = FALSE;
      cmplxfunc = FALSE;
      multi = FALSE;
      break;

    default:
      assert ("say what??" == NULL);
      /* Fall through. */
    case FFEINFO_kindANY:
      gt = FFEGLOBAL_typeANY;
      bt = FFEINFO_basictypeNONE;
      kt = FFEINFO_kindtypeNONE;
      type = error_mark_node;
      charfunc = FALSE;
      cmplxfunc = FALSE;
      multi = FALSE;
      break;
    }

  /* build_decl uses the current lineno and input_filename to set the decl
     source info.  So, I've putzed with ffestd and ffeste code to update that
     source info to point to the appropriate statement just before calling
     ffecom_do_entrypoint (which calls this fn).  */

  start_function (ffecom_get_external_identifier_ (fn),
      type,
      0,    /* nested/inline */
      1);   /* TREE_PUBLIC */

  if (((g = ffesymbol_global (fn)) != NULL)
      && ((ffeglobal_type (g) == gt)
    || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
    {
      ffeglobal_set_hook (g, current_function_decl);
    }

  /* Reset args in master arg list so they get retransitioned. */

  for (item = ffecom_master_arglist_;
       item != NULL;
       item = ffebld_trail (item))
    {
      ffebld arg;
      ffesymbol s;

      arg = ffebld_head (item);
      if (ffebld_op (arg) != FFEBLD_opSYMTER)
  continue;   /* Alternate return or some such thing. */
      s = ffebld_symter (arg);
      ffesymbol_hook (s).decl_tree = NULL_TREE;
      ffesymbol_hook (s).length_tree = NULL_TREE;
    }

  /* Build dummy arg list for this entry point. */

  if (charfunc || cmplxfunc)
    {       /* Prepend arg for where result goes. */
      tree type;
      tree length;

      if (charfunc)
  type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
      else
  type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];

      result = ffecom_get_invented_identifier ("__g77_%s", "result");

      /* Make length arg _and_ enhance type info for CHAR arg itself.  */

      if (charfunc)
  length = ffecom_char_enhance_arg_ (&type, fn);
      else
  length = NULL_TREE; /* Not ref'd if !charfunc. */

      type = build_pointer_type (type);
      result = build_decl (PARM_DECL, result, type);

      push_parm_decl (result);
      ffecom_func_result_ = result;

      if (charfunc)
  {
    push_parm_decl (length);
    ffecom_func_length_ = length;
  }
    }
  else
    result = DECL_RESULT (current_function_decl);

  ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);

  store_parm_decls (0);

  ffecom_start_compstmt ();
  /* Disallow temp vars at this level.  */
  current_binding_level->prep_state = 2;

  /* Make local var to hold return type for multi-type master fn. */

  if (multi)
    {
      multi_retval = ffecom_get_invented_identifier ("__g77_%s",
                 "multi_retval");
      multi_retval = build_decl (VAR_DECL, multi_retval,
         ffecom_multi_type_node_);
      multi_retval = start_decl (multi_retval, FALSE);
      finish_decl (multi_retval, NULL_TREE, FALSE);
    }
  else
    multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */

  /* Here we emit the actual code for the entry point. */

  {
    ffebld list;
    ffebld arg;
    ffesymbol s;
    tree arglist = NULL_TREE;
    tree *plist = &arglist;
    tree prepend;
    tree call;
    tree actarg;
    tree master_fn;

    /* Prepare actual arg list based on master arg list. */

    for (list = ffecom_master_arglist_;
   list != NULL;
   list = ffebld_trail (list))
      {
  arg = ffebld_head (list);
  if (ffebld_op (arg) != FFEBLD_opSYMTER)
    continue;
  s = ffebld_symter (arg);
  if (ffesymbol_hook (s).decl_tree == NULL_TREE
      || ffesymbol_hook (s).decl_tree == error_mark_node)
    actarg = null_pointer_node; /* We don't have this arg. */
  else
    actarg = ffesymbol_hook (s).decl_tree;
  *plist = build_tree_list (NULL_TREE, actarg);
  plist = &TREE_CHAIN (*plist);
      }

    /* This code appends the length arguments for character
       variables/arrays.  */

    for (list = ffecom_master_arglist_;
   list != NULL;
   list = ffebld_trail (list))
      {
  arg = ffebld_head (list);
  if (ffebld_op (arg) != FFEBLD_opSYMTER)
    continue;
  s = ffebld_symter (arg);
  if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
    continue;   /* Only looking for CHARACTER arguments. */
  if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
    continue;   /* Only looking for variables and arrays. */
  if (ffesymbol_hook (s).length_tree == NULL_TREE
      || ffesymbol_hook (s).length_tree == error_mark_node)
    actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
  else
    actarg = ffesymbol_hook (s).length_tree;
  *plist = build_tree_list (NULL_TREE, actarg);
  plist = &TREE_CHAIN (*plist);
      }

    /* Prepend character-value return info to actual arg list. */

    if (charfunc)
      {
  prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
  TREE_CHAIN (prepend)
    = build_tree_list (NULL_TREE, ffecom_func_length_);
  TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
  arglist = prepend;
      }

    /* Prepend multi-type return value to actual arg list. */

    if (multi)
      {
  prepend
    = build_tree_list (NULL_TREE,
           ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (multi_retval)),
               multi_retval));
  TREE_CHAIN (prepend) = arglist;
  arglist = prepend;
      }

    /* Prepend my entry-point number to the actual arg list. */

    prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
    TREE_CHAIN (prepend) = arglist;
    arglist = prepend;

    /* Build the call to the master function. */

    master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
    call = ffecom_3s (CALL_EXPR,
          TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
          master_fn, arglist, NULL_TREE);

    /* Decide whether the master function is a function or subroutine, and
       handle the return value for my entry point. */

    if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
         && !altreturning))
      {
  expand_expr_stmt (call);
  expand_null_return ();
      }
    else if (multi && cmplxfunc)
      {
  expand_expr_stmt (call);
  result
    = ffecom_1 (INDIRECT_REF,
          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
          result);
  result = ffecom_modify (NULL_TREE, result,
        ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
            multi_retval,
            ffecom_multi_fields_[bt][kt]));
  expand_expr_stmt (result);
  expand_null_return ();
      }
    else if (multi)
      {
  expand_expr_stmt (call);
  result
    = ffecom_modify (NULL_TREE, result,
         convert (TREE_TYPE (result),
            ffecom_2 (COMPONENT_REF,
                ffecom_tree_type[bt][kt],
                multi_retval,
                ffecom_multi_fields_[bt][kt])));
  expand_return (result);
      }
    else if (cmplxfunc)
      {
  result
    = ffecom_1 (INDIRECT_REF,
          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
          result);
  result = ffecom_modify (NULL_TREE, result, call);
  expand_expr_stmt (result);
  expand_null_return ();
      }
    else
      {
  result = ffecom_modify (NULL_TREE,
        result,
        convert (TREE_TYPE (result),
           call));
  expand_return (result);
      }
  }

  ffecom_end_compstmt ();

  finish_function (0);

  lineno = old_lineno;
  input_filename = old_input_filename;

  ffecom_doing_entry_ = FALSE;
}

/* Transform expr into gcc tree with possible destination

   Recursive descent on expr while making corresponding tree nodes and
   attaching type info and such.  If destination supplied and compatible
   with temporary that would be made in certain cases, temporary isn't
   made, destination used instead, and dest_used flag set TRUE.  */

static tree
ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
        bool *dest_used, bool assignp, bool widenp)
{
  tree item;
  tree list;
  tree args;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  tree t;
  tree dt;      /* decl_tree for an ffesymbol. */
  tree tree_type, tree_type_x;
  tree left, right;
  ffesymbol s;
  enum tree_code code;

  assert (expr != NULL);

  if (dest_used != NULL)
    *dest_used = FALSE;

  bt = ffeinfo_basictype (ffebld_info (expr));
  kt = ffeinfo_kindtype (ffebld_info (expr));
  tree_type = ffecom_tree_type[bt][kt];

  /* Widen integral arithmetic as desired while preserving signedness.  */
  tree_type_x = NULL_TREE;
  if (widenp && tree_type
      && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
      && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
    tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);

  switch (ffebld_op (expr))
    {
    case FFEBLD_opACCTER:
      {
  ffebitCount i;
  ffebit bits = ffebld_accter_bits (expr);
  ffetargetOffset source_offset = 0;
  ffetargetOffset dest_offset = ffebld_accter_pad (expr);
  tree purpose;

  assert (dest_offset == 0
    || (bt == FFEINFO_basictypeCHARACTER
        && kt == FFEINFO_kindtypeCHARACTER1));

  list = item = NULL;
  for (;;)
    {
      ffebldConstantUnion cu;
      ffebitCount length;
      bool value;
      ffebldConstantArray ca = ffebld_accter (expr);

      ffebit_test (bits, source_offset, &value, &length);
      if (length == 0)
        break;

      if (value)
        {
    for (i = 0; i < length; ++i)
      {
        cu = ffebld_constantarray_get (ca, bt, kt,
               source_offset + i);

        t = ffecom_constantunion (&cu, bt, kt, tree_type);

        if (i == 0
      && dest_offset != 0)
          purpose = build_int_2 (dest_offset, 0);
        else
          purpose = NULL_TREE;

        if (list == NULL_TREE)
          list = item = build_tree_list (purpose, t);
        else
          {
      TREE_CHAIN (item) = build_tree_list (purpose, t);
      item = TREE_CHAIN (item);
          }
      }
        }
      source_offset += length;
      dest_offset += length;
    }
      }

      item = build_int_2 ((ffebld_accter_size (expr)
         + ffebld_accter_pad (expr)) - 1, 0);
      ffebit_kill (ffebld_accter_bits (expr));
      TREE_TYPE (item) = ffecom_integer_type_node;
      item
  = build_array_type
    (tree_type,
     build_range_type (ffecom_integer_type_node,
           ffecom_integer_zero_node,
           item));
      list = build (CONSTRUCTOR, item, NULL_TREE, list);
      TREE_CONSTANT (list) = 1;
      TREE_STATIC (list) = 1;
      return list;

    case FFEBLD_opARRTER:
      {
  ffetargetOffset i;

  list = NULL_TREE;
  if (ffebld_arrter_pad (expr) == 0)
    item = NULL_TREE;
  else
    {
      assert (bt == FFEINFO_basictypeCHARACTER
        && kt == FFEINFO_kindtypeCHARACTER1);

      /* Becomes PURPOSE first time through loop.  */
      item = build_int_2 (ffebld_arrter_pad (expr), 0);
    }

  for (i = 0; i < ffebld_arrter_size (expr); ++i)
    {
      ffebldConstantUnion cu
      = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);

      t = ffecom_constantunion (&cu, bt, kt, tree_type);

      if (list == NULL_TREE)
        /* Assume item is PURPOSE first time through loop.  */
        list = item = build_tree_list (item, t);
      else
        {
    TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
    item = TREE_CHAIN (item);
        }
    }
      }

      item = build_int_2 ((ffebld_arrter_size (expr)
        + ffebld_arrter_pad (expr)) - 1, 0);
      TREE_TYPE (item) = ffecom_integer_type_node;
      item
  = build_array_type
    (tree_type,
     build_range_type (ffecom_integer_type_node,
           ffecom_integer_zero_node,
           item));
      list = build (CONSTRUCTOR, item, NULL_TREE, list);
      TREE_CONSTANT (list) = 1;
      TREE_STATIC (list) = 1;
      return list;

    case FFEBLD_opCONTER:
      assert (ffebld_conter_pad (expr) == 0);
      item
  = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
        bt, kt, tree_type);
      return item;

    case FFEBLD_opSYMTER:
      if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
    || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
  return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
      s = ffebld_symter (expr);
      t = ffesymbol_hook (s).decl_tree;

      if (assignp)
  {     /* ASSIGN'ed-label expr. */
    if (ffe_is_ugly_assign ())
      {
        /* User explicitly wants ASSIGN'ed variables to be at the same
     memory address as the variables when used in non-ASSIGN
     contexts.  That can make old, arcane, non-standard code
     work, but don't try to do it when a pointer wouldn't fit
     in the normal variable (take other approach, and warn,
     instead).  */

        if (t == NULL_TREE)
    {
      s = ffecom_sym_transform_ (s);
      t = ffesymbol_hook (s).decl_tree;
      assert (t != NULL_TREE);
    }

        if (t == error_mark_node)
    return t;

        if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
      >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
    {
      if (ffesymbol_hook (s).addr)
        t = ffecom_1 (INDIRECT_REF,
          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
      return t;
    }

        if (ffesymbol_hook (s).assign_tree == NULL_TREE)
    {
      /* xgettext:no-c-format */
      ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
            FFEBAD_severityWARNING);
      ffebad_string (ffesymbol_text (s));
      ffebad_here (0, ffesymbol_where_line (s),
             ffesymbol_where_column (s));
      ffebad_finish ();
    }
      }

    /* Don't use the normal variable's tree for ASSIGN, though mark
       it as in the system header (housekeeping).  Use an explicit,
       specially created sibling that is known to be wide enough
       to hold pointers to labels.  */

    if (t != NULL_TREE
        && TREE_CODE (t) == VAR_DECL)
      DECL_IN_SYSTEM_HEADER (t) = 1;  /* Don't let -Wunused complain. */

    t = ffesymbol_hook (s).assign_tree;
    if (t == NULL_TREE)
      {
        s = ffecom_sym_transform_assign_ (s);
        t = ffesymbol_hook (s).assign_tree;
        assert (t != NULL_TREE);
      }
  }
      else
  {
    if (t == NULL_TREE)
      {
        s = ffecom_sym_transform_ (s);
        t = ffesymbol_hook (s).decl_tree;
        assert (t != NULL_TREE);
      }
    if (ffesymbol_hook (s).addr)
      t = ffecom_1 (INDIRECT_REF,
        TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
  }
      return t;

    case FFEBLD_opARRAYREF:
      return ffecom_arrayref_ (NULL_TREE, expr, 0);

    case FFEBLD_opUPLUS:
      left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
      return ffecom_1 (NOP_EXPR, tree_type, left);

    case FFEBLD_opPAREN:
      /* ~~~Make sure Fortran rules respected here */
      left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
      return ffecom_1 (NOP_EXPR, tree_type, left);

    case FFEBLD_opUMINUS:
      left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
      if (tree_type_x)
  {
    tree_type = tree_type_x;
    left = convert (tree_type, left);
  }
      return ffecom_1 (NEGATE_EXPR, tree_type, left);

    case FFEBLD_opADD:
      left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
      right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
      if (tree_type_x)
  {
    tree_type = tree_type_x;
    left = convert (tree_type, left);
    right = convert (tree_type, right);
  }
      return ffecom_2 (PLUS_EXPR, tree_type, left, right);

    case FFEBLD_opSUBTRACT:
      left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
      right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
      if (tree_type_x)
  {
    tree_type = tree_type_x;
    left = convert (tree_type, left);
    right = convert (tree_type, right);
  }
      return ffecom_2 (MINUS_EXPR, tree_type, left, right);

    case FFEBLD_opMULTIPLY:
      left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
      right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
      if (tree_type_x)
  {
    tree_type = tree_type_x;
    left = convert (tree_type, left);
    right = convert (tree_type, right);
  }
      return ffecom_2 (MULT_EXPR, tree_type, left, right);

    case FFEBLD_opDIVIDE:
      left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
      right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
      if (tree_type_x)
  {
    tree_type = tree_type_x;
    left = convert (tree_type, left);
    right = convert (tree_type, right);
  }
      return ffecom_tree_divide_ (tree_type, left, right,
                dest_tree, dest, dest_used,
          ffebld_nonter_hook (expr));

    case FFEBLD_opPOWER:
      {
  ffebld left = ffebld_left (expr);
  ffebld right = ffebld_right (expr);
  ffecomGfrt code;
  ffeinfoKindtype rtkt;
  ffeinfoKindtype ltkt;
  bool ref = TRUE;

  switch (ffeinfo_basictype (ffebld_info (right)))
    {

    case FFEINFO_basictypeINTEGER:
      if (1 || optimize)
        {
    item = ffecom_expr_power_integer_ (expr);
    if (item != NULL_TREE)
      return item;
        }

      rtkt = FFEINFO_kindtypeINTEGER1;
      switch (ffeinfo_basictype (ffebld_info (left)))
        {
        case FFEINFO_basictypeINTEGER:
    if ((ffeinfo_kindtype (ffebld_info (left))
        == FFEINFO_kindtypeINTEGER4)
        || (ffeinfo_kindtype (ffebld_info (right))
      == FFEINFO_kindtypeINTEGER4))
      {
        code = FFECOM_gfrtPOW_QQ;
        ltkt = FFEINFO_kindtypeINTEGER4;
        rtkt = FFEINFO_kindtypeINTEGER4;
      }
    else
      {
        code = FFECOM_gfrtPOW_II;
        ltkt = FFEINFO_kindtypeINTEGER1;
      }
    break;

        case FFEINFO_basictypeREAL:
    if (ffeinfo_kindtype (ffebld_info (left))
        == FFEINFO_kindtypeREAL1)
      {
        code = FFECOM_gfrtPOW_RI;
        ltkt = FFEINFO_kindtypeREAL1;
      }
    else
      {
        code = FFECOM_gfrtPOW_DI;
        ltkt = FFEINFO_kindtypeREAL2;
      }
    break;

        case FFEINFO_basictypeCOMPLEX:
    if (ffeinfo_kindtype (ffebld_info (left))
        == FFEINFO_kindtypeREAL1)
      {
        code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
        ltkt = FFEINFO_kindtypeREAL1;
      }
    else
      {
        code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
        ltkt = FFEINFO_kindtypeREAL2;
      }
    break;

        default:
    assert ("bad pow_*i" == NULL);
    code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
    ltkt = FFEINFO_kindtypeREAL1;
    break;
        }
      if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
        left = ffeexpr_convert (left, NULL, NULL,
              ffeinfo_basictype (ffebld_info (left)),
              ltkt, 0,
              FFETARGET_charactersizeNONE,
              FFEEXPR_contextLET);
      if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
        right = ffeexpr_convert (right, NULL, NULL,
               FFEINFO_basictypeINTEGER,
               rtkt, 0,
               FFETARGET_charactersizeNONE,
               FFEEXPR_contextLET);
      break;

    case FFEINFO_basictypeREAL:
      if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
        left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
              FFEINFO_kindtypeREALDOUBLE, 0,
              FFETARGET_charactersizeNONE,
              FFEEXPR_contextLET);
      if (ffeinfo_kindtype (ffebld_info (right))
    == FFEINFO_kindtypeREAL1)
        right = ffeexpr_convert (right, NULL, NULL,
               FFEINFO_basictypeREAL,
               FFEINFO_kindtypeREALDOUBLE, 0,
               FFETARGET_charactersizeNONE,
               FFEEXPR_contextLET);
      /* We used to call FFECOM_gfrtPOW_DD here,
         which passes arguments by reference.  */
      code = FFECOM_gfrtL_POW;
      /* Pass arguments by value. */
      ref  = FALSE;
      break;

    case FFEINFO_basictypeCOMPLEX:
      if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
        left = ffeexpr_convert (left, NULL, NULL,
              FFEINFO_basictypeCOMPLEX,
              FFEINFO_kindtypeREALDOUBLE, 0,
              FFETARGET_charactersizeNONE,
              FFEEXPR_contextLET);
      if (ffeinfo_kindtype (ffebld_info (right))
    == FFEINFO_kindtypeREAL1)
        right = ffeexpr_convert (right, NULL, NULL,
               FFEINFO_basictypeCOMPLEX,
               FFEINFO_kindtypeREALDOUBLE, 0,
               FFETARGET_charactersizeNONE,
               FFEEXPR_contextLET);
      code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
      ref = TRUE;     /* Pass arguments by reference. */
      break;

    default:
      assert ("bad pow_x*" == NULL);
      code = FFECOM_gfrtPOW_II;
      break;
    }
  return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
           ffecom_gfrt_kindtype (code),
           (ffe_is_f2c_library ()
            && ffecom_gfrt_complex_[code]),
           tree_type, left, right,
           dest_tree, dest, dest_used,
           NULL_TREE, FALSE, ref,
           ffebld_nonter_hook (expr));
      }

    case FFEBLD_opNOT:
      switch (bt)
  {
  case FFEINFO_basictypeLOGICAL:
    item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
    return convert (tree_type, item);

  case FFEINFO_basictypeINTEGER:
    return ffecom_1 (BIT_NOT_EXPR, tree_type,
         ffecom_expr (ffebld_left (expr)));

  default:
    assert ("NOT bad basictype" == NULL);
    /* Fall through. */
  case FFEINFO_basictypeANY:
    return error_mark_node;
  }
      break;

    case FFEBLD_opFUNCREF:
      assert (ffeinfo_basictype (ffebld_info (expr))
        != FFEINFO_basictypeCHARACTER);
      /* Fall through.   */
    case FFEBLD_opSUBRREF:
      if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
    == FFEINFO_whereINTRINSIC)
  {     /* Invocation of an intrinsic. */
    item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
           dest_used);
    return item;
  }
      s = ffebld_symter (ffebld_left (expr));
      dt = ffesymbol_hook (s).decl_tree;
      if (dt == NULL_TREE)
  {
    s = ffecom_sym_transform_ (s);
    dt = ffesymbol_hook (s).decl_tree;
  }
      if (dt == error_mark_node)
  return dt;

      if (ffesymbol_hook (s).addr)
  item = dt;
      else
  item = ffecom_1_fn (dt);

      if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
  args = ffecom_list_expr (ffebld_right (expr));
      else
  args = ffecom_list_ptr_to_expr (ffebld_right (expr));

      if (args == error_mark_node)
  return error_mark_node;

      item = ffecom_call_ (item, kt,
         ffesymbol_is_f2c (s)
         && (bt == FFEINFO_basictypeCOMPLEX)
         && (ffesymbol_where (s)
             != FFEINFO_whereCONSTANT),
         tree_type,
         args,
         dest_tree, dest, dest_used,
         error_mark_node, FALSE,
         ffebld_nonter_hook (expr));
      TREE_SIDE_EFFECTS (item) = 1;
      return item;

    case FFEBLD_opAND:
      switch (bt)
  {
  case FFEINFO_basictypeLOGICAL:
    item
      = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
           ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
         ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
    return convert (tree_type, item);

  case FFEINFO_basictypeINTEGER:
    return ffecom_2 (BIT_AND_EXPR, tree_type,
         ffecom_expr (ffebld_left (expr)),
         ffecom_expr (ffebld_right (expr)));

  default:
    assert ("AND bad basictype" == NULL);
    /* Fall through. */
  case FFEINFO_basictypeANY:
    return error_mark_node;
  }
      break;

    case FFEBLD_opOR:
      switch (bt)
  {
  case FFEINFO_basictypeLOGICAL:
    item
      = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
           ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
         ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
    return convert (tree_type, item);

  case FFEINFO_basictypeINTEGER:
    return ffecom_2 (BIT_IOR_EXPR, tree_type,
         ffecom_expr (ffebld_left (expr)),
         ffecom_expr (ffebld_right (expr)));

  default:
    assert ("OR bad basictype" == NULL);
    /* Fall through. */
  case FFEINFO_basictypeANY:
    return error_mark_node;
  }
      break;

    case FFEBLD_opXOR:
    case FFEBLD_opNEQV:
      switch (bt)
  {
  case FFEINFO_basictypeLOGICAL:
    item
      = ffecom_2 (NE_EXPR, integer_type_node,
      ffecom_expr (ffebld_left (expr)),
      ffecom_expr (ffebld_right (expr)));
    return convert (tree_type, ffecom_truth_value (item));

  case FFEINFO_basictypeINTEGER:
    return ffecom_2 (BIT_XOR_EXPR, tree_type,
         ffecom_expr (ffebld_left (expr)),
         ffecom_expr (ffebld_right (expr)));

  default:
    assert ("XOR/NEQV bad basictype" == NULL);
    /* Fall through. */
  case FFEINFO_basictypeANY:
    return error_mark_node;
  }
      break;

    case FFEBLD_opEQV:
      switch (bt)
  {
  case FFEINFO_basictypeLOGICAL:
    item
      = ffecom_2 (EQ_EXPR, integer_type_node,
      ffecom_expr (ffebld_left (expr)),
      ffecom_expr (ffebld_right (expr)));
    return convert (tree_type, ffecom_truth_value (item));

  case FFEINFO_basictypeINTEGER:
    return
      ffecom_1 (BIT_NOT_EXPR, tree_type,
          ffecom_2 (BIT_XOR_EXPR, tree_type,
        ffecom_expr (ffebld_left (expr)),
        ffecom_expr (ffebld_right (expr))));

  default:
    assert ("EQV bad basictype" == NULL);
    /* Fall through. */
  case FFEINFO_basictypeANY:
    return error_mark_node;
  }
      break;

    case FFEBLD_opCONVERT:
      if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
  return error_mark_node;

      switch (bt)
  {
  case FFEINFO_basictypeLOGICAL:
  case FFEINFO_basictypeINTEGER:
  case FFEINFO_basictypeREAL:
    return convert (tree_type, ffecom_expr (ffebld_left (expr)));

  case FFEINFO_basictypeCOMPLEX:
    switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
      {
      case FFEINFO_basictypeINTEGER:
      case FFEINFO_basictypeLOGICAL:
      case FFEINFO_basictypeREAL:
        item = ffecom_expr (ffebld_left (expr));
        if (item == error_mark_node)
    return error_mark_node;
        /* convert() takes care of converting to the subtype first,
     at least in gcc-2.7.2. */
        item = convert (tree_type, item);
        return item;

      case FFEINFO_basictypeCOMPLEX:
        return convert (tree_type, ffecom_expr (ffebld_left (expr)));

      default:
        assert ("CONVERT COMPLEX bad basictype" == NULL);
        /* Fall through. */
      case FFEINFO_basictypeANY:
        return error_mark_node;
      }
    break;

  default:
    assert ("CONVERT bad basictype" == NULL);
    /* Fall through. */
  case FFEINFO_basictypeANY:
    return error_mark_node;
  }
      break;

    case FFEBLD_opLT:
      code = LT_EXPR;
      goto relational;    /* :::::::::::::::::::: */

    case FFEBLD_opLE:
      code = LE_EXPR;
      goto relational;    /* :::::::::::::::::::: */

    case FFEBLD_opEQ:
      code = EQ_EXPR;
      goto relational;    /* :::::::::::::::::::: */

    case FFEBLD_opNE:
      code = NE_EXPR;
      goto relational;    /* :::::::::::::::::::: */

    case FFEBLD_opGT:
      code = GT_EXPR;
      goto relational;    /* :::::::::::::::::::: */

    case FFEBLD_opGE:
      code = GE_EXPR;

    relational:   /* :::::::::::::::::::: */
      switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  {
  case FFEINFO_basictypeLOGICAL:
  case FFEINFO_basictypeINTEGER:
  case FFEINFO_basictypeREAL:
    item = ffecom_2 (code, integer_type_node,
         ffecom_expr (ffebld_left (expr)),
         ffecom_expr (ffebld_right (expr)));
    return convert (tree_type, item);

  case FFEINFO_basictypeCOMPLEX:
    assert (code == EQ_EXPR || code == NE_EXPR);
    {
      tree real_type;
      tree arg1 = ffecom_expr (ffebld_left (expr));
      tree arg2 = ffecom_expr (ffebld_right (expr));

      if (arg1 == error_mark_node || arg2 == error_mark_node)
        return error_mark_node;

      arg1 = ffecom_save_tree (arg1);
      arg2 = ffecom_save_tree (arg2);

      if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
        {
    real_type = TREE_TYPE (TREE_TYPE (arg1));
    assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
        }
      else
        {
    real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
    assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
        }

      item
        = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
        ffecom_2 (EQ_EXPR, integer_type_node,
          ffecom_1 (REALPART_EXPR, real_type, arg1),
         ffecom_1 (REALPART_EXPR, real_type, arg2)),
        ffecom_2 (EQ_EXPR, integer_type_node,
          ffecom_1 (IMAGPART_EXPR, real_type, arg1),
            ffecom_1 (IMAGPART_EXPR, real_type,
                arg2)));
      if (code == EQ_EXPR)
        item = ffecom_truth_value (item);
      else
        item = ffecom_truth_value_invert (item);
      return convert (tree_type, item);
    }

  case FFEINFO_basictypeCHARACTER:
    {
      ffebld left = ffebld_left (expr);
      ffebld right = ffebld_right (expr);
      tree left_tree;
      tree right_tree;
      tree left_length;
      tree right_length;

      /* f2c run-time functions do the implicit blank-padding for us,
         so we don't usually have to implement blank-padding ourselves.
         (The exception is when we pass an argument to a separately
         compiled statement function -- if we know the arg is not the
         same length as the dummy, we must truncate or extend it.  If
         we "inline" statement functions, that necessity goes away as
         well.)

         Strip off the CONVERT operators that blank-pad.  (Truncation by
         CONVERT shouldn't happen here, but it can happen in
         assignments.) */

      while (ffebld_op (left) == FFEBLD_opCONVERT)
        left = ffebld_left (left);
      while (ffebld_op (right) == FFEBLD_opCONVERT)
        right = ffebld_left (right);

      left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
      right_tree = ffecom_arg_ptr_to_expr (right, &right_length);

      if (left_tree == error_mark_node || left_length == error_mark_node
    || right_tree == error_mark_node
    || right_length == error_mark_node)
        return error_mark_node;

      if ((ffebld_size_known (left) == 1)
    && (ffebld_size_known (right) == 1))
        {
    left_tree
      = ffecom_1 (INDIRECT_REF,
          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
            left_tree);
    right_tree
      = ffecom_1 (INDIRECT_REF,
         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
            right_tree);

    item
      = ffecom_2 (code, integer_type_node,
            ffecom_2 (ARRAY_REF,
          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
          left_tree,
          integer_one_node),
            ffecom_2 (ARRAY_REF,
         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
          right_tree,
          integer_one_node));
        }
      else
        {
    item = build_tree_list (NULL_TREE, left_tree);
    TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
    TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
                     left_length);
    TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
      = build_tree_list (NULL_TREE, right_length);
    item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
    item = ffecom_2 (code, integer_type_node,
         item,
         convert (TREE_TYPE (item),
            integer_zero_node));
        }
      item = convert (tree_type, item);
    }

    return item;

  default:
    assert ("relational bad basictype" == NULL);
    /* Fall through. */
  case FFEINFO_basictypeANY:
    return error_mark_node;
  }
      break;

    case FFEBLD_opPERCENT_LOC:
      item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
      return convert (tree_type, item);

    case FFEBLD_opPERCENT_VAL:
      item = ffecom_arg_expr (ffebld_left (expr), &list);
      return convert (tree_type, item);

    case FFEBLD_opITEM:
    case FFEBLD_opSTAR:
    case FFEBLD_opBOUNDS:
    case FFEBLD_opREPEAT:
    case FFEBLD_opLABTER:
    case FFEBLD_opLABTOK:
    case FFEBLD_opIMPDO:
    case FFEBLD_opCONCATENATE:
    case FFEBLD_opSUBSTR:
    default:
      assert ("bad op" == NULL);
      /* Fall through. */
    case FFEBLD_opANY:
      return error_mark_node;
    }

#if 1
  assert ("didn't think anything got here anymore!!" == NULL);
#else
  switch (ffebld_arity (expr))
    {
    case 2:
      TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
      TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
      if (TREE_OPERAND (item, 0) == error_mark_node
    || TREE_OPERAND (item, 1) == error_mark_node)
  return error_mark_node;
      break;

    case 1:
      TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
      if (TREE_OPERAND (item, 0) == error_mark_node)
  return error_mark_node;
      break;

    default:
      break;
    }

  return fold (item);
#endif
}

/* Returns the tree that does the intrinsic invocation.

   Note: this function applies only to intrinsics returning
   CHARACTER*1 or non-CHARACTER results, and to intrinsic
   subroutines.  */

static tree
ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
      ffebld dest, bool *dest_used)
{
  tree expr_tree;
  tree saved_expr1;   /* For those who need it. */
  tree saved_expr2;   /* For those who need it. */
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  tree tree_type;
  tree arg1_type;
  tree real_type;   /* REAL type corresponding to COMPLEX. */
  tree tempvar;
  ffebld list = ffebld_right (expr);  /* List of (some) args. */
  ffebld arg1;      /* For handy reference. */
  ffebld arg2;
  ffebld arg3;
  ffeintrinImp codegen_imp;
  ffecomGfrt gfrt;

  assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);

  if (dest_used != NULL)
    *dest_used = FALSE;

  bt = ffeinfo_basictype (ffebld_info (expr));
  kt = ffeinfo_kindtype (ffebld_info (expr));
  tree_type = ffecom_tree_type[bt][kt];

  if (list != NULL)
    {
      arg1 = ffebld_head (list);
      if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
  return error_mark_node;
      if ((list = ffebld_trail (list)) != NULL)
  {
    arg2 = ffebld_head (list);
    if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
      return error_mark_node;
    if ((list = ffebld_trail (list)) != NULL)
      {
        arg3 = ffebld_head (list);
        if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
    return error_mark_node;
      }
    else
      arg3 = NULL;
  }
      else
  arg2 = arg3 = NULL;
    }
  else
    arg1 = arg2 = arg3 = NULL;

  /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
     args.  This is used by the MAX/MIN expansions. */

  if (arg1 != NULL)
    arg1_type = ffecom_tree_type
      [ffeinfo_basictype (ffebld_info (arg1))]
      [ffeinfo_kindtype (ffebld_info (arg1))];
  else
    arg1_type = NULL_TREE;  /* Really not needed, but might catch bugs
           here. */

  /* There are several ways for each of the cases in the following switch
     statements to exit (from simplest to use to most complicated):

     break;  (when expr_tree == NULL)

     A standard call is made to the specific intrinsic just as if it had been
     passed in as a dummy procedure and called as any old procedure.  This
     method can produce slower code but in some cases it's the easiest way for
     now.  However, if a (presumably faster) direct call is available,
     that is used, so this is the easiest way in many more cases now.

     gfrt = FFECOM_gfrtWHATEVER;
     break;

     gfrt contains the gfrt index of a library function to call, passing the
     argument(s) by value rather than by reference.  Used when a more
     careful choice of library function is needed than that provided
     by the vanilla `break;'.

     return expr_tree;

     The expr_tree has been completely set up and is ready to be returned
     as is.  No further actions are taken.  Use this when the tree is not
     in the simple form for one of the arity_n labels.   */

  /* For info on how the switch statement cases were written, see the files
     enclosed in comments below the switch statement. */

  codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
  gfrt = ffeintrin_gfrt_direct (codegen_imp);
  if (gfrt == FFECOM_gfrt)
    gfrt = ffeintrin_gfrt_indirect (codegen_imp);

  switch (codegen_imp)
    {
    case FFEINTRIN_impABS:
    case FFEINTRIN_impCABS:
    case FFEINTRIN_impCDABS:
    case FFEINTRIN_impDABS:
    case FFEINTRIN_impIABS:
      if (ffeinfo_basictype (ffebld_info (arg1))
    == FFEINFO_basictypeCOMPLEX)
  {
    if (kt == FFEINFO_kindtypeREAL1)
      gfrt = FFECOM_gfrtCABS;
    else if (kt == FFEINFO_kindtypeREAL2)
      gfrt = FFECOM_gfrtCDABS;
    break;
  }
      return ffecom_1 (ABS_EXPR, tree_type,
           convert (tree_type, ffecom_expr (arg1)));

    case FFEINTRIN_impACOS:
    case FFEINTRIN_impDACOS:
      break;

    case FFEINTRIN_impAIMAG:
    case FFEINTRIN_impDIMAG:
    case FFEINTRIN_impIMAGPART:
      if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
  arg1_type = TREE_TYPE (arg1_type);
      else
  arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));

      return
  convert (tree_type,
     ffecom_1 (IMAGPART_EXPR, arg1_type,
         ffecom_expr (arg1)));

    case FFEINTRIN_impAINT:
    case FFEINTRIN_impDINT:
#if 0
      /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
      return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
#else /* in the meantime, must use floor to avoid range problems with ints */
      /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
      saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
      return
  convert (tree_type,
     ffecom_3 (COND_EXPR, double_type_node,
         ffecom_truth_value
         (ffecom_2 (GE_EXPR, integer_type_node,
              saved_expr1,
              convert (arg1_type,
                 ffecom_float_zero_))),
         ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
               build_tree_list (NULL_TREE,
              convert (double_type_node,
                 saved_expr1)),
               NULL_TREE),
         ffecom_1 (NEGATE_EXPR, double_type_node,
             ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
             build_tree_list (NULL_TREE,
              convert (double_type_node,
                  ffecom_1 (NEGATE_EXPR,
                arg1_type,
                     saved_expr1))),
                   NULL_TREE)
             ))
     );
#endif

    case FFEINTRIN_impANINT:
    case FFEINTRIN_impDNINT:
#if 0       /* This way of doing it won't handle real
           numbers of large magnitudes. */
      saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
      expr_tree = convert (tree_type,
         convert (integer_type_node,
            ffecom_3 (COND_EXPR, tree_type,
                ffecom_truth_value
                (ffecom_2 (GE_EXPR,
               integer_type_node,
               saved_expr1,
                   ffecom_float_zero_)),
                ffecom_2 (PLUS_EXPR,
              tree_type,
              saved_expr1,
              ffecom_float_half_),
                ffecom_2 (MINUS_EXPR,
              tree_type,
              saved_expr1,
                 ffecom_float_half_))));
      return expr_tree;
#else /* So we instead call floor. */
      /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
      saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
      return
  convert (tree_type,
     ffecom_3 (COND_EXPR, double_type_node,
         ffecom_truth_value
         (ffecom_2 (GE_EXPR, integer_type_node,
              saved_expr1,
              convert (arg1_type,
                 ffecom_float_zero_))),
         ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
               build_tree_list (NULL_TREE,
              convert (double_type_node,
                 ffecom_2 (PLUS_EXPR,
                     arg1_type,
                     saved_expr1,
                     convert (arg1_type,
                        ffecom_float_half_)))),
               NULL_TREE),
         ffecom_1 (NEGATE_EXPR, double_type_node,
             ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
                   build_tree_list (NULL_TREE,
                  convert (double_type_node,
                     ffecom_2 (MINUS_EXPR,
                         arg1_type,
                         convert (arg1_type,
                            ffecom_float_half_),
                         saved_expr1))),
                   NULL_TREE))
         )
     );
#endif

    case FFEINTRIN_impASIN:
    case FFEINTRIN_impDASIN:
    case FFEINTRIN_impATAN:
    case FFEINTRIN_impDATAN:
    case FFEINTRIN_impATAN2:
    case FFEINTRIN_impDATAN2:
      break;

    case FFEINTRIN_impCHAR:
    case FFEINTRIN_impACHAR:
#ifdef HOHO
      tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
#else
      tempvar = ffebld_nonter_hook (expr);
      assert (tempvar);
#endif
      {
  tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));

  expr_tree = ffecom_modify (tmv,
           ffecom_2 (ARRAY_REF, tmv, tempvar,
               integer_one_node),
           convert (tmv, ffecom_expr (arg1)));
      }
      expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
          expr_tree,
          tempvar);
      expr_tree = ffecom_1 (ADDR_EXPR,
          build_pointer_type (TREE_TYPE (expr_tree)),
          expr_tree);
      return expr_tree;

    case FFEINTRIN_impCMPLX:
    case FFEINTRIN_impDCMPLX:
      if (arg2 == NULL)
  return
    convert (tree_type, ffecom_expr (arg1));

      real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
      return
  ffecom_2 (COMPLEX_EXPR, tree_type,
      convert (real_type, ffecom_expr (arg1)),
      convert (real_type,
         ffecom_expr (arg2)));

    case FFEINTRIN_impCOMPLEX:
      return
  ffecom_2 (COMPLEX_EXPR, tree_type,
      ffecom_expr (arg1),
      ffecom_expr (arg2));

    case FFEINTRIN_impCONJG:
    case FFEINTRIN_impDCONJG:
      {
  tree arg1_tree;

  real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
  arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
  return
    ffecom_2 (COMPLEX_EXPR, tree_type,
        ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
        ffecom_1 (NEGATE_EXPR, real_type,
            ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
      }

    case FFEINTRIN_impCOS:
    case FFEINTRIN_impCCOS:
    case FFEINTRIN_impCDCOS:
    case FFEINTRIN_impDCOS:
      if (bt == FFEINFO_basictypeCOMPLEX)
  {
    if (kt == FFEINFO_kindtypeREAL1)
      gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
    else if (kt == FFEINFO_kindtypeREAL2)
      gfrt = FFECOM_gfrtCDCOS;  /* Overlapping result okay. */
  }
      break;

    case FFEINTRIN_impCOSH:
    case FFEINTRIN_impDCOSH:
      break;

    case FFEINTRIN_impDBLE:
    case FFEINTRIN_impDFLOAT:
    case FFEINTRIN_impDREAL:
    case FFEINTRIN_impFLOAT:
    case FFEINTRIN_impIDINT:
    case FFEINTRIN_impIFIX:
    case FFEINTRIN_impINT2:
    case FFEINTRIN_impINT8:
    case FFEINTRIN_impINT:
    case FFEINTRIN_impLONG:
    case FFEINTRIN_impREAL:
    case FFEINTRIN_impSHORT:
    case FFEINTRIN_impSNGL:
      return convert (tree_type, ffecom_expr (arg1));

    case FFEINTRIN_impDIM:
    case FFEINTRIN_impDDIM:
    case FFEINTRIN_impIDIM:
      saved_expr1 = ffecom_save_tree (convert (tree_type,
                 ffecom_expr (arg1)));
      saved_expr2 = ffecom_save_tree (convert (tree_type,
                 ffecom_expr (arg2)));
      return
  ffecom_3 (COND_EXPR, tree_type,
      ffecom_truth_value
      (ffecom_2 (GT_EXPR, integer_type_node,
           saved_expr1,
           saved_expr2)),
      ffecom_2 (MINUS_EXPR, tree_type,
          saved_expr1,
          saved_expr2),
      convert (tree_type, ffecom_float_zero_));

    case FFEINTRIN_impDPROD:
      return
  ffecom_2 (MULT_EXPR, tree_type,
      convert (tree_type, ffecom_expr (arg1)),
      convert (tree_type, ffecom_expr (arg2)));

    case FFEINTRIN_impEXP:
    case FFEINTRIN_impCDEXP:
    case FFEINTRIN_impCEXP:
    case FFEINTRIN_impDEXP:
      if (bt == FFEINFO_basictypeCOMPLEX)
  {
    if (kt == FFEINFO_kindtypeREAL1)
      gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
    else if (kt == FFEINFO_kindtypeREAL2)
      gfrt = FFECOM_gfrtCDEXP;  /* Overlapping result okay. */
  }
      break;

    case FFEINTRIN_impICHAR:
    case FFEINTRIN_impIACHAR:
#if 0       /* The simple approach. */
      ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
      expr_tree
  = ffecom_1 (INDIRECT_REF,
        TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
        expr_tree);
      expr_tree
  = ffecom_2 (ARRAY_REF,
        TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
        expr_tree,
        integer_one_node);
      return convert (tree_type, expr_tree);
#else /* The more interesting (and more optimal) approach. */
      expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
      expr_tree = ffecom_3 (COND_EXPR, tree_type,
          saved_expr1,
          expr_tree,
          convert (tree_type, integer_zero_node));
      return expr_tree;
#endif

    case FFEINTRIN_impINDEX:
      break;

    case FFEINTRIN_impLEN:
#if 0
      break;          /* The simple approach. */
#else
      return ffecom_intrinsic_len_ (arg1);  /* The more optimal approach. */
#endif

    case FFEINTRIN_impLGE:
    case FFEINTRIN_impLGT:
    case FFEINTRIN_impLLE:
    case FFEINTRIN_impLLT:
      break;

    case FFEINTRIN_impLOG:
    case FFEINTRIN_impALOG:
    case FFEINTRIN_impCDLOG:
    case FFEINTRIN_impCLOG:
    case FFEINTRIN_impDLOG:
      if (bt == FFEINFO_basictypeCOMPLEX)
  {
    if (kt == FFEINFO_kindtypeREAL1)
      gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
    else if (kt == FFEINFO_kindtypeREAL2)
      gfrt = FFECOM_gfrtCDLOG;  /* Overlapping result okay. */
  }
      break;

    case FFEINTRIN_impLOG10:
    case FFEINTRIN_impALOG10:
    case FFEINTRIN_impDLOG10:
      if (gfrt != FFECOM_gfrt)
  break;  /* Already picked one, stick with it. */

      if (kt == FFEINFO_kindtypeREAL1)
  /* We used to call FFECOM_gfrtALOG10 here.  */
  gfrt = FFECOM_gfrtL_LOG10;
      else if (kt == FFEINFO_kindtypeREAL2)
  /* We used to call FFECOM_gfrtDLOG10 here.  */
  gfrt = FFECOM_gfrtL_LOG10;
      break;

    case FFEINTRIN_impMAX:
    case FFEINTRIN_impAMAX0:
    case FFEINTRIN_impAMAX1:
    case FFEINTRIN_impDMAX1:
    case FFEINTRIN_impMAX0:
    case FFEINTRIN_impMAX1:
      if (bt != ffeinfo_basictype (ffebld_info (arg1)))
  arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
      else
  arg1_type = tree_type;
      expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
          convert (arg1_type, ffecom_expr (arg1)),
          convert (arg1_type, ffecom_expr (arg2)));
      for (; list != NULL; list = ffebld_trail (list))
  {
    if ((ffebld_head (list) == NULL)
        || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
      continue;
    expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
        expr_tree,
        convert (arg1_type,
           ffecom_expr (ffebld_head (list))));
  }
      return convert (tree_type, expr_tree);

    case FFEINTRIN_impMIN:
    case FFEINTRIN_impAMIN0:
    case FFEINTRIN_impAMIN1:
    case FFEINTRIN_impDMIN1:
    case FFEINTRIN_impMIN0:
    case FFEINTRIN_impMIN1:
      if (bt != ffeinfo_basictype (ffebld_info (arg1)))
  arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
      else
  arg1_type = tree_type;
      expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
          convert (arg1_type, ffecom_expr (arg1)),
          convert (arg1_type, ffecom_expr (arg2)));
      for (; list != NULL; list = ffebld_trail (list))
  {
    if ((ffebld_head (list) == NULL)
        || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
      continue;
    expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
        expr_tree,
        convert (arg1_type,
           ffecom_expr (ffebld_head (list))));
  }
      return convert (tree_type, expr_tree);

    case FFEINTRIN_impMOD:
    case FFEINTRIN_impAMOD:
    case FFEINTRIN_impDMOD:
      if (bt != FFEINFO_basictypeREAL)
  return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
       convert (tree_type, ffecom_expr (arg1)),
       convert (tree_type, ffecom_expr (arg2)));

      if (kt == FFEINFO_kindtypeREAL1)
  /* We used to call FFECOM_gfrtAMOD here.  */
  gfrt = FFECOM_gfrtL_FMOD;
      else if (kt == FFEINFO_kindtypeREAL2)
  /* We used to call FFECOM_gfrtDMOD here.  */
  gfrt = FFECOM_gfrtL_FMOD;
      break;

    case FFEINTRIN_impNINT:
    case FFEINTRIN_impIDNINT:
#if 0
      /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
      return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
#else
      /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
      saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
      return
  convert (ffecom_integer_type_node,
     ffecom_3 (COND_EXPR, arg1_type,
         ffecom_truth_value
         (ffecom_2 (GE_EXPR, integer_type_node,
              saved_expr1,
              convert (arg1_type,
                 ffecom_float_zero_))),
         ffecom_2 (PLUS_EXPR, arg1_type,
             saved_expr1,
             convert (arg1_type,
                ffecom_float_half_)),
         ffecom_2 (MINUS_EXPR, arg1_type,
             saved_expr1,
             convert (arg1_type,
                ffecom_float_half_))));
#endif

    case FFEINTRIN_impSIGN:
    case FFEINTRIN_impDSIGN:
    case FFEINTRIN_impISIGN:
      {
  tree arg2_tree = ffecom_expr (arg2);

  saved_expr1
    = ffecom_save_tree
    (ffecom_1 (ABS_EXPR, tree_type,
         convert (tree_type,
            ffecom_expr (arg1))));
  expr_tree
    = ffecom_3 (COND_EXPR, tree_type,
          ffecom_truth_value
          (ffecom_2 (GE_EXPR, integer_type_node,
         arg2_tree,
         convert (TREE_TYPE (arg2_tree),
            integer_zero_node))),
          saved_expr1,
          ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
  /* Make sure SAVE_EXPRs get referenced early enough. */
  expr_tree
    = ffecom_2 (COMPOUND_EXPR, tree_type,
          convert (void_type_node, saved_expr1),
          expr_tree);
      }
      return expr_tree;

    case FFEINTRIN_impSIN:
    case FFEINTRIN_impCDSIN:
    case FFEINTRIN_impCSIN:
    case FFEINTRIN_impDSIN:
      if (bt == FFEINFO_basictypeCOMPLEX)
  {
    if (kt == FFEINFO_kindtypeREAL1)
      gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
    else if (kt == FFEINFO_kindtypeREAL2)
      gfrt = FFECOM_gfrtCDSIN;  /* Overlapping result okay. */
  }
      break;

    case FFEINTRIN_impSINH:
    case FFEINTRIN_impDSINH:
      break;

    case FFEINTRIN_impSQRT:
    case FFEINTRIN_impCDSQRT:
    case FFEINTRIN_impCSQRT:
    case FFEINTRIN_impDSQRT:
      if (bt == FFEINFO_basictypeCOMPLEX)
  {
    if (kt == FFEINFO_kindtypeREAL1)
      gfrt = FFECOM_gfrtCSQRT;  /* Overlapping result okay. */
    else if (kt == FFEINFO_kindtypeREAL2)
      gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
  }
      break;

    case FFEINTRIN_impTAN:
    case FFEINTRIN_impDTAN:
    case FFEINTRIN_impTANH:
    case FFEINTRIN_impDTANH:
      break;

    case FFEINTRIN_impREALPART:
      if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
  arg1_type = TREE_TYPE (arg1_type);
      else
  arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));

      return
  convert (tree_type,
     ffecom_1 (REALPART_EXPR, arg1_type,
         ffecom_expr (arg1)));

    case FFEINTRIN_impIAND:
    case FFEINTRIN_impAND:
      return ffecom_2 (BIT_AND_EXPR, tree_type,
           convert (tree_type,
        ffecom_expr (arg1)),
           convert (tree_type,
        ffecom_expr (arg2)));

    case FFEINTRIN_impIOR:
    case FFEINTRIN_impOR:
      return ffecom_2 (BIT_IOR_EXPR, tree_type,
           convert (tree_type,
        ffecom_expr (arg1)),
           convert (tree_type,
        ffecom_expr (arg2)));

    case FFEINTRIN_impIEOR:
    case FFEINTRIN_impXOR:
      return ffecom_2 (BIT_XOR_EXPR, tree_type,
           convert (tree_type,
        ffecom_expr (arg1)),
           convert (tree_type,
        ffecom_expr (arg2)));

    case FFEINTRIN_impLSHIFT:
      return ffecom_2 (LSHIFT_EXPR, tree_type,
           ffecom_expr (arg1),
           convert (integer_type_node,
        ffecom_expr (arg2)));

    case FFEINTRIN_impRSHIFT:
      return ffecom_2 (RSHIFT_EXPR, tree_type,
           ffecom_expr (arg1),
           convert (integer_type_node,
        ffecom_expr (arg2)));

    case FFEINTRIN_impNOT:
      return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));

    case FFEINTRIN_impBIT_SIZE:
      return convert (tree_type, TYPE_SIZE (arg1_type));

    case FFEINTRIN_impBTEST:
      {
  ffetargetLogical1 target_true;
  ffetargetLogical1 target_false;
  tree true_tree;
  tree false_tree;

  ffetarget_logical1 (&target_true, TRUE);
  ffetarget_logical1 (&target_false, FALSE);
  if (target_true == 1)
    true_tree = convert (tree_type, integer_one_node);
  else
    true_tree = convert (tree_type, build_int_2 (target_true, 0));
  if (target_false == 0)
    false_tree = convert (tree_type, integer_zero_node);
  else
    false_tree = convert (tree_type, build_int_2 (target_false, 0));

  return
    ffecom_3 (COND_EXPR, tree_type,
        ffecom_truth_value
        (ffecom_2 (EQ_EXPR, integer_type_node,
             ffecom_2 (BIT_AND_EXPR, arg1_type,
           ffecom_expr (arg1),
           ffecom_2 (LSHIFT_EXPR, arg1_type,
               convert (arg1_type,
                integer_one_node),
               convert (integer_type_node,
                  ffecom_expr (arg2)))),
             convert (arg1_type,
          integer_zero_node))),
        false_tree,
        true_tree);
      }

    case FFEINTRIN_impIBCLR:
      return
  ffecom_2 (BIT_AND_EXPR, tree_type,
      ffecom_expr (arg1),
      ffecom_1 (BIT_NOT_EXPR, tree_type,
          ffecom_2 (LSHIFT_EXPR, tree_type,
              convert (tree_type,
                 integer_one_node),
              convert (integer_type_node,
                 ffecom_expr (arg2)))));

    case FFEINTRIN_impIBITS:
      {
  tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
                ffecom_expr (arg3)));
  tree uns_type
  = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];

  expr_tree
    = ffecom_2 (BIT_AND_EXPR, tree_type,
          ffecom_2 (RSHIFT_EXPR, tree_type,
        ffecom_expr (arg1),
        convert (integer_type_node,
           ffecom_expr (arg2))),
          convert (tree_type,
             ffecom_2 (RSHIFT_EXPR, uns_type,
           ffecom_1 (BIT_NOT_EXPR,
               uns_type,
               convert (uns_type,
              integer_zero_node)),
           ffecom_2 (MINUS_EXPR,
               integer_type_node,
               TYPE_SIZE (uns_type),
               arg3_tree))));
  /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
  expr_tree
    = ffecom_3 (COND_EXPR, tree_type,
          ffecom_truth_value
          (ffecom_2 (NE_EXPR, integer_type_node,
         arg3_tree,
         integer_zero_node)),
          expr_tree,
          convert (tree_type, integer_zero_node));
      }
      return expr_tree;

    case FFEINTRIN_impIBSET:
      return
  ffecom_2 (BIT_IOR_EXPR, tree_type,
      ffecom_expr (arg1),
      ffecom_2 (LSHIFT_EXPR, tree_type,
          convert (tree_type, integer_one_node),
          convert (integer_type_node,
             ffecom_expr (arg2))));

    case FFEINTRIN_impISHFT:
      {
  tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
  tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
                ffecom_expr (arg2)));
  tree uns_type
  = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];

  expr_tree
    = ffecom_3 (COND_EXPR, tree_type,
          ffecom_truth_value
          (ffecom_2 (GE_EXPR, integer_type_node,
         arg2_tree,
         integer_zero_node)),
          ffecom_2 (LSHIFT_EXPR, tree_type,
        arg1_tree,
        arg2_tree),
          convert (tree_type,
             ffecom_2 (RSHIFT_EXPR, uns_type,
           convert (uns_type, arg1_tree),
           ffecom_1 (NEGATE_EXPR,
               integer_type_node,
               arg2_tree))));
  /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
  expr_tree
    = ffecom_3 (COND_EXPR, tree_type,
          ffecom_truth_value
          (ffecom_2 (NE_EXPR, integer_type_node,
         ffecom_1 (ABS_EXPR,
             integer_type_node,
             arg2_tree),
         TYPE_SIZE (uns_type))),
          expr_tree,
          convert (tree_type, integer_zero_node));
  /* Make sure SAVE_EXPRs get referenced early enough. */
  expr_tree
    = ffecom_2 (COMPOUND_EXPR, tree_type,
          convert (void_type_node, arg1_tree),
          ffecom_2 (COMPOUND_EXPR, tree_type,
        convert (void_type_node, arg2_tree),
        expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impISHFTC:
      {
  tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
  tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
                ffecom_expr (arg2)));
  tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
  : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
  tree shift_neg;
  tree shift_pos;
  tree mask_arg1;
  tree masked_arg1;
  tree uns_type
  = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];

  mask_arg1
    = ffecom_2 (LSHIFT_EXPR, tree_type,
          ffecom_1 (BIT_NOT_EXPR, tree_type,
        convert (tree_type, integer_zero_node)),
          arg3_tree);
  /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
  mask_arg1
    = ffecom_3 (COND_EXPR, tree_type,
          ffecom_truth_value
          (ffecom_2 (NE_EXPR, integer_type_node,
         arg3_tree,
         TYPE_SIZE (uns_type))),
          mask_arg1,
          convert (tree_type, integer_zero_node));
  mask_arg1 = ffecom_save_tree (mask_arg1);
  masked_arg1
    = ffecom_2 (BIT_AND_EXPR, tree_type,
          arg1_tree,
          ffecom_1 (BIT_NOT_EXPR, tree_type,
        mask_arg1));
  masked_arg1 = ffecom_save_tree (masked_arg1);
  shift_neg
    = ffecom_2 (BIT_IOR_EXPR, tree_type,
          convert (tree_type,
             ffecom_2 (RSHIFT_EXPR, uns_type,
           convert (uns_type, masked_arg1),
           ffecom_1 (NEGATE_EXPR,
               integer_type_node,
               arg2_tree))),
          ffecom_2 (LSHIFT_EXPR, tree_type,
        arg1_tree,
        ffecom_2 (PLUS_EXPR, integer_type_node,
            arg2_tree,
            arg3_tree)));
  shift_pos
    = ffecom_2 (BIT_IOR_EXPR, tree_type,
          ffecom_2 (LSHIFT_EXPR, tree_type,
        arg1_tree,
        arg2_tree),
          convert (tree_type,
             ffecom_2 (RSHIFT_EXPR, uns_type,
           convert (uns_type, masked_arg1),
           ffecom_2 (MINUS_EXPR,
               integer_type_node,
               arg3_tree,
               arg2_tree))));
  expr_tree
    = ffecom_3 (COND_EXPR, tree_type,
          ffecom_truth_value
          (ffecom_2 (LT_EXPR, integer_type_node,
         arg2_tree,
         integer_zero_node)),
          shift_neg,
          shift_pos);
  expr_tree
    = ffecom_2 (BIT_IOR_EXPR, tree_type,
          ffecom_2 (BIT_AND_EXPR, tree_type,
        mask_arg1,
        arg1_tree),
          ffecom_2 (BIT_AND_EXPR, tree_type,
        ffecom_1 (BIT_NOT_EXPR, tree_type,
            mask_arg1),
        expr_tree));
  expr_tree
    = ffecom_3 (COND_EXPR, tree_type,
          ffecom_truth_value
          (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
         ffecom_2 (EQ_EXPR, integer_type_node,
             ffecom_1 (ABS_EXPR,
                 integer_type_node,
                 arg2_tree),
             arg3_tree),
         ffecom_2 (EQ_EXPR, integer_type_node,
             arg2_tree,
             integer_zero_node))),
          arg1_tree,
          expr_tree);
  /* Make sure SAVE_EXPRs get referenced early enough. */
  expr_tree
    = ffecom_2 (COMPOUND_EXPR, tree_type,
          convert (void_type_node, arg1_tree),
          ffecom_2 (COMPOUND_EXPR, tree_type,
        convert (void_type_node, arg2_tree),
        ffecom_2 (COMPOUND_EXPR, tree_type,
            convert (void_type_node,
               mask_arg1),
            ffecom_2 (COMPOUND_EXPR, tree_type,
                convert (void_type_node,
                   masked_arg1),
                expr_tree))));
  expr_tree
    = ffecom_2 (COMPOUND_EXPR, tree_type,
          convert (void_type_node,
             arg3_tree),
          expr_tree);
      }
      return expr_tree;

    case FFEINTRIN_impLOC:
      {
  tree arg1_tree = ffecom_expr (arg1);

  expr_tree
    = convert (tree_type,
         ffecom_1 (ADDR_EXPR,
             build_pointer_type (TREE_TYPE (arg1_tree)),
             arg1_tree));
      }
      return expr_tree;

    case FFEINTRIN_impMVBITS:
      {
  tree arg1_tree;
  tree arg2_tree;
  tree arg3_tree;
  ffebld arg4 = ffebld_head (ffebld_trail (list));
  tree arg4_tree;
  tree arg4_type;
  ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
  tree arg5_tree;
  tree prep_arg1;
  tree prep_arg4;
  tree arg5_plus_arg3;

  arg2_tree = convert (integer_type_node,
           ffecom_expr (arg2));
  arg3_tree = ffecom_save_tree (convert (integer_type_node,
                 ffecom_expr (arg3)));
  arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
  arg4_type = TREE_TYPE (arg4_tree);

  arg1_tree = ffecom_save_tree (convert (arg4_type,
                 ffecom_expr (arg1)));

  arg5_tree = ffecom_save_tree (convert (integer_type_node,
                 ffecom_expr (arg5)));

  prep_arg1
    = ffecom_2 (LSHIFT_EXPR, arg4_type,
          ffecom_2 (BIT_AND_EXPR, arg4_type,
        ffecom_2 (RSHIFT_EXPR, arg4_type,
            arg1_tree,
            arg2_tree),
        ffecom_1 (BIT_NOT_EXPR, arg4_type,
            ffecom_2 (LSHIFT_EXPR, arg4_type,
                ffecom_1 (BIT_NOT_EXPR,
                    arg4_type,
                    convert
                    (arg4_type,
              integer_zero_node)),
                arg3_tree))),
          arg5_tree);
  arg5_plus_arg3
    = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
          arg5_tree,
          arg3_tree));
  prep_arg4
    = ffecom_2 (LSHIFT_EXPR, arg4_type,
          ffecom_1 (BIT_NOT_EXPR, arg4_type,
        convert (arg4_type,
           integer_zero_node)),
          arg5_plus_arg3);
  /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
  prep_arg4
    = ffecom_3 (COND_EXPR, arg4_type,
          ffecom_truth_value
          (ffecom_2 (NE_EXPR, integer_type_node,
         arg5_plus_arg3,
         convert (TREE_TYPE (arg5_plus_arg3),
            TYPE_SIZE (arg4_type)))),
          prep_arg4,
          convert (arg4_type, integer_zero_node));
  prep_arg4
    = ffecom_2 (BIT_AND_EXPR, arg4_type,
          arg4_tree,
          ffecom_2 (BIT_IOR_EXPR, arg4_type,
        prep_arg4,
        ffecom_1 (BIT_NOT_EXPR, arg4_type,
            ffecom_2 (LSHIFT_EXPR, arg4_type,
                ffecom_1 (BIT_NOT_EXPR,
                    arg4_type,
                    convert
                    (arg4_type,
              integer_zero_node)),
                arg5_tree))));
  prep_arg1
    = ffecom_2 (BIT_IOR_EXPR, arg4_type,
          prep_arg1,
          prep_arg4);
  /* Fix up (twice), because LSHIFT_EXPR above
     can't shift over TYPE_SIZE.  */
  prep_arg1
    = ffecom_3 (COND_EXPR, arg4_type,
          ffecom_truth_value
          (ffecom_2 (NE_EXPR, integer_type_node,
         arg3_tree,
         convert (TREE_TYPE (arg3_tree),
            integer_zero_node))),
          prep_arg1,
          arg4_tree);
  prep_arg1
    = ffecom_3 (COND_EXPR, arg4_type,
          ffecom_truth_value
          (ffecom_2 (NE_EXPR, integer_type_node,
         arg3_tree,
         convert (TREE_TYPE (arg3_tree),
            TYPE_SIZE (arg4_type)))),
          prep_arg1,
          arg1_tree);
  expr_tree
    = ffecom_2s (MODIFY_EXPR, void_type_node,
           arg4_tree,
           prep_arg1);
  /* Make sure SAVE_EXPRs get referenced early enough. */
  expr_tree
    = ffecom_2 (COMPOUND_EXPR, void_type_node,
          arg1_tree,
          ffecom_2 (COMPOUND_EXPR, void_type_node,
        arg3_tree,
        ffecom_2 (COMPOUND_EXPR, void_type_node,
            arg5_tree,
            ffecom_2 (COMPOUND_EXPR, void_type_node,
                arg5_plus_arg3,
                expr_tree))));
  expr_tree
    = ffecom_2 (COMPOUND_EXPR, void_type_node,
          arg4_tree,
          expr_tree);

      }
      return expr_tree;

    case FFEINTRIN_impDERF:
    case FFEINTRIN_impERF:
    case FFEINTRIN_impDERFC:
    case FFEINTRIN_impERFC:
      break;

    case FFEINTRIN_impIARGC:
      /* extern int xargc; i__1 = xargc - 1; */
      expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
          ffecom_tree_xargc_,
          convert (TREE_TYPE (ffecom_tree_xargc_),
             integer_one_node));
      return expr_tree;

    case FFEINTRIN_impSIGNAL_func:
    case FFEINTRIN_impSIGNAL_subr:
      {
  tree arg1_tree;
  tree arg2_tree;
  tree arg3_tree;

  arg1_tree = convert (ffecom_f2c_integer_type_node,
           ffecom_expr (arg1));
  arg1_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg1_tree)),
            arg1_tree);

  /* Pass procedure as a pointer to it, anything else by value.  */
  if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
    arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
  else
    arg2_tree = ffecom_ptr_to_expr (arg2);
  arg2_tree = convert (TREE_TYPE (null_pointer_node),
           arg2_tree);

  if (arg3 != NULL)
    arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
  else
    arg3_tree = NULL_TREE;

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  TREE_CHAIN (arg1_tree) = arg2_tree;

  expr_tree
    = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
        ffecom_gfrt_kindtype (gfrt),
        FALSE,
        ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
         NULL_TREE :
         tree_type),
        arg1_tree,
        NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
        ffebld_nonter_hook (expr));

  if (arg3_tree != NULL_TREE)
    expr_tree
      = ffecom_modify (NULL_TREE, arg3_tree,
           convert (TREE_TYPE (arg3_tree),
              expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impALARM:
      {
  tree arg1_tree;
  tree arg2_tree;
  tree arg3_tree;

  arg1_tree = convert (ffecom_f2c_integer_type_node,
           ffecom_expr (arg1));
  arg1_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg1_tree)),
            arg1_tree);

  /* Pass procedure as a pointer to it, anything else by value.  */
  if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
    arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
  else
    arg2_tree = ffecom_ptr_to_expr (arg2);
  arg2_tree = convert (TREE_TYPE (null_pointer_node),
           arg2_tree);

  if (arg3 != NULL)
    arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
  else
    arg3_tree = NULL_TREE;

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  TREE_CHAIN (arg1_tree) = arg2_tree;

  expr_tree
    = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
        ffecom_gfrt_kindtype (gfrt),
        FALSE,
        NULL_TREE,
        arg1_tree,
        NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
        ffebld_nonter_hook (expr));

  if (arg3_tree != NULL_TREE)
    expr_tree
      = ffecom_modify (NULL_TREE, arg3_tree,
           convert (TREE_TYPE (arg3_tree),
              expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impCHDIR_subr:
    case FFEINTRIN_impFDATE_subr:
    case FFEINTRIN_impFGET_subr:
    case FFEINTRIN_impFPUT_subr:
    case FFEINTRIN_impGETCWD_subr:
    case FFEINTRIN_impHOSTNM_subr:
    case FFEINTRIN_impSYSTEM_subr:
    case FFEINTRIN_impUNLINK_subr:
      {
  tree arg1_len = integer_zero_node;
  tree arg1_tree;
  tree arg2_tree;

  arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);

  if (arg2 != NULL)
    arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
  else
    arg2_tree = NULL_TREE;

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg1_len = build_tree_list (NULL_TREE, arg1_len);
  TREE_CHAIN (arg1_tree) = arg1_len;

  expr_tree
    = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
        ffecom_gfrt_kindtype (gfrt),
        FALSE,
        NULL_TREE,
        arg1_tree,
        NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
        ffebld_nonter_hook (expr));

  if (arg2_tree != NULL_TREE)
    expr_tree
      = ffecom_modify (NULL_TREE, arg2_tree,
           convert (TREE_TYPE (arg2_tree),
              expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impEXIT:
      if (arg1 != NULL)
  break;

      expr_tree = build_tree_list (NULL_TREE,
           ffecom_1 (ADDR_EXPR,
               build_pointer_type
               (ffecom_integer_type_node),
               integer_zero_node));

      return
  ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          void_type_node,
          expr_tree,
          NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
          ffebld_nonter_hook (expr));

    case FFEINTRIN_impFLUSH:
      if (arg1 == NULL)
  gfrt = FFECOM_gfrtFLUSH;
      else
  gfrt = FFECOM_gfrtFLUSH1;
      break;

    case FFEINTRIN_impCHMOD_subr:
    case FFEINTRIN_impLINK_subr:
    case FFEINTRIN_impRENAME_subr:
    case FFEINTRIN_impSYMLNK_subr:
      {
  tree arg1_len = integer_zero_node;
  tree arg1_tree;
  tree arg2_len = integer_zero_node;
  tree arg2_tree;
  tree arg3_tree;

  arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
  arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
  if (arg3 != NULL)
    arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
  else
    arg3_tree = NULL_TREE;

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg1_len = build_tree_list (NULL_TREE, arg1_len);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  arg2_len = build_tree_list (NULL_TREE, arg2_len);
  TREE_CHAIN (arg1_tree) = arg2_tree;
  TREE_CHAIN (arg2_tree) = arg1_len;
  TREE_CHAIN (arg1_len) = arg2_len;
  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          NULL_TREE,
          arg1_tree,
          NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
          ffebld_nonter_hook (expr));
  if (arg3_tree != NULL_TREE)
    expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
             convert (TREE_TYPE (arg3_tree),
                expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impLSTAT_subr:
    case FFEINTRIN_impSTAT_subr:
      {
  tree arg1_len = integer_zero_node;
  tree arg1_tree;
  tree arg2_tree;
  tree arg3_tree;

  arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);

  arg2_tree = ffecom_ptr_to_expr (arg2);

  if (arg3 != NULL)
    arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
  else
    arg3_tree = NULL_TREE;

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg1_len = build_tree_list (NULL_TREE, arg1_len);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  TREE_CHAIN (arg1_tree) = arg2_tree;
  TREE_CHAIN (arg2_tree) = arg1_len;
  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          NULL_TREE,
          arg1_tree,
          NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
          ffebld_nonter_hook (expr));
  if (arg3_tree != NULL_TREE)
    expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
             convert (TREE_TYPE (arg3_tree),
                expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impFGETC_subr:
    case FFEINTRIN_impFPUTC_subr:
      {
  tree arg1_tree;
  tree arg2_tree;
  tree arg2_len = integer_zero_node;
  tree arg3_tree;

  arg1_tree = convert (ffecom_f2c_integer_type_node,
           ffecom_expr (arg1));
  arg1_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg1_tree)),
            arg1_tree);

  arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
  if (arg3 != NULL)
    arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
  else
    arg3_tree = NULL_TREE;

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  arg2_len = build_tree_list (NULL_TREE, arg2_len);
  TREE_CHAIN (arg1_tree) = arg2_tree;
  TREE_CHAIN (arg2_tree) = arg2_len;

  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          NULL_TREE,
          arg1_tree,
          NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
          ffebld_nonter_hook (expr));
  if (arg3_tree != NULL_TREE)
    expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
             convert (TREE_TYPE (arg3_tree),
                expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impFSTAT_subr:
      {
  tree arg1_tree;
  tree arg2_tree;
  tree arg3_tree;

  arg1_tree = convert (ffecom_f2c_integer_type_node,
           ffecom_expr (arg1));
  arg1_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg1_tree)),
            arg1_tree);

  arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
           ffecom_ptr_to_expr (arg2));

  if (arg3 == NULL)
    arg3_tree = NULL_TREE;
  else
    arg3_tree = ffecom_expr_w (NULL_TREE, arg3);

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  TREE_CHAIN (arg1_tree) = arg2_tree;
  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          NULL_TREE,
          arg1_tree,
          NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
          ffebld_nonter_hook (expr));
  if (arg3_tree != NULL_TREE) {
    expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
             convert (TREE_TYPE (arg3_tree),
                expr_tree));
  }
      }
      return expr_tree;

    case FFEINTRIN_impKILL_subr:
      {
  tree arg1_tree;
  tree arg2_tree;
  tree arg3_tree;

  arg1_tree = convert (ffecom_f2c_integer_type_node,
           ffecom_expr (arg1));
  arg1_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg1_tree)),
            arg1_tree);

  arg2_tree = convert (ffecom_f2c_integer_type_node,
           ffecom_expr (arg2));
  arg2_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg2_tree)),
            arg2_tree);

  if (arg3 == NULL)
    arg3_tree = NULL_TREE;
  else
    arg3_tree = ffecom_expr_w (NULL_TREE, arg3);

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  TREE_CHAIN (arg1_tree) = arg2_tree;
  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          NULL_TREE,
          arg1_tree,
          NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
          ffebld_nonter_hook (expr));
  if (arg3_tree != NULL_TREE) {
    expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
             convert (TREE_TYPE (arg3_tree),
                expr_tree));
  }
      }
      return expr_tree;

    case FFEINTRIN_impCTIME_subr:
    case FFEINTRIN_impTTYNAM_subr:
      {
  tree arg1_len = integer_zero_node;
  tree arg1_tree;
  tree arg2_tree;

  arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);

  arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
            ffecom_f2c_longint_type_node :
            ffecom_f2c_integer_type_node),
           ffecom_expr (arg1));
  arg2_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg2_tree)),
            arg2_tree);

  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
  arg1_len = build_tree_list (NULL_TREE, arg1_len);
  arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
  TREE_CHAIN (arg1_len) = arg2_tree;
  TREE_CHAIN (arg1_tree) = arg1_len;

  expr_tree
    = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
        ffecom_gfrt_kindtype (gfrt),
        FALSE,
        NULL_TREE,
        arg1_tree,
        NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
        ffebld_nonter_hook (expr));
  TREE_SIDE_EFFECTS (expr_tree) = 1;
      }
      return expr_tree;

    case FFEINTRIN_impIRAND:
    case FFEINTRIN_impRAND:
      /* Arg defaults to 0 (normal random case) */
      {
  tree arg1_tree;

  if (arg1 == NULL)
    arg1_tree = ffecom_integer_zero_node;
  else
    arg1_tree = ffecom_expr (arg1);
  arg1_tree = convert (ffecom_f2c_integer_type_node,
           arg1_tree);
  arg1_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg1_tree)),
            arg1_tree);
  arg1_tree = build_tree_list (NULL_TREE, arg1_tree);

  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          ((codegen_imp == FFEINTRIN_impIRAND) ?
           ffecom_f2c_integer_type_node :
           ffecom_f2c_real_type_node),
          arg1_tree,
          dest_tree, dest, dest_used,
          NULL_TREE, TRUE,
          ffebld_nonter_hook (expr));
      }
      return expr_tree;

    case FFEINTRIN_impFTELL_subr:
    case FFEINTRIN_impUMASK_subr:
      {
  tree arg1_tree;
  tree arg2_tree;

  arg1_tree = convert (ffecom_f2c_integer_type_node,
           ffecom_expr (arg1));
  arg1_tree = ffecom_1 (ADDR_EXPR,
            build_pointer_type (TREE_TYPE (arg1_tree)),
            arg1_tree);

  if (arg2 == NULL)
    arg2_tree = NULL_TREE;
  else
    arg2_tree = ffecom_expr_w (NULL_TREE, arg2);

  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          NULL_TREE,
          build_tree_list (NULL_TREE, arg1_tree),
          NULL_TREE, NULL, NULL, NULL_TREE,
          TRUE,
          ffebld_nonter_hook (expr));
  if (arg2_tree != NULL_TREE) {
    expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
             convert (TREE_TYPE (arg2_tree),
                expr_tree));
  }
      }
      return expr_tree;

    case FFEINTRIN_impCPU_TIME:
    case FFEINTRIN_impSECOND_subr:
      {
  tree arg1_tree;

  arg1_tree = ffecom_expr_w (NULL_TREE, arg1);

  expr_tree
    = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
        ffecom_gfrt_kindtype (gfrt),
        FALSE,
        NULL_TREE,
        NULL_TREE,
        NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
        ffebld_nonter_hook (expr));

  expr_tree
    = ffecom_modify (NULL_TREE, arg1_tree,
         convert (TREE_TYPE (arg1_tree),
            expr_tree));
      }
      return expr_tree;

    case FFEINTRIN_impDTIME_subr:
    case FFEINTRIN_impETIME_subr:
      {
  tree arg1_tree;
  tree result_tree;

  result_tree = ffecom_expr_w (NULL_TREE, arg2);

  arg1_tree = ffecom_ptr_to_expr (arg1);

  expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
          ffecom_gfrt_kindtype (gfrt),
          FALSE,
          NULL_TREE,
          build_tree_list (NULL_TREE, arg1_tree),
          NULL_TREE, NULL, NULL, NULL_TREE,
          TRUE,
          ffebld_nonter_hook (expr));
  expr_tree = ffecom_modify (NULL_TREE, result_tree,
           convert (TREE_TYPE (result_tree),
              expr_tree));
      }
      return expr_tree;

      /* Straightforward calls of libf2c routines: */
    case FFEINTRIN_impABORT:
    case FFEINTRIN_impACCESS:
    case FFEINTRIN_impBESJ0:
    case FFEINTRIN_impBESJ1:
    case FFEINTRIN_impBESJN:
    case FFEINTRIN_impBESY0:
    case FFEINTRIN_impBESY1:
    case FFEINTRIN_impBESYN:
    case FFEINTRIN_impCHDIR_func:
    case FFEINTRIN_impCHMOD_func:
    case FFEINTRIN_impDATE:
    case FFEINTRIN_impDATE_AND_TIME:
    case FFEINTRIN_impDBESJ0:
    case FFEINTRIN_impDBESJ1:
    case FFEINTRIN_impDBESJN:
    case FFEINTRIN_impDBESY0:
    case FFEINTRIN_impDBESY1:
    case FFEINTRIN_impDBESYN:
    case FFEINTRIN_impDTIME_func:
    case FFEINTRIN_impETIME_func:
    case FFEINTRIN_impFGETC_func:
    case FFEINTRIN_impFGET_func:
    case FFEINTRIN_impFNUM:
    case FFEINTRIN_impFPUTC_func:
    case FFEINTRIN_impFPUT_func:
    case FFEINTRIN_impFSEEK:
    case FFEINTRIN_impFSTAT_func:
    case FFEINTRIN_impFTELL_func:
    case FFEINTRIN_impGERROR:
    case FFEINTRIN_impGETARG:
    case FFEINTRIN_impGETCWD_func:
    case FFEINTRIN_impGETENV:
    case FFEINTRIN_impGETGID:
    case FFEINTRIN_impGETLOG:
    case FFEINTRIN_impGETPID:
    case FFEINTRIN_impGETUID:
    case FFEINTRIN_impGMTIME:
    case FFEINTRIN_impHOSTNM_func:
    case FFEINTRIN_impIDATE_unix:
    case FFEINTRIN_impIDATE_vxt:
    case FFEINTRIN_impIERRNO:
    case FFEINTRIN_impISATTY:
    case FFEINTRIN_impITIME:
    case FFEINTRIN_impKILL_func:
    case FFEINTRIN_impLINK_func:
    case FFEINTRIN_impLNBLNK:
    case FFEINTRIN_impLSTAT_func:
    case FFEINTRIN_impLTIME:
    case FFEINTRIN_impMCLOCK8:
    case FFEINTRIN_impMCLOCK:
    case FFEINTRIN_impPERROR:
    case FFEINTRIN_impRENAME_func:
    case FFEINTRIN_impSECNDS:
    case FFEINTRIN_impSECOND_func:
    case FFEINTRIN_impSLEEP:
    case FFEINTRIN_impSRAND:
    case FFEINTRIN_impSTAT_func:
    case FFEINTRIN_impSYMLNK_func:
    case FFEINTRIN_impSYSTEM_CLOCK:
    case FFEINTRIN_impSYSTEM_func:
    case FFEINTRIN_impTIME8:
    case FFEINTRIN_impTIME_unix:
    case FFEINTRIN_impTIME_vxt:
    case FFEINTRIN_impUMASK_func:
    case FFEINTRIN_impUNLINK_func:
      break;

    case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
    case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
    case FFEINTRIN_impTTYNAM_func:  /* CHARACTER functions not handled here. */
    case FFEINTRIN_impNONE:
    case FFEINTRIN_imp:   /* Hush up gcc warning. */
      fprintf (stderr, "No %s implementation.\n",
         ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
      assert ("unimplemented intrinsic" == NULL);
      return error_mark_node;
    }

  assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */

  expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
            ffebld_right (expr));

  return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
           (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
           tree_type,
           expr_tree, dest_tree, dest, dest_used,
           NULL_TREE, TRUE,
           ffebld_nonter_hook (expr));

  /* See bottom of this file for f2c transforms used to determine
     many of the above implementations.  The info seems to confuse
     Emacs's C mode indentation, which is why it's been moved to
     the bottom of this source file.  */
}

/* For power (exponentiation) where right-hand operand is type INTEGER,
   generate in-line code to do it the fast way (which, if the operand
   is a constant, might just mean a series of multiplies).  */

static tree
ffecom_expr_power_integer_ (ffebld expr)
{
  tree l = ffecom_expr (ffebld_left (expr));
  tree r = ffecom_expr (ffebld_right (expr));
  tree ltype = TREE_TYPE (l);
  tree rtype = TREE_TYPE (r);
  tree result = NULL_TREE;

  if (l == error_mark_node
      || r == error_mark_node)
    return error_mark_node;

  if (TREE_CODE (r) == INTEGER_CST)
    {
      int sgn = tree_int_cst_sgn (r);

      if (sgn == 0)
  return convert (ltype, integer_one_node);

      if ((TREE_CODE (ltype) == INTEGER_TYPE)
    && (sgn < 0))
  {
    /* Reciprocal of integer is either 0, -1, or 1, so after
       calculating that (which we leave to the back end to do
       or not do optimally), don't bother with any multiplying.  */

    result = ffecom_tree_divide_ (ltype,
          convert (ltype, integer_one_node),
          l,
          NULL_TREE, NULL, NULL, NULL_TREE);
    r = ffecom_1 (NEGATE_EXPR,
      rtype,
      r);
    if ((TREE_INT_CST_LOW (r) & 1) == 0)
      result = ffecom_1 (ABS_EXPR, rtype,
             result);
  }

      /* Generate appropriate series of multiplies, preceded
   by divide if the exponent is negative.  */

      l = save_expr (l);

      if (sgn < 0)
  {
    l = ffecom_tree_divide_ (ltype,
           convert (ltype, integer_one_node),
           l,
           NULL_TREE, NULL, NULL,
           ffebld_nonter_hook (expr));
    r = ffecom_1 (NEGATE_EXPR, rtype, r);
    assert (TREE_CODE (r) == INTEGER_CST);

    if (tree_int_cst_sgn (r) < 0)
      {     /* The "most negative" number.  */
        r = ffecom_1 (NEGATE_EXPR, rtype,
          ffecom_2 (RSHIFT_EXPR, rtype,
              r,
              integer_one_node));
        l = save_expr (l);
        l = ffecom_2 (MULT_EXPR, ltype,
          l,
          l);
      }
  }

      for (;;)
  {
    if (TREE_INT_CST_LOW (r) & 1)
      {
        if (result == NULL_TREE)
    result = l;
        else
    result = ffecom_2 (MULT_EXPR, ltype,
           result,
           l);
      }

    r = ffecom_2 (RSHIFT_EXPR, rtype,
      r,
      integer_one_node);
    if (integer_zerop (r))
      break;
    assert (TREE_CODE (r) == INTEGER_CST);

    l = save_expr (l);
    l = ffecom_2 (MULT_EXPR, ltype,
      l,
      l);
  }
      return result;
    }

  /* Though rhs isn't a constant, in-line code cannot be expanded
     while transforming dummies
     because the back end cannot be easily convinced to generate
     stores (MODIFY_EXPR), handle temporaries, and so on before
     all the appropriate rtx's have been generated for things like
     dummy args referenced in rhs -- which doesn't happen until
     store_parm_decls() is called (expand_function_start, I believe,
     does the actual rtx-stuffing of PARM_DECLs).

     So, in this case, let the caller generate the call to the
     run-time-library function to evaluate the power for us.  */

  if (ffecom_transform_only_dummies_)
    return NULL_TREE;

  /* Right-hand operand not a constant, expand in-line code to figure
     out how to do the multiplies, &c.

     The returned expression is expressed this way in GNU C, where l and
     r are the "inputs":

     ({ typeof (r) rtmp = r;
  typeof (l) ltmp = l;
  typeof (l) result;

  if (rtmp == 0)
    result = 1;
  else
    {
      if ((basetypeof (l) == basetypeof (int))
    && (rtmp < 0))
        {
          result = ((typeof (l)) 1) / ltmp;
          if ((ltmp < 0) && (((-rtmp) & 1) == 0))
      result = -result;
        }
      else
        {
    result = 1;
    if ((basetypeof (l) != basetypeof (int))
        && (rtmp < 0))
      {
        ltmp = ((typeof (l)) 1) / ltmp;
        rtmp = -rtmp;
        if (rtmp < 0)
          {
            rtmp = -(rtmp >> 1);
            ltmp *= ltmp;
          }
      }
    for (;;)
      {
        if (rtmp & 1)
          result *= ltmp;
        if ((rtmp >>= 1) == 0)
          break;
        ltmp *= ltmp;
      }
        }
    }
  result;
     })

     Note that some of the above is compile-time collapsable, such as
     the first part of the if statements that checks the base type of
     l against int.  The if statements are phrased that way to suggest
     an easy way to generate the if/else constructs here, knowing that
     the back end should (and probably does) eliminate the resulting
     dead code (either the int case or the non-int case), something
     it couldn't do without the redundant phrasing, requiring explicit
     dead-code elimination here, which would be kind of difficult to
     read.  */

  {
    tree rtmp;
    tree ltmp;
    tree divide;
    tree basetypeof_l_is_int;
    tree se;
    tree t;

    basetypeof_l_is_int
      = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);

    se = expand_start_stmt_expr (/*has_scope=*/1);

    ffecom_start_compstmt ();

#ifndef HAHA
    rtmp = ffecom_make_tempvar ("power_r", rtype,
        FFETARGET_charactersizeNONE, -1);
    ltmp = ffecom_make_tempvar ("power_l", ltype,
        FFETARGET_charactersizeNONE, -1);
    result = ffecom_make_tempvar ("power_res", ltype,
          FFETARGET_charactersizeNONE, -1);
    if (TREE_CODE (ltype) == COMPLEX_TYPE
  || TREE_CODE (ltype) == RECORD_TYPE)
      divide = ffecom_make_tempvar ("power_div", ltype,
            FFETARGET_charactersizeNONE, -1);
    else
      divide = NULL_TREE;
#else  /* HAHA */
    {
      tree hook;

      hook = ffebld_nonter_hook (expr);
      assert (hook);
      assert (TREE_CODE (hook) == TREE_VEC);
      assert (TREE_VEC_LENGTH (hook) == 4);
      rtmp = TREE_VEC_ELT (hook, 0);
      ltmp = TREE_VEC_ELT (hook, 1);
      result = TREE_VEC_ELT (hook, 2);
      divide = TREE_VEC_ELT (hook, 3);
      if (TREE_CODE (ltype) == COMPLEX_TYPE
    || TREE_CODE (ltype) == RECORD_TYPE)
  assert (divide);
      else
  assert (! divide);
    }
#endif  /* HAHA */

    expand_expr_stmt (ffecom_modify (void_type_node,
             rtmp,
             r));
    expand_expr_stmt (ffecom_modify (void_type_node,
             ltmp,
             l));
    expand_start_cond (ffecom_truth_value
           (ffecom_2 (EQ_EXPR, integer_type_node,
          rtmp,
          convert (rtype, integer_zero_node))),
           0);
    expand_expr_stmt (ffecom_modify (void_type_node,
             result,
             convert (ltype, integer_one_node)));
    expand_start_else ();
    if (! integer_zerop (basetypeof_l_is_int))
      {
  expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
             rtmp,
             convert (rtype,
                integer_zero_node)),
         0);
  expand_expr_stmt (ffecom_modify (void_type_node,
           result,
           ffecom_tree_divide_
           (ltype,
            convert (ltype, integer_one_node),
            ltmp,
            NULL_TREE, NULL, NULL,
            divide)));
  expand_start_cond (ffecom_truth_value
         (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
              ffecom_2 (LT_EXPR, integer_type_node,
            ltmp,
            convert (ltype,
               integer_zero_node)),
              ffecom_2 (EQ_EXPR, integer_type_node,
            ffecom_2 (BIT_AND_EXPR,
                rtype,
                ffecom_1 (NEGATE_EXPR,
                    rtype,
                    rtmp),
                convert (rtype,
                   integer_one_node)),
            convert (rtype,
               integer_zero_node)))),
         0);
  expand_expr_stmt (ffecom_modify (void_type_node,
           result,
           ffecom_1 (NEGATE_EXPR,
               ltype,
               result)));
  expand_end_cond ();
  expand_start_else ();
      }
    expand_expr_stmt (ffecom_modify (void_type_node,
             result,
             convert (ltype, integer_one_node)));
    expand_start_cond (ffecom_truth_value
           (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
          ffecom_truth_value_invert
          (basetypeof_l_is_int),
          ffecom_2 (LT_EXPR, integer_type_node,
              rtmp,
              convert (rtype,
                 integer_zero_node)))),
           0);
    expand_expr_stmt (ffecom_modify (void_type_node,
             ltmp,
             ffecom_tree_divide_
             (ltype,
              convert (ltype, integer_one_node),
              ltmp,
              NULL_TREE, NULL, NULL,
              divide)));
    expand_expr_stmt (ffecom_modify (void_type_node,
             rtmp,
             ffecom_1 (NEGATE_EXPR, rtype,
                 rtmp)));
    expand_start_cond (ffecom_truth_value
           (ffecom_2 (LT_EXPR, integer_type_node,
          rtmp,
          convert (rtype, integer_zero_node))),
           0);
    expand_expr_stmt (ffecom_modify (void_type_node,
             rtmp,
             ffecom_1 (NEGATE_EXPR, rtype,
                 ffecom_2 (RSHIFT_EXPR,
               rtype,
               rtmp,
               integer_one_node))));
    expand_expr_stmt (ffecom_modify (void_type_node,
             ltmp,
             ffecom_2 (MULT_EXPR, ltype,
                 ltmp,
                 ltmp)));
    expand_end_cond ();
    expand_end_cond ();
    expand_start_loop (1);
    expand_start_cond (ffecom_truth_value
           (ffecom_2 (BIT_AND_EXPR, rtype,
          rtmp,
          convert (rtype, integer_one_node))),
           0);
    expand_expr_stmt (ffecom_modify (void_type_node,
             result,
             ffecom_2 (MULT_EXPR, ltype,
                 result,
                 ltmp)));
    expand_end_cond ();
    expand_exit_loop_if_false (NULL,
             ffecom_truth_value
             (ffecom_modify (rtype,
                 rtmp,
                 ffecom_2 (RSHIFT_EXPR,
               rtype,
               rtmp,
               integer_one_node))));
    expand_expr_stmt (ffecom_modify (void_type_node,
             ltmp,
             ffecom_2 (MULT_EXPR, ltype,
                 ltmp,
                 ltmp)));
    expand_end_loop ();
    expand_end_cond ();
    if (!integer_zerop (basetypeof_l_is_int))
      expand_end_cond ();
    expand_expr_stmt (result);

    t = ffecom_end_compstmt ();

    result = expand_end_stmt_expr (se);

    /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */

    if (TREE_CODE (t) == BLOCK)
      {
  /* Make a BIND_EXPR for the BLOCK already made.  */
  result = build (BIND_EXPR, TREE_TYPE (result),
      NULL_TREE, result, t);
  /* Remove the block from the tree at this point.
     It gets put back at the proper place
     when the BIND_EXPR is expanded.  */
  delete_block (t);
      }
    else
      result = t;
  }

  return result;
}

/* ffecom_expr_transform_ -- Transform symbols in expr

   ffebld expr;  // FFE expression.
   ffecom_expr_transform_ (expr);

   Recursive descent on expr while transforming any untransformed SYMTERs.  */

static void
ffecom_expr_transform_ (ffebld expr)
{
  tree t;
  ffesymbol s;

 tail_recurse:

  if (expr == NULL)
    return;

  switch (ffebld_op (expr))
    {
    case FFEBLD_opSYMTER:
      s = ffebld_symter (expr);
      t = ffesymbol_hook (s).decl_tree;
      if ((t == NULL_TREE)
    && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
        || ((ffesymbol_where (s) != FFEINFO_whereNONE)
      && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
  {
    s = ffecom_sym_transform_ (s);
    t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
               DIMENSION expr? */
  }
      break;      /* Ok if (t == NULL) here. */

    case FFEBLD_opITEM:
      ffecom_expr_transform_ (ffebld_head (expr));
      expr = ffebld_trail (expr);
      goto tail_recurse;  /* :::::::::::::::::::: */

    default:
      break;
    }

  switch (ffebld_arity (expr))
    {
    case 2:
      ffecom_expr_transform_ (ffebld_left (expr));
      expr = ffebld_right (expr);
      goto tail_recurse;  /* :::::::::::::::::::: */

    case 1:
      expr = ffebld_left (expr);
      goto tail_recurse;  /* :::::::::::::::::::: */

    default:
      break;
    }

  return;
}

/* Make a type based on info in live f2c.h file.  */

static void
ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
{
  switch (tcode)
    {
    case FFECOM_f2ccodeCHAR:
      *type = make_signed_type (CHAR_TYPE_SIZE);
      break;

    case FFECOM_f2ccodeSHORT:
      *type = make_signed_type (SHORT_TYPE_SIZE);
      break;

    case FFECOM_f2ccodeINT:
      *type = make_signed_type (INT_TYPE_SIZE);
      break;

    case FFECOM_f2ccodeLONG:
      *type = make_signed_type (LONG_TYPE_SIZE);
      break;

    case FFECOM_f2ccodeLONGLONG:
      *type = make_signed_type (LONG_LONG_TYPE_SIZE);
      break;

    case FFECOM_f2ccodeCHARPTR:
      *type = build_pointer_type (DEFAULT_SIGNED_CHAR
          ? signed_char_type_node
          : unsigned_char_type_node);
      break;

    case FFECOM_f2ccodeFLOAT:
      *type = make_node (REAL_TYPE);
      TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
      layout_type (*type);
      break;

    case FFECOM_f2ccodeDOUBLE:
      *type = make_node (REAL_TYPE);
      TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
      layout_type (*type);
      break;

    case FFECOM_f2ccodeLONGDOUBLE:
      *type = make_node (REAL_TYPE);
      TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
      layout_type (*type);
      break;

    case FFECOM_f2ccodeTWOREALS:
      *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
      break;

    case FFECOM_f2ccodeTWODOUBLEREALS:
      *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
      break;

    default:
      assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
      *type = error_mark_node;
      return;
    }

  pushdecl (build_decl (TYPE_DECL,
      ffecom_get_invented_identifier ("__g77_f2c_%s", name),
      *type));
}

/* Set the f2c list-directed-I/O code for whatever (integral) type has the
   given size.  */

static void
ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
        int code)
{
  int j;
  tree t;

  for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
    if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
  && compare_tree_int (TYPE_SIZE (t), size) == 0)
      {
  assert (code != -1);
  ffecom_f2c_typecode_[bt][j] = code;
  code = -1;
      }
}

/* Finish up globals after doing all program units in file

   Need to handle only uninitialized COMMON areas.  */

static ffeglobal
ffecom_finish_global_ (ffeglobal global)
{
  tree cbtype;
  tree cbt;
  tree size;

  if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
      return global;

  if (ffeglobal_common_init (global))
      return global;

  cbt = ffeglobal_hook (global);
  if ((cbt == NULL_TREE)
      || !ffeglobal_common_have_size (global))
    return global;    /* No need to make common, never ref'd. */

  DECL_EXTERNAL (cbt) = 0;

  /* Give the array a size now.  */

  size = build_int_2 ((ffeglobal_common_size (global)
          + ffeglobal_common_pad (global)) - 1,
          0);

  cbtype = TREE_TYPE (cbt);
  TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
             integer_zero_node,
             size);
  if (!TREE_TYPE (size))
    TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
  layout_type (cbtype);

  cbt = start_decl (cbt, FALSE);
  assert (cbt == ffeglobal_hook (global));

  finish_decl (cbt, NULL_TREE, FALSE);

  return global;
}

/* Finish up any untransformed symbols.  */

static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s)
{
  if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
    return s;

  /* It's easy to know to transform an untransformed symbol, to make sure
     we put out debugging info for it.  But COMMON variables, unlike
     EQUIVALENCE ones, aren't given declarations in addition to the
     tree expressions that specify offsets, because COMMON variables
     can be referenced in the outer scope where only dummy arguments
     (PARM_DECLs) should really be seen.  To be safe, just don't do any
     VAR_DECLs for COMMON variables when we transform them for real
     use, and therefore we do all the VAR_DECL creating here.  */

  if (ffesymbol_hook (s).decl_tree == NULL_TREE)
    {
      if (ffesymbol_kind (s) != FFEINFO_kindNONE
    || (ffesymbol_where (s) != FFEINFO_whereNONE
        && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
        && ffesymbol_where (s) != FFEINFO_whereDUMMY))
  /* Not transformed, and not CHARACTER*(*), and not a dummy
     argument, which can happen only if the entry point names
     it "rides in on" are all invalidated for other reasons.  */
  s = ffecom_sym_transform_ (s);
    }

  if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
      && (ffesymbol_hook (s).decl_tree != error_mark_node))
    {
      /* This isn't working, at least for dbxout.  The .s file looks
   okay to me (burley), but in gdb 4.9 at least, the variables
   appear to reside somewhere outside of the common area, so
   it doesn't make sense to mislead anyone by generating the info
   on those variables until this is fixed.  NOTE: Same problem
   with EQUIVALENCE, sadly...see similar #if later.  */
      ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
           ffesymbol_storage (s));
    }

  return s;
}

/* Append underscore(s) to name before calling get_identifier.  "us"
   is nonzero if the name already contains an underscore and thus
   needs two underscores appended.  */

static tree
ffecom_get_appended_identifier_ (char us, const char *name)
{
  int i;
  char *newname;
  tree id;

  newname = xmalloc ((i = strlen (name)) + 1
         + ffe_is_underscoring ()
         + us);
  memcpy (newname, name, i);
  newname[i] = '_';
  newname[i + us] = '_';
  newname[i + 1 + us] = '\0';
  id = get_identifier (newname);

  free (newname);

  return id;
}

/* Decide whether to append underscore to name before calling
   get_identifier.  */

static tree
ffecom_get_external_identifier_ (ffesymbol s)
{
  char us;
  const char *name = ffesymbol_text (s);

  /* If name is a built-in name, just return it as is.  */

  if (!ffe_is_underscoring ()
      || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
#if FFETARGET_isENFORCED_MAIN_NAME
      || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
#else
      || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
#endif
      || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
    return get_identifier (name);

  us = ffe_is_second_underscore ()
    ? (strchr (name, '_') != NULL)
      : 0;

  return ffecom_get_appended_identifier_ (us, name);
}

/* Decide whether to append underscore to internal name before calling
   get_identifier.

   This is for non-external, top-function-context names only.  Transform
   identifier so it doesn't conflict with the transformed result
   of using a _different_ external name.  E.g. if "CALL FOO" is
   transformed into "FOO_();", then the variable in "FOO_ = 3"
   must be transformed into something that does not conflict, since
   these two things should be independent.

   The transformation is as follows.  If the name does not contain
   an underscore, there is no possible conflict, so just return.
   If the name does contain an underscore, then transform it just
   like we transform an external identifier.  */

static tree
ffecom_get_identifier_ (const char *name)
{
  /* If name does not contain an underscore, just return it as is.  */

  if (!ffe_is_underscoring ()
      || (strchr (name, '_') == NULL))
    return get_identifier (name);

  return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
            name);
}

/* ffecom_gen_sfuncdef_ -- Generate definition of statement function

   tree t;
   ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
   t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
   ffesymbol_kindtype(s));

   Call after setting up containing function and getting trees for all
   other symbols.  */

static tree
ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
{
  ffebld expr = ffesymbol_sfexpr (s);
  tree type;
  tree func;
  tree result;
  bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
  static bool recurse = FALSE;
  int old_lineno = lineno;
  const char *old_input_filename = input_filename;

  ffecom_nested_entry_ = s;

  /* For now, we don't have a handy pointer to where the sfunc is actually
     defined, though that should be easy to add to an ffesymbol. (The
     token/where info available might well point to the place where the type
     of the sfunc is declared, especially if that precedes the place where
     the sfunc itself is defined, which is typically the case.)  We should
     put out a null pointer rather than point somewhere wrong, but I want to
     see how it works at this point.  */

  input_filename = ffesymbol_where_filename (s);
  lineno = ffesymbol_where_filelinenum (s);

  /* Pretransform the expression so any newly discovered things belong to the
     outer program unit, not to the statement function. */

  ffecom_expr_transform_ (expr);

  /* Make sure no recursive invocation of this fn (a specific case of failing
     to pretransform an sfunc's expression, i.e. where its expression
     references another untransformed sfunc) happens. */

  assert (!recurse);
  recurse = TRUE;

  push_f_function_context ();

  if (charfunc)
    type = void_type_node;
  else
    {
      type = ffecom_tree_type[bt][kt];
      if (type == NULL_TREE)
  type = integer_type_node; /* _sym_exec_transition reports
             error. */
    }

  start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
      build_function_type (type, NULL_TREE),
      1,    /* nested/inline */
      0);   /* TREE_PUBLIC */

  /* We don't worry about COMPLEX return values here, because this is
     entirely internal to our code, and gcc has the ability to return COMPLEX
     directly as a value.  */

  if (charfunc)
    {       /* Prepend arg for where result goes. */
      tree type;

      type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];

      result = ffecom_get_invented_identifier ("__g77_%s", "result");

      ffecom_char_enhance_arg_ (&type, s);  /* Ignore returned length. */

      type = build_pointer_type (type);
      result = build_decl (PARM_DECL, result, type);

      push_parm_decl (result);
    }
  else
    result = NULL_TREE;   /* Not ref'd if !charfunc. */

  ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);

  store_parm_decls (0);

  ffecom_start_compstmt ();

  if (expr != NULL)
    {
      if (charfunc)
  {
    ffetargetCharacterSize sz = ffesymbol_size (s);
    tree result_length;

    result_length = build_int_2 (sz, 0);
    TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;

    ffecom_prepare_let_char_ (sz, expr);

    ffecom_prepare_end ();

    ffecom_let_char_ (result, result_length, sz, expr);
    expand_null_return ();
  }
      else
  {
    ffecom_prepare_expr (expr);

    ffecom_prepare_end ();

    expand_return (ffecom_modify (NULL_TREE,
          DECL_RESULT (current_function_decl),
          ffecom_expr (expr)));
  }
    }

  ffecom_end_compstmt ();

  func = current_function_decl;
  finish_function (1);

  pop_f_function_context ();

  recurse = FALSE;

  lineno = old_lineno;
  input_filename = old_input_filename;

  ffecom_nested_entry_ = NULL;

  return func;
}

static const char *
ffecom_gfrt_args_ (ffecomGfrt ix)
{
  return ffecom_gfrt_argstring_[ix];
}

static tree
ffecom_gfrt_tree_ (ffecomGfrt ix)
{
  if (ffecom_gfrt_[ix] == NULL_TREE)
    ffecom_make_gfrt_ (ix);

  return ffecom_1 (ADDR_EXPR,
       build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
       ffecom_gfrt_[ix]);
}

/* Return initialize-to-zero expression for this VAR_DECL.  */

/* A somewhat evil way to prevent the garbage collector
   from collecting 'tree' structures.  */
#define NUM_TRACKED_CHUNK 63
static struct tree_ggc_tracker
{
  struct tree_ggc_tracker *next;
  tree trees[NUM_TRACKED_CHUNK];
} *tracker_head = NULL;

static void
mark_tracker_head (void *arg)
{
  struct tree_ggc_tracker *head;
  int i;

  for (head = * (struct tree_ggc_tracker **) arg;
       head != NULL;
       head = head->next)
  {
    ggc_mark (head);
    for (i = 0; i < NUM_TRACKED_CHUNK; i++)
      ggc_mark_tree (head->trees[i]);
  }
}

void
ffecom_save_tree_forever (tree t)
{
  int i;
  if (tracker_head != NULL)
    for (i = 0; i < NUM_TRACKED_CHUNK; i++)
      if (tracker_head->trees[i] == NULL)
  {
    tracker_head->trees[i] = t;
    return;
  }

  {
    /* Need to allocate a new block.  */
    struct tree_ggc_tracker *old_head = tracker_head;

    tracker_head = ggc_alloc (sizeof (*tracker_head));
    tracker_head->next = old_head;
    tracker_head->trees[0] = t;
    for (i = 1; i < NUM_TRACKED_CHUNK; i++)
      tracker_head->trees[i] = NULL;
  }
}

static tree
ffecom_init_zero_ (tree decl)
{
  tree init;
  int incremental = TREE_STATIC (decl);
  tree type = TREE_TYPE (decl);

  if (incremental)
    {
      make_decl_rtl (decl, NULL);
      assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
    }

  if ((TREE_CODE (type) != ARRAY_TYPE)
      && (TREE_CODE (type) != RECORD_TYPE)
      && (TREE_CODE (type) != UNION_TYPE)
      && !incremental)
    init = convert (type, integer_zero_node);
  else if (!incremental)
    {
      init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
      TREE_CONSTANT (init) = 1;
      TREE_STATIC (init) = 1;
    }
  else
    {
      assemble_zeros (int_size_in_bytes (type));
      init = error_mark_node;
    }

  return init;
}

static tree
ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
       tree *maybe_tree)
{
  tree expr_tree;
  tree length_tree;

  switch (ffebld_op (arg))
    {
    case FFEBLD_opCONTER: /* For F90, check 0-length. */
      if (ffetarget_length_character1
    (ffebld_constant_character1
     (ffebld_conter (arg))) == 0)
  {
    *maybe_tree = integer_zero_node;
    return convert (tree_type, integer_zero_node);
  }

      *maybe_tree = integer_one_node;
      expr_tree = build_int_2 (*ffetarget_text_character1
             (ffebld_constant_character1
        (ffebld_conter (arg))),
             0);
      TREE_TYPE (expr_tree) = tree_type;
      return expr_tree;

    case FFEBLD_opSYMTER:
    case FFEBLD_opARRAYREF:
    case FFEBLD_opFUNCREF:
    case FFEBLD_opSUBSTR:
      ffecom_char_args_ (&expr_tree, &length_tree, arg);

      if ((expr_tree == error_mark_node)
    || (length_tree == error_mark_node))
  {
    *maybe_tree = error_mark_node;
    return error_mark_node;
  }

      if (integer_zerop (length_tree))
  {
    *maybe_tree = integer_zero_node;
    return convert (tree_type, integer_zero_node);
  }

      expr_tree
  = ffecom_1 (INDIRECT_REF,
        TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
        expr_tree);
      expr_tree
  = ffecom_2 (ARRAY_REF,
        TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
        expr_tree,
        integer_one_node);
      expr_tree = convert (tree_type, expr_tree);

      if (TREE_CODE (length_tree) == INTEGER_CST)
  *maybe_tree = integer_one_node;
      else      /* Must check length at run time.  */
  *maybe_tree
    = ffecom_truth_value
      (ffecom_2 (GT_EXPR, integer_type_node,
           length_tree,
           ffecom_f2c_ftnlen_zero_node));
      return expr_tree;

    case FFEBLD_opPAREN:
    case FFEBLD_opCONVERT:
      if (ffeinfo_size (ffebld_info (arg)) == 0)
  {
    *maybe_tree = integer_zero_node;
    return convert (tree_type, integer_zero_node);
  }
      return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
              maybe_tree);

    case FFEBLD_opCONCATENATE:
      {
  tree maybe_left;
  tree maybe_right;
  tree expr_left;
  tree expr_right;

  expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
               &maybe_left);
  expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
                &maybe_right);
  *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
        maybe_left,
        maybe_right);
  expr_tree = ffecom_3 (COND_EXPR, tree_type,
            maybe_left,
            expr_left,
            expr_right);
  return expr_tree;
      }

    default:
      assert ("bad op in ICHAR" == NULL);
      return error_mark_node;
    }
}

/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())

   tree length_arg;
   ffebld expr;
   length_arg = ffecom_intrinsic_len_ (expr);

   Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
   subexpressions by constructing the appropriate tree for the
   length-of-character-text argument in a calling sequence.  */

static tree
ffecom_intrinsic_len_ (ffebld expr)
{
  ffetargetCharacter1 val;
  tree length;

  switch (ffebld_op (expr))
    {
    case FFEBLD_opCONTER:
      val = ffebld_constant_character1 (ffebld_conter (expr));
      length = build_int_2 (ffetarget_length_character1 (val), 0);
      TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
      break;

    case FFEBLD_opSYMTER:
      {
  ffesymbol s = ffebld_symter (expr);
  tree item;

  item = ffesymbol_hook (s).decl_tree;
  if (item == NULL_TREE)
    {
      s = ffecom_sym_transform_ (s);
      item = ffesymbol_hook (s).decl_tree;
    }
  if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
    {
      if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
        length = ffesymbol_hook (s).length_tree;
      else
        {
    length = build_int_2 (ffesymbol_size (s), 0);
    TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
        }
    }
  else if (item == error_mark_node)
    length = error_mark_node;
  else      /* FFEINFO_kindFUNCTION: */
    length = NULL_TREE;
      }
      break;

    case FFEBLD_opARRAYREF:
      length = ffecom_intrinsic_len_ (ffebld_left (expr));
      break;

    case FFEBLD_opSUBSTR:
      {
  ffebld start;
  ffebld end;
  ffebld thing = ffebld_right (expr);
  tree start_tree;
  tree end_tree;

  assert (ffebld_op (thing) == FFEBLD_opITEM);
  start = ffebld_head (thing);
  thing = ffebld_trail (thing);
  assert (ffebld_trail (thing) == NULL);
  end = ffebld_head (thing);

  length = ffecom_intrinsic_len_ (ffebld_left (expr));

  if (length == error_mark_node)
    break;

  if (start == NULL)
    {
      if (end == NULL)
        ;
      else
        {
    length = convert (ffecom_f2c_ftnlen_type_node,
          ffecom_expr (end));
        }
    }
  else
    {
      start_tree = convert (ffecom_f2c_ftnlen_type_node,
          ffecom_expr (start));

      if (start_tree == error_mark_node)
        {
    length = error_mark_node;
    break;
        }

      if (end == NULL)
        {
    length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
           ffecom_f2c_ftnlen_one_node,
           ffecom_2 (MINUS_EXPR,
               ffecom_f2c_ftnlen_type_node,
               length,
               start_tree));
        }
      else
        {
    end_tree = convert (ffecom_f2c_ftnlen_type_node,
            ffecom_expr (end));

    if (end_tree == error_mark_node)
      {
        length = error_mark_node;
        break;
      }

    length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
           ffecom_f2c_ftnlen_one_node,
           ffecom_2 (MINUS_EXPR,
               ffecom_f2c_ftnlen_type_node,
               end_tree, start_tree));
        }
    }
      }
      break;

    case FFEBLD_opCONCATENATE:
      length
  = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
        ffecom_intrinsic_len_ (ffebld_left (expr)),
        ffecom_intrinsic_len_ (ffebld_right (expr)));
      break;

    case FFEBLD_opFUNCREF:
    case FFEBLD_opCONVERT:
      length = build_int_2 (ffebld_size (expr), 0);
      TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
      break;

    default:
      assert ("bad op for single char arg expr" == NULL);
      length = ffecom_f2c_ftnlen_zero_node;
      break;
    }

  assert (length != NULL_TREE);

  return length;
}

/* Handle CHARACTER assignments.

   Generates code to do the assignment.  Used by ordinary assignment
   statement handler ffecom_let_stmt and by statement-function
   handler to generate code for a statement function.  */

static void
ffecom_let_char_ (tree dest_tree, tree dest_length,
      ffetargetCharacterSize dest_size, ffebld source)
{
  ffecomConcatList_ catlist;
  tree source_length;
  tree source_tree;
  tree expr_tree;

  if ((dest_tree == error_mark_node)
      || (dest_length == error_mark_node))
    return;

  assert (dest_tree != NULL_TREE);
  assert (dest_length != NULL_TREE);

  /* Source might be an opCONVERT, which just means it is a different size
     than the destination.  Since the underlying implementation here handles
     that (directly or via the s_copy or s_cat run-time-library functions),
     we don't need the "convenience" of an opCONVERT that tells us to
     truncate or blank-pad, particularly since the resulting implementation
     would probably be slower than otherwise. */

  while (ffebld_op (source) == FFEBLD_opCONVERT)
    source = ffebld_left (source);

  catlist = ffecom_concat_list_new_ (source, dest_size);
  switch (ffecom_concat_list_count_ (catlist))
    {
    case 0:     /* Shouldn't happen, but in case it does... */
      ffecom_concat_list_kill_ (catlist);
      source_tree = null_pointer_node;
      source_length = ffecom_f2c_ftnlen_zero_node;
      expr_tree = build_tree_list (NULL_TREE, dest_tree);
      TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
      TREE_CHAIN (TREE_CHAIN (expr_tree))
  = build_tree_list (NULL_TREE, dest_length);
      TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
  = build_tree_list (NULL_TREE, source_length);

      expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
      TREE_SIDE_EFFECTS (expr_tree) = 1;

      expand_expr_stmt (expr_tree);

      return;

    case 1:     /* The (fairly) easy case. */
      ffecom_char_args_ (&source_tree, &source_length,
       ffecom_concat_list_expr_ (catlist, 0));
      ffecom_concat_list_kill_ (catlist);
      assert (source_tree != NULL_TREE);
      assert (source_length != NULL_TREE);

      if ((source_tree == error_mark_node)
    || (source_length == error_mark_node))
  return;

      if (dest_size == 1)
  {
    dest_tree
      = ffecom_1 (INDIRECT_REF,
      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
                  (dest_tree))),
      dest_tree);
    dest_tree
      = ffecom_2 (ARRAY_REF,
      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
                  (dest_tree))),
      dest_tree,
      integer_one_node);
    source_tree
      = ffecom_1 (INDIRECT_REF,
      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
                  (source_tree))),
      source_tree);
    source_tree
      = ffecom_2 (ARRAY_REF,
      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
                  (source_tree))),
      source_tree,
      integer_one_node);

    expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);

    expand_expr_stmt (expr_tree);

    return;
  }

      expr_tree = build_tree_list (NULL_TREE, dest_tree);
      TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
      TREE_CHAIN (TREE_CHAIN (expr_tree))
  = build_tree_list (NULL_TREE, dest_length);
      TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
  = build_tree_list (NULL_TREE, source_length);

      expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
      TREE_SIDE_EFFECTS (expr_tree) = 1;

      expand_expr_stmt (expr_tree);

      return;

    default:      /* Must actually concatenate things. */
      break;
    }

  /* Heavy-duty concatenation. */

  {
    int count = ffecom_concat_list_count_ (catlist);
    int i;
    tree lengths;
    tree items;
    tree length_array;
    tree item_array;
    tree citem;
    tree clength;

#ifdef HOHO
    length_array
      = lengths
      = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
           FFETARGET_charactersizeNONE, count, TRUE);
    item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
                FFETARGET_charactersizeNONE,
                count, TRUE);
#else
    {
      tree hook;

      hook = ffebld_nonter_hook (source);
      assert (hook);
      assert (TREE_CODE (hook) == TREE_VEC);
      assert (TREE_VEC_LENGTH (hook) == 2);
      length_array = lengths = TREE_VEC_ELT (hook, 0);
      item_array = items = TREE_VEC_ELT (hook, 1);
    }
#endif

    for (i = 0; i < count; ++i)
      {
  ffecom_char_args_ (&citem, &clength,
         ffecom_concat_list_expr_ (catlist, i));
  if ((citem == error_mark_node)
      || (clength == error_mark_node))
    {
      ffecom_concat_list_kill_ (catlist);
      return;
    }

  items
    = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
          ffecom_modify (void_type_node,
             ffecom_2 (ARRAY_REF,
         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
                 item_array,
                 build_int_2 (i, 0)),
             citem),
          items);
  lengths
    = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
          ffecom_modify (void_type_node,
             ffecom_2 (ARRAY_REF,
       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
                 length_array,
                 build_int_2 (i, 0)),
             clength),
          lengths);
      }

    expr_tree = build_tree_list (NULL_TREE, dest_tree);
    TREE_CHAIN (expr_tree)
      = build_tree_list (NULL_TREE,
       ffecom_1 (ADDR_EXPR,
           build_pointer_type (TREE_TYPE (items)),
           items));
    TREE_CHAIN (TREE_CHAIN (expr_tree))
      = build_tree_list (NULL_TREE,
       ffecom_1 (ADDR_EXPR,
           build_pointer_type (TREE_TYPE (lengths)),
           lengths));
    TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
      = build_tree_list
  (NULL_TREE,
   ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
       convert (ffecom_f2c_ftnlen_type_node,
          build_int_2 (count, 0))));
    TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
      = build_tree_list (NULL_TREE, dest_length);

    expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
    TREE_SIDE_EFFECTS (expr_tree) = 1;

    expand_expr_stmt (expr_tree);
  }

  ffecom_concat_list_kill_ (catlist);
}

/* ffecom_make_gfrt_ -- Make initial info for run-time routine

   ffecomGfrt ix;
   ffecom_make_gfrt_(ix);

   Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
   for the indicated run-time routine (ix).  */

static void
ffecom_make_gfrt_ (ffecomGfrt ix)
{
  tree t;
  tree ttype;

  switch (ffecom_gfrt_type_[ix])
    {
    case FFECOM_rttypeVOID_:
      ttype = void_type_node;
      break;

    case FFECOM_rttypeVOIDSTAR_:
      ttype = TREE_TYPE (null_pointer_node);  /* `void *'. */
      break;

    case FFECOM_rttypeFTNINT_:
      ttype = ffecom_f2c_ftnint_type_node;
      break;

    case FFECOM_rttypeINTEGER_:
      ttype = ffecom_f2c_integer_type_node;
      break;

    case FFECOM_rttypeLONGINT_:
      ttype = ffecom_f2c_longint_type_node;
      break;

    case FFECOM_rttypeLOGICAL_:
      ttype = ffecom_f2c_logical_type_node;
      break;

    case FFECOM_rttypeREAL_F2C_:
      ttype = double_type_node;
      break;

    case FFECOM_rttypeREAL_GNU_:
      ttype = float_type_node;
      break;

    case FFECOM_rttypeCOMPLEX_F2C_:
      ttype = void_type_node;
      break;

    case FFECOM_rttypeCOMPLEX_GNU_:
      ttype = ffecom_f2c_complex_type_node;
      break;

    case FFECOM_rttypeDOUBLE_:
      ttype = double_type_node;
      break;

    case FFECOM_rttypeDOUBLEREAL_:
      ttype = ffecom_f2c_doublereal_type_node;
      break;

    case FFECOM_rttypeDBLCMPLX_F2C_:
      ttype = void_type_node;
      break;

    case FFECOM_rttypeDBLCMPLX_GNU_:
      ttype = ffecom_f2c_doublecomplex_type_node;
      break;

    case FFECOM_rttypeCHARACTER_:
      ttype = void_type_node;
      break;

    default:
      ttype = NULL;
      assert ("bad rttype" == NULL);
      break;
    }

  ttype = build_function_type (ttype, NULL_TREE);
  t = build_decl (FUNCTION_DECL,
      get_identifier (ffecom_gfrt_name_[ix]),
      ttype);
  DECL_EXTERNAL (t) = 1;
  TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
  TREE_PUBLIC (t) = 1;
  TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;

  /* Sanity check:  A function that's const cannot be volatile.  */

  assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);

  /* Sanity check: A function that's const cannot return complex.  */

  assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);

  t = start_decl (t, TRUE);

  finish_decl (t, NULL_TREE, TRUE);

  ffecom_gfrt_[ix] = t;
}

/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */

static void
ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
{
  ffesymbol s = ffestorag_symbol (st);

  if (ffesymbol_namelisted (s))
    ffecom_member_namelisted_ = TRUE;
}

/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
   the member so debugger will see it.  Otherwise nobody should be
   referencing the member.  */

static void
ffecom_member_phase2_ (ffestorag mst, ffestorag st)
{
  ffesymbol s;
  tree t;
  tree mt;
  tree type;

  if ((mst == NULL)
      || ((mt = ffestorag_hook (mst)) == NULL)
      || (mt == error_mark_node))
    return;

  if ((st == NULL)
      || ((s = ffestorag_symbol (st)) == NULL))
    return;

  type = ffecom_type_localvar_ (s,
        ffesymbol_basictype (s),
        ffesymbol_kindtype (s));
  if (type == error_mark_node)
    return;

  t = build_decl (VAR_DECL,
      ffecom_get_identifier_ (ffesymbol_text (s)),
      type);

  TREE_STATIC (t) = TREE_STATIC (mt);
  DECL_INITIAL (t) = NULL_TREE;
  TREE_ASM_WRITTEN (t) = 1;
  TREE_USED (t) = 1;

  SET_DECL_RTL (t,
    gen_rtx (MEM, TYPE_MODE (type),
       plus_constant (XEXP (DECL_RTL (mt), 0),
          ffestorag_modulo (mst)
          + ffestorag_offset (st)
          - ffestorag_offset (mst))));

  t = start_decl (t, FALSE);

  finish_decl (t, NULL_TREE, FALSE);
}

/* Prepare source expression for assignment into a destination perhaps known
   to be of a specific size.  */

static void
ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
{
  ffecomConcatList_ catlist;
  int count;
  int i;
  tree ltmp;
  tree itmp;
  tree tempvar = NULL_TREE;

  while (ffebld_op (source) == FFEBLD_opCONVERT)
    source = ffebld_left (source);

  catlist = ffecom_concat_list_new_ (source, dest_size);
  count = ffecom_concat_list_count_ (catlist);

  if (count >= 2)
    {
      ltmp
  = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
             FFETARGET_charactersizeNONE, count);
      itmp
  = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
             FFETARGET_charactersizeNONE, count);

      tempvar = make_tree_vec (2);
      TREE_VEC_ELT (tempvar, 0) = ltmp;
      TREE_VEC_ELT (tempvar, 1) = itmp;
    }

  for (i = 0; i < count; ++i)
    ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));

  ffecom_concat_list_kill_ (catlist);

  if (tempvar)
    {
      ffebld_nonter_set_hook (source, tempvar);
      current_binding_level->prep_state = 1;
    }
}

/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order

   Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
   (which generates their trees) and then their trees get push_parm_decl'd.

   The second arg is TRUE if the dummies are for a statement function, in
   which case lengths are not pushed for character arguments (since they are
   always known by both the caller and the callee, though the code allows
   for someday permitting CHAR*(*) stmtfunc dummies).  */

static void
ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
{
  ffebld dummy;
  ffebld dumlist;
  ffesymbol s;
  tree parm;

  ffecom_transform_only_dummies_ = TRUE;

  /* First push the parms corresponding to actual dummy "contents".  */

  for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
    {
      dummy = ffebld_head (dumlist);
      switch (ffebld_op (dummy))
  {
  case FFEBLD_opSTAR:
  case FFEBLD_opANY:
    continue;   /* Forget alternate returns. */

  default:
    break;
  }
      assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
      s = ffebld_symter (dummy);
      parm = ffesymbol_hook (s).decl_tree;
      if (parm == NULL_TREE)
  {
    s = ffecom_sym_transform_ (s);
    parm = ffesymbol_hook (s).decl_tree;
    assert (parm != NULL_TREE);
  }
      if (parm != error_mark_node)
  push_parm_decl (parm);
    }

  /* Then, for CHARACTER dummies, push the parms giving their lengths.  */

  for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
    {
      dummy = ffebld_head (dumlist);
      switch (ffebld_op (dummy))
  {
  case FFEBLD_opSTAR:
  case FFEBLD_opANY:
    continue;   /* Forget alternate returns, they mean
           NOTHING! */

  default:
    break;
  }
      s = ffebld_symter (dummy);
      if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
  continue;   /* Only looking for CHARACTER arguments. */
      if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
  continue;   /* Stmtfunc arg with known size needs no
           length param. */
      if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
  continue;   /* Only looking for variables and arrays. */
      parm = ffesymbol_hook (s).length_tree;
      assert (parm != NULL_TREE);
      if (parm != error_mark_node)
  push_parm_decl (parm);
    }

  ffecom_transform_only_dummies_ = FALSE;
}

/* ffecom_start_progunit_ -- Beginning of program unit

   Does GNU back end stuff necessary to teach it about the start of its
   equivalent of a Fortran program unit.  */

static void
ffecom_start_progunit_ ()
{
  ffesymbol fn = ffecom_primary_entry_;
  ffebld arglist;
  tree id;      /* Identifier (name) of function. */
  tree type;      /* Type of function. */
  tree result;      /* Result of function. */
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffeglobal g;
  ffeglobalType gt;
  ffeglobalType egt = FFEGLOBAL_type;
  bool charfunc;
  bool cmplxfunc;
  bool altentries = (ffecom_num_entrypoints_ != 0);
  bool multi
  = altentries
  && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
  && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
  bool main_program = FALSE;
  int old_lineno = lineno;
  const char *old_input_filename = input_filename;

  assert (fn != NULL);
  assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);

  input_filename = ffesymbol_where_filename (fn);
  lineno = ffesymbol_where_filelinenum (fn);

  switch (ffecom_primary_entry_kind_)
    {
    case FFEINFO_kindPROGRAM:
      main_program = TRUE;
      gt = FFEGLOBAL_typeMAIN;
      bt = FFEINFO_basictypeNONE;
      kt = FFEINFO_kindtypeNONE;
      type = ffecom_tree_fun_type_void;
      charfunc = FALSE;
      cmplxfunc = FALSE;
      break;

    case FFEINFO_kindBLOCKDATA:
      gt = FFEGLOBAL_typeBDATA;
      bt = FFEINFO_basictypeNONE;
      kt = FFEINFO_kindtypeNONE;
      type = ffecom_tree_fun_type_void;
      charfunc = FALSE;
      cmplxfunc = FALSE;
      break;

    case FFEINFO_kindFUNCTION:
      gt = FFEGLOBAL_typeFUNC;
      egt = FFEGLOBAL_typeEXT;
      bt = ffesymbol_basictype (fn);
      kt = ffesymbol_kindtype (fn);
      if (bt == FFEINFO_basictypeNONE)
  {
    ffeimplic_establish_symbol (fn);
    if (ffesymbol_funcresult (fn) != NULL)
      ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
    bt = ffesymbol_basictype (fn);
    kt = ffesymbol_kindtype (fn);
  }

      if (multi)
  charfunc = cmplxfunc = FALSE;
      else if (bt == FFEINFO_basictypeCHARACTER)
  charfunc = TRUE, cmplxfunc = FALSE;
      else if ((bt == FFEINFO_basictypeCOMPLEX)
         && ffesymbol_is_f2c (fn)
         && !altentries)
  charfunc = FALSE, cmplxfunc = TRUE;
      else
  charfunc = cmplxfunc = FALSE;

      if (multi || charfunc)
  type = ffecom_tree_fun_type_void;
      else if (ffesymbol_is_f2c (fn) && !altentries)
  type = ffecom_tree_fun_type[bt][kt];
      else
  type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);

      if ((type == NULL_TREE)
    || (TREE_TYPE (type) == NULL_TREE))
  type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
      break;

    case FFEINFO_kindSUBROUTINE:
      gt = FFEGLOBAL_typeSUBR;
      egt = FFEGLOBAL_typeEXT;
      bt = FFEINFO_basictypeNONE;
      kt = FFEINFO_kindtypeNONE;
      if (ffecom_is_altreturning_)
  type = ffecom_tree_subr_type;
      else
  type = ffecom_tree_fun_type_void;
      charfunc = FALSE;
      cmplxfunc = FALSE;
      break;

    default:
      assert ("say what??" == NULL);
      /* Fall through. */
    case FFEINFO_kindANY:
      gt = FFEGLOBAL_typeANY;
      bt = FFEINFO_basictypeNONE;
      kt = FFEINFO_kindtypeNONE;
      type = error_mark_node;
      charfunc = FALSE;
      cmplxfunc = FALSE;
      break;
    }

  if (altentries)
    {
      id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
             ffesymbol_text (fn));
    }
#if FFETARGET_isENFORCED_MAIN
  else if (main_program)
    id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
#endif
  else
    id = ffecom_get_external_identifier_ (fn);

  start_function (id,
      type,
      0,    /* nested/inline */
      !altentries); /* TREE_PUBLIC */

  TREE_USED (current_function_decl) = 1;  /* Avoid spurious warning if altentries. */

  if (!altentries
      && ((g = ffesymbol_global (fn)) != NULL)
      && ((ffeglobal_type (g) == gt)
    || (ffeglobal_type (g) == egt)))
    {
      ffeglobal_set_hook (g, current_function_decl);
    }

  /* Arg handling needs exec-transitioned ffesymbols to work with.  But
     exec-transitioning needs current_function_decl to be filled in.  So we
     do these things in two phases. */

  if (altentries)
    {       /* 1st arg identifies which entrypoint. */
      ffecom_which_entrypoint_decl_
  = build_decl (PARM_DECL,
          ffecom_get_invented_identifier ("__g77_%s",
                  "which_entrypoint"),
          integer_type_node);
      push_parm_decl (ffecom_which_entrypoint_decl_);
    }

  if (charfunc
      || cmplxfunc
      || multi)
    {       /* Arg for result (return value). */
      tree type;
      tree length;

      if (charfunc)
  type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
      else if (cmplxfunc)
  type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
      else
  type = ffecom_multi_type_node_;

      result = ffecom_get_invented_identifier ("__g77_%s", "result");

      /* Make length arg _and_ enhance type info for CHAR arg itself.  */

      if (charfunc)
  length = ffecom_char_enhance_arg_ (&type, fn);
      else
  length = NULL_TREE; /* Not ref'd if !charfunc. */

      type = build_pointer_type (type);
      result = build_decl (PARM_DECL, result, type);

      push_parm_decl (result);
      if (multi)
  ffecom_multi_retval_ = result;
      else
  ffecom_func_result_ = result;

      if (charfunc)
  {
    push_parm_decl (length);
    ffecom_func_length_ = length;
  }
    }

  if (ffecom_primary_entry_is_proc_)
    {
      if (altentries)
  arglist = ffecom_master_arglist_;
      else
  arglist = ffesymbol_dummyargs (fn);
      ffecom_push_dummy_decls_ (arglist, FALSE);
    }

  if (TREE_CODE (current_function_decl) != ERROR_MARK)
    store_parm_decls (main_program ? 1 : 0);

  ffecom_start_compstmt ();
  /* Disallow temp vars at this level.  */
  current_binding_level->prep_state = 2;

  lineno = old_lineno;
  input_filename = old_input_filename;

  /* This handles any symbols still untransformed, in case -g specified.
     This used to be done in ffecom_finish_progunit, but it turns out to
     be necessary to do it here so that statement functions are
     expanded before code.  But don't bother for BLOCK DATA.  */

  if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
    ffesymbol_drive (ffecom_finish_symbol_transform_);
}

/* ffecom_sym_transform_ -- Transform FFE sym into backend sym

   ffesymbol s;
   ffecom_sym_transform_(s);

   The ffesymbol_hook info for s is updated with appropriate backend info
   on the symbol.  */

static ffesymbol
ffecom_sym_transform_ (ffesymbol s)
{
  tree t;     /* Transformed thingy. */
  tree tlen;      /* Length if CHAR*(*). */
  bool addr;      /* Is t the address of the thingy? */
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffeglobal g;
  int old_lineno = lineno;
  const char *old_input_filename = input_filename;

  /* Must ensure special ASSIGN variables are declared at top of outermost
     block, else they'll end up in the innermost block when their first
     ASSIGN is seen, which leaves them out of scope when they're the
     subject of a GOTO or I/O statement.

     We make this variable even if -fugly-assign.  Just let it go unused,
     in case it turns out there are cases where we really want to use this
     variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */

  if (! ffecom_transform_only_dummies_
      && ffesymbol_assigned (s)
      && ! ffesymbol_hook (s).assign_tree)
    s = ffecom_sym_transform_assign_ (s);

  if (ffesymbol_sfdummyparent (s) == NULL)
    {
      input_filename = ffesymbol_where_filename (s);
      lineno = ffesymbol_where_filelinenum (s);
    }
  else
    {
      ffesymbol sf = ffesymbol_sfdummyparent (s);

      input_filename = ffesymbol_where_filename (sf);
      lineno = ffesymbol_where_filelinenum (sf);
    }

  bt = ffeinfo_basictype (ffebld_info (s));
  kt = ffeinfo_kindtype (ffebld_info (s));

  t = NULL_TREE;
  tlen = NULL_TREE;
  addr = FALSE;

  switch (ffesymbol_kind (s))
    {
    case FFEINFO_kindNONE:
      switch (ffesymbol_where (s))
  {
  case FFEINFO_whereDUMMY:  /* Subroutine or function. */
    assert (ffecom_transform_only_dummies_);

    /* Before 0.4, this could be ENTITY/DUMMY, but see
       ffestu_sym_end_transition -- no longer true (in particular, if
       it could be an ENTITY, it _will_ be made one, so that
       possibility won't come through here).  So we never make length
       arg for CHARACTER type.  */

    t = build_decl (PARM_DECL,
        ffecom_get_identifier_ (ffesymbol_text (s)),
        ffecom_tree_ptr_to_subr_type);
    DECL_ARTIFICIAL (t) = 1;
    addr = TRUE;
    break;

  case FFEINFO_whereGLOBAL: /* Subroutine or function. */
    assert (!ffecom_transform_only_dummies_);

    if (((g = ffesymbol_global (s)) != NULL)
        && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
      || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
      || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
        && (ffeglobal_hook (g) != NULL_TREE)
        && ffe_is_globals ())
      {
        t = ffeglobal_hook (g);
        break;
      }

    t = build_decl (FUNCTION_DECL,
        ffecom_get_external_identifier_ (s),
        ffecom_tree_subr_type); /* Assume subr. */
    DECL_EXTERNAL (t) = 1;
    TREE_PUBLIC (t) = 1;

    t = start_decl (t, FALSE);
    finish_decl (t, NULL_TREE, FALSE);

    if ((g != NULL)
        && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
      || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
      || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
      ffeglobal_set_hook (g, t);

    ffecom_save_tree_forever (t);

    break;

  default:
    assert ("NONE where unexpected" == NULL);
    /* Fall through. */
  case FFEINFO_whereANY:
    break;
  }
      break;

    case FFEINFO_kindENTITY:
      switch (ffeinfo_where (ffesymbol_info (s)))
  {

  case FFEINFO_whereCONSTANT:
    /* ~~Debugging info needed? */
    assert (!ffecom_transform_only_dummies_);
    t = error_mark_node;  /* Shouldn't ever see this in expr. */
    break;

  case FFEINFO_whereLOCAL:
    assert (!ffecom_transform_only_dummies_);

    {
      ffestorag st = ffesymbol_storage (s);
      tree type;

      if ((st != NULL)
    && (ffestorag_size (st) == 0))
        {
    t = error_mark_node;
    break;
        }

      type = ffecom_type_localvar_ (s, bt, kt);

      if (type == error_mark_node)
        {
    t = error_mark_node;
    break;
        }

      if ((st != NULL)
    && (ffestorag_parent (st) != NULL))
        {     /* Child of EQUIVALENCE parent. */
    ffestorag est;
    tree et;
    ffetargetOffset offset;

    est = ffestorag_parent (st);
    ffecom_transform_equiv_ (est);

    et = ffestorag_hook (est);
    assert (et != NULL_TREE);

    if (! TREE_STATIC (et))
      put_var_into_stack (et);

    offset = ffestorag_modulo (est)
      + ffestorag_offset (ffesymbol_storage (s))
      - ffestorag_offset (est);

    ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);

    /* (t_type *) (((char *) &et) + offset) */

    t = convert (string_type_node,  /* (char *) */
           ffecom_1 (ADDR_EXPR,
               build_pointer_type (TREE_TYPE (et)),
               et));
    t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
            t,
            build_int_2 (offset, 0));
    t = convert (build_pointer_type (type),
           t);
    TREE_CONSTANT (t) = staticp (et);

    addr = TRUE;
        }
      else
        {
    tree initexpr;
    bool init = ffesymbol_is_init (s);

    t = build_decl (VAR_DECL,
        ffecom_get_identifier_ (ffesymbol_text (s)),
        type);

    if (init
        || ffesymbol_namelisted (s)
#ifdef FFECOM_sizeMAXSTACKITEM
        || ((st != NULL)
      && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
#endif
        || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
      && (ffecom_primary_entry_kind_
          != FFEINFO_kindBLOCKDATA)
      && (ffesymbol_is_save (s) || ffe_is_saveall ())))
      TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
    else
      TREE_STATIC (t) = 0;  /* No need to make static. */

    if (init || ffe_is_init_local_zero ())
      DECL_INITIAL (t) = error_mark_node;

    /* Keep -Wunused from complaining about var if it
       is used as sfunc arg or DATA implied-DO.  */
    if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
      DECL_IN_SYSTEM_HEADER (t) = 1;

    t = start_decl (t, FALSE);

    if (init)
      {
        if (ffesymbol_init (s) != NULL)
          initexpr = ffecom_expr (ffesymbol_init (s));
        else
          initexpr = ffecom_init_zero_ (t);
      }
    else if (ffe_is_init_local_zero ())
      initexpr = ffecom_init_zero_ (t);
    else
      initexpr = NULL_TREE; /* Not ref'd if !init. */

    finish_decl (t, initexpr, FALSE);

    if (st != NULL && DECL_SIZE (t) != error_mark_node)
      {
        assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
        assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
               ffestorag_size (st)));
      }
        }
    }
    break;

  case FFEINFO_whereRESULT:
    assert (!ffecom_transform_only_dummies_);

    if (bt == FFEINFO_basictypeCHARACTER)
      {     /* Result is already in list of dummies, use
           it (& length). */
        t = ffecom_func_result_;
        tlen = ffecom_func_length_;
        addr = TRUE;
        break;
      }
    if ((ffecom_num_entrypoints_ == 0)
        && (bt == FFEINFO_basictypeCOMPLEX)
        && (ffesymbol_is_f2c (ffecom_primary_entry_)))
      {     /* Result is already in list of dummies, use
           it. */
        t = ffecom_func_result_;
        addr = TRUE;
        break;
      }
    if (ffecom_func_result_ != NULL_TREE)
      {
        t = ffecom_func_result_;
        break;
      }
    if ((ffecom_num_entrypoints_ != 0)
        && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
      {
        assert (ffecom_multi_retval_ != NULL_TREE);
        t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
          ffecom_multi_retval_);
        t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
          t, ffecom_multi_fields_[bt][kt]);

        break;
      }

    t = build_decl (VAR_DECL,
        ffecom_get_identifier_ (ffesymbol_text (s)),
        ffecom_tree_type[bt][kt]);
    TREE_STATIC (t) = 0;  /* Put result on stack. */
    t = start_decl (t, FALSE);
    finish_decl (t, NULL_TREE, FALSE);

    ffecom_func_result_ = t;

    break;

  case FFEINFO_whereDUMMY:
    {
      tree type;
      ffebld dl;
      ffebld dim;
      tree low;
      tree high;
      tree old_sizes;
      bool adjustable = FALSE;  /* Conditionally adjustable? */

      type = ffecom_tree_type[bt][kt];
      if (ffesymbol_sfdummyparent (s) != NULL)
        {
    if (current_function_decl == ffecom_outer_function_decl_)
      {     /* Exec transition before sfunc
             context; get it later. */
        break;
      }
    t = ffecom_get_identifier_ (ffesymbol_text
              (ffesymbol_sfdummyparent (s)));
        }
      else
        t =