gcc/f/com.c

/* com.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   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 "real.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"
#include "debug.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 GTY(()) 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 GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
static GTY(()) tree
  ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
static GTY(()) tree ffecom_tree_subr_type;
static GTY(()) tree ffecom_tree_ptr_to_subr_type;
static GTY(()) tree ffecom_tree_blockdata_type;

static GTY(()) 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;
static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node;
tree ffecom_f2c_address_type_node;
tree ffecom_f2c_real_type_node;
static GTY(()) 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 tree ffe_type_for_mode (enum machine_mode, int);
static tree ffe_type_for_size (unsigned int, int);
static tree ffe_unsigned_type (tree);
static tree ffe_signed_type (tree);
static tree ffe_signed_or_unsigned_type (int, tree);
static bool ffe_mark_addressable (tree);
static tree ffe_truthvalue_conversion (tree);
static void ffecom_init_decl_processing (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 *ffe_printable_name (tree decl, int v);
static void ffe_print_error_function (diagnostic_context *, const char *);
static tree lookup_name_current_level (tree name);
static struct f_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 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 GTY(()) tree ffecom_outer_function_decl_;
static GTY(()) tree ffecom_previous_function_decl_;
static GTY(()) tree ffecom_which_entrypoint_decl_;
static GTY(()) tree ffecom_float_zero_;
static GTY(()) tree ffecom_float_half_;
static GTY(()) tree ffecom_double_zero_;
static GTY(()) tree ffecom_double_half_;
static GTY(()) tree ffecom_func_result_;/* For functions. */
static GTY(()) 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 GTY(()) tree ffecom_multi_type_node_;
static GTY(()) tree ffecom_multi_retval_;
static GTY(()) 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 GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];

/* 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 f_binding_level GTY(())
  {
    /* 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 f_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 f_binding_level *) NULL

/* The binding level currently in effect.  */

static GTY(()) struct f_binding_level *current_binding_level;

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

static GTY((deletable (""))) struct f_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 f_binding_level *global_binding_level;

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

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

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

struct lang_identifier GTY(())
{
  struct tree_identifier common;
  tree global_value;
  tree local_value;
  tree 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)

/* The resulting tree type.  */
union lang_tree_node
  GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
       chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
{
  union tree_node GTY ((tag ("0"),
			desc ("tree_node_structure (&%h)")))
    generic;
  struct lang_identifier GTY ((tag ("1"))) identifier;
};

/* Fortran doesn't use either of these.  */
struct lang_decl GTY(())
{
};
struct lang_type GTY(())
{
};

/* 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 GTY(()) tree named_labels;

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

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

   `array' is the array type 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).
   `item' is the array decl or NULL_TREE.
*/

static tree
ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
			 const char *array_name, tree item)
{
  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));
        }
    }

  /* If the array index is safe at compile-time, return element.  */
  if (integer_nonzerop (cond))
    return element;

  {
    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 (input_line, 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;
  die = convert (void_type_node, die);

  if (integer_zerop (cond) && item)
    ffe_mark_addressable (item);

  return ffecom_3 (COND_EXPR, TREE_TYPE (element), cond, element, die);
}

/* 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 nonzero 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
	  && ! ffe_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, item);
	  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, item);
	  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_ (tree type, tree 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_ (tree type, tree 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, 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 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_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))
	{
	  tempvar = hook;
	  assert (tempvar);
	}
      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, NULL_TREE);
		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, NULL_TREE);
	    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, NULL_TREE);
		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);
	  }
	tempvar = ffebld_nonter_hook (expr);
	assert (tempvar);
	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;

	  tempvar = ffebld_nonter_hook (expr);
	  assert (tempvar);
	  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. */
  location_t old_loc = input_location;

  input_filename = ffesymbol_where_filename (fn);
  input_line = 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);

  input_location = old_loc;

  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, 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, 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: