• Main Page
  • Modules
  • Data Types
  • Files

osprey/kgccfe/gnu/f/com.c

Go to the documentation of this file.
00001 /* com.c -- Implementation File (module.c template V1.0)
00002    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
00003    Free Software Foundation, Inc.
00004    Contributed by James Craig Burley.
00005 
00006 This file is part of GNU Fortran.
00007 
00008 GNU Fortran is free software; you can redistribute it and/or modify
00009 it under the terms of the GNU General Public License as published by
00010 the Free Software Foundation; either version 2, or (at your option)
00011 any later version.
00012 
00013 GNU Fortran is distributed in the hope that it will be useful,
00014 but WITHOUT ANY WARRANTY; without even the implied warranty of
00015 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00016 GNU General Public License for more details.
00017 
00018 You should have received a copy of the GNU General Public License
00019 along with GNU Fortran; see the file COPYING.  If not, write to
00020 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
00021 02111-1307, USA.
00022 
00023    Related Modules:
00024       None
00025 
00026    Description:
00027       Contains compiler-specific functions.
00028 
00029    Modifications:
00030 */
00031 
00032 /* Understanding this module means understanding the interface between
00033    the g77 front end and the gcc back end (or, perhaps, some other
00034    back end).  In here are the functions called by the front end proper
00035    to notify whatever back end is in place about certain things, and
00036    also the back-end-specific functions.  It's a bear to deal with, so
00037    lately I've been trying to simplify things, especially with regard
00038    to the gcc-back-end-specific stuff.
00039 
00040    Building expressions generally seems quite easy, but building decls
00041    has been challenging and is undergoing revision.  gcc has several
00042    kinds of decls:
00043 
00044    TYPE_DECL -- a type (int, float, struct, function, etc.)
00045    CONST_DECL -- a constant of some type other than function
00046    LABEL_DECL -- a variable or a constant?
00047    PARM_DECL -- an argument to a function (a variable that is a dummy)
00048    RESULT_DECL -- the return value of a function (a variable)
00049    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
00050    FUNCTION_DECL -- a function (either the actual function or an extern ref)
00051    FIELD_DECL -- a field in a struct or union (goes into types)
00052 
00053    g77 has a set of functions that somewhat parallels the gcc front end
00054    when it comes to building decls:
00055 
00056    Internal Function (one we define, not just declare as extern):
00057    if (is_nested) push_f_function_context ();
00058    start_function (get_identifier ("function_name"), function_type,
00059        is_nested, is_public);
00060    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
00061    store_parm_decls (is_main_program);
00062    ffecom_start_compstmt ();
00063    // for stmts and decls inside function, do appropriate things;
00064    ffecom_end_compstmt ();
00065    finish_function (is_nested);
00066    if (is_nested) pop_f_function_context ();
00067 
00068    Everything Else:
00069    tree d;
00070    tree init;
00071    // fill in external, public, static, &c for decl, and
00072    // set DECL_INITIAL to error_mark_node if going to initialize
00073    // set is_top_level TRUE only if not at top level and decl
00074    // must go in top level (i.e. not within current function decl context)
00075    d = start_decl (decl, is_top_level);
00076    init = ...;  // if have initializer
00077    finish_decl (d, init, is_top_level);
00078 
00079 */
00080 
00081 /* Include files. */
00082 
00083 #include "proj.h"
00084 #include "flags.h"
00085 #include "rtl.h"
00086 #include "toplev.h"
00087 #include "tree.h"
00088 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
00089 #include "convert.h"
00090 #include "ggc.h"
00091 #include "diagnostic.h"
00092 #include "intl.h"
00093 #include "langhooks.h"
00094 #include "langhooks-def.h"
00095 
00096 /* VMS-specific definitions */
00097 #ifdef VMS
00098 #include <descrip.h>
00099 #define O_RDONLY  0 /* Open arg for Read/Only  */
00100 #define O_WRONLY  1 /* Open arg for Write/Only */
00101 #define read(fd,buf,size) VMS_read (fd,buf,size)
00102 #define write(fd,buf,size)  VMS_write (fd,buf,size)
00103 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
00104 #define fopen(fname,mode) VMS_fopen (fname,mode)
00105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
00106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
00107 #define fstat(fd,stbuf)   VMS_fstat (fd,stbuf)
00108 static int VMS_fstat (), VMS_stat ();
00109 static char * VMS_strncat ();
00110 static int VMS_read ();
00111 static int VMS_write ();
00112 static int VMS_open ();
00113 static FILE * VMS_fopen ();
00114 static FILE * VMS_freopen ();
00115 static void hack_vms_include_specification ();
00116 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
00117 #define ino_t vms_ino_t
00118 #define INCLUDE_LEN_FUDGE 10  /* leave room for VMS syntax conversion */
00119 #endif /* VMS */
00120 
00121 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
00122 #include "com.h"
00123 #include "bad.h"
00124 #include "bld.h"
00125 #include "equiv.h"
00126 #include "expr.h"
00127 #include "implic.h"
00128 #include "info.h"
00129 #include "malloc.h"
00130 #include "src.h"
00131 #include "st.h"
00132 #include "storag.h"
00133 #include "symbol.h"
00134 #include "target.h"
00135 #include "top.h"
00136 #include "type.h"
00137 
00138 /* Externals defined here.  */
00139 
00140 /* Stream for reading from the input file.  */
00141 FILE *finput;
00142 
00143 /* These definitions parallel those in c-decl.c so that code from that
00144    module can be used pretty much as is.  Much of these defs aren't
00145    otherwise used, i.e. by g77 code per se, except some of them are used
00146    to build some of them that are.  The ones that are global (i.e. not
00147    "static") are those that ste.c and such might use (directly
00148    or by using com macros that reference them in their definitions).  */
00149 
00150 tree string_type_node;
00151 
00152 /* The rest of these are inventions for g77, though there might be
00153    similar things in the C front end.  As they are found, these
00154    inventions should be renamed to be canonical.  Note that only
00155    the ones currently required to be global are so.  */
00156 
00157 static tree ffecom_tree_fun_type_void;
00158 
00159 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
00160 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
00161 tree ffecom_integer_one_node; /* " */
00162 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
00163 
00164 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
00165    just use build_function_type and build_pointer_type on the
00166    appropriate _tree_type array element.  */
00167 
00168 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
00169 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
00170 static tree ffecom_tree_subr_type;
00171 static tree ffecom_tree_ptr_to_subr_type;
00172 static tree ffecom_tree_blockdata_type;
00173 
00174 static tree ffecom_tree_xargc_;
00175 
00176 ffecomSymbol ffecom_symbol_null_
00177 =
00178 {
00179   NULL_TREE,
00180   NULL_TREE,
00181   NULL_TREE,
00182   NULL_TREE,
00183   false
00184 };
00185 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
00186 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
00187 
00188 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
00189 tree ffecom_f2c_integer_type_node;
00190 tree ffecom_f2c_ptr_to_integer_type_node;
00191 tree ffecom_f2c_address_type_node;
00192 tree ffecom_f2c_real_type_node;
00193 tree ffecom_f2c_ptr_to_real_type_node;
00194 tree ffecom_f2c_doublereal_type_node;
00195 tree ffecom_f2c_complex_type_node;
00196 tree ffecom_f2c_doublecomplex_type_node;
00197 tree ffecom_f2c_longint_type_node;
00198 tree ffecom_f2c_logical_type_node;
00199 tree ffecom_f2c_flag_type_node;
00200 tree ffecom_f2c_ftnlen_type_node;
00201 tree ffecom_f2c_ftnlen_zero_node;
00202 tree ffecom_f2c_ftnlen_one_node;
00203 tree ffecom_f2c_ftnlen_two_node;
00204 tree ffecom_f2c_ptr_to_ftnlen_type_node;
00205 tree ffecom_f2c_ftnint_type_node;
00206 tree ffecom_f2c_ptr_to_ftnint_type_node;
00207 
00208 /* Simple definitions and enumerations. */
00209 
00210 #ifndef FFECOM_sizeMAXSTACKITEM
00211 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
00212              larger than this # bytes
00213              off stack if possible. */
00214 #endif
00215 
00216 /* For systems that have large enough stacks, they should define
00217    this to 0, and here, for ease of use later on, we just undefine
00218    it if it is 0.  */
00219 
00220 #if FFECOM_sizeMAXSTACKITEM == 0
00221 #undef FFECOM_sizeMAXSTACKITEM
00222 #endif
00223 
00224 typedef enum
00225   {
00226     FFECOM_rttypeVOID_,
00227     FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
00228     FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
00229     FFECOM_rttypeINTEGER_,  /* f2c's `integer' type. */
00230     FFECOM_rttypeLONGINT_,  /* f2c's `longint' type. */
00231     FFECOM_rttypeLOGICAL_,  /* f2c's `logical' type. */
00232     FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
00233     FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
00234     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
00235     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
00236     FFECOM_rttypeDOUBLE_, /* C's `double' type. */
00237     FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
00238     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
00239     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
00240     FFECOM_rttypeCHARACTER_,  /* f2c `char *'/`ftnlen' pair. */
00241     FFECOM_rttype_
00242   } ffecomRttype_;
00243 
00244 /* Internal typedefs. */
00245 
00246 typedef struct _ffecom_concat_list_ ffecomConcatList_;
00247 
00248 /* Private include files. */
00249 
00250 
00251 /* Internal structure definitions. */
00252 
00253 struct _ffecom_concat_list_
00254   {
00255     ffebld *exprs;
00256     int count;
00257     int max;
00258     ffetargetCharacterSize minlen;
00259     ffetargetCharacterSize maxlen;
00260   };
00261 
00262 /* Static functions (internal). */
00263 
00264 static void ffecom_init_decl_processing PARAMS ((void));
00265 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
00266 static tree ffecom_widest_expr_type_ (ffebld list);
00267 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
00268            tree dest_size, tree source_tree,
00269            ffebld source, bool scalar_arg);
00270 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
00271               tree args, tree callee_commons,
00272               bool scalar_args);
00273 static tree ffecom_build_f2c_string_ (int i, const char *s);
00274 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
00275         bool is_f2c_complex, tree type,
00276         tree args, tree dest_tree,
00277         ffebld dest, bool *dest_used,
00278         tree callee_commons, bool scalar_args, tree hook);
00279 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
00280         bool is_f2c_complex, tree type,
00281         ffebld left, ffebld right,
00282         tree dest_tree, ffebld dest,
00283         bool *dest_used, tree callee_commons,
00284         bool scalar_args, bool ref, tree hook);
00285 static void ffecom_char_args_x_ (tree *xitem, tree *length,
00286          ffebld expr, bool with_null);
00287 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
00288 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
00289 static ffecomConcatList_
00290   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
00291             ffebld expr,
00292             ffetargetCharacterSize max);
00293 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
00294 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
00295             ffetargetCharacterSize max);
00296 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
00297           ffesymbol member, tree member_type,
00298           ffetargetOffset offset);
00299 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
00300 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
00301         bool *dest_used, bool assignp, bool widenp);
00302 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
00303             ffebld dest, bool *dest_used);
00304 static tree ffecom_expr_power_integer_ (ffebld expr);
00305 static void ffecom_expr_transform_ (ffebld expr);
00306 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
00307 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
00308               int code);
00309 static ffeglobal ffecom_finish_global_ (ffeglobal global);
00310 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
00311 static tree ffecom_get_appended_identifier_ (char us, const char *text);
00312 static tree ffecom_get_external_identifier_ (ffesymbol s);
00313 static tree ffecom_get_identifier_ (const char *text);
00314 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
00315           ffeinfoBasictype bt,
00316           ffeinfoKindtype kt);
00317 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
00318 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
00319 static tree ffecom_init_zero_ (tree decl);
00320 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
00321              tree *maybe_tree);
00322 static tree ffecom_intrinsic_len_ (ffebld expr);
00323 static void ffecom_let_char_ (tree dest_tree,
00324             tree dest_length,
00325             ffetargetCharacterSize dest_size,
00326             ffebld source);
00327 static void ffecom_make_gfrt_ (ffecomGfrt ix);
00328 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
00329 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
00330 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
00331               ffebld source);
00332 static void ffecom_push_dummy_decls_ (ffebld dumlist,
00333               bool stmtfunc);
00334 static void ffecom_start_progunit_ (void);
00335 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
00336 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
00337 static void ffecom_transform_common_ (ffesymbol s);
00338 static void ffecom_transform_equiv_ (ffestorag st);
00339 static tree ffecom_transform_namelist_ (ffesymbol s);
00340 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
00341                tree t);
00342 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
00343                tree *size, tree tree);
00344 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
00345          tree dest_tree, ffebld dest,
00346          bool *dest_used, tree hook);
00347 static tree ffecom_type_localvar_ (ffesymbol s,
00348            ffeinfoBasictype bt,
00349            ffeinfoKindtype kt);
00350 static tree ffecom_type_namelist_ (void);
00351 static tree ffecom_type_vardesc_ (void);
00352 static tree ffecom_vardesc_ (ffebld expr);
00353 static tree ffecom_vardesc_array_ (ffesymbol s);
00354 static tree ffecom_vardesc_dims_ (ffesymbol s);
00355 static tree ffecom_convert_narrow_ (tree type, tree expr);
00356 static tree ffecom_convert_widen_ (tree type, tree expr);
00357 
00358 /* These are static functions that parallel those found in the C front
00359    end and thus have the same names.  */
00360 
00361 static tree bison_rule_compstmt_ (void);
00362 static void bison_rule_pushlevel_ (void);
00363 static void delete_block (tree block);
00364 static int duplicate_decls (tree newdecl, tree olddecl);
00365 static void finish_decl (tree decl, tree init, bool is_top_level);
00366 static void finish_function (int nested);
00367 static const char *lang_printable_name (tree decl, int v);
00368 static tree lookup_name_current_level (tree name);
00369 static struct binding_level *make_binding_level (void);
00370 static void pop_f_function_context (void);
00371 static void push_f_function_context (void);
00372 static void push_parm_decl (tree parm);
00373 static tree pushdecl_top_level (tree decl);
00374 static int kept_level_p (void);
00375 static tree storedecls (tree decls);
00376 static void store_parm_decls (int is_main_program);
00377 static tree start_decl (tree decl, bool is_top_level);
00378 static void start_function (tree name, tree type, int nested, int public);
00379 static void ffecom_file_ (const char *name);
00380 static void ffecom_close_include_ (FILE *f);
00381 static int ffecom_decode_include_option_ (char *spec);
00382 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
00383            ffewhereColumn c);
00384 
00385 /* Static objects accessed by functions in this module. */
00386 
00387 static ffesymbol ffecom_primary_entry_ = NULL;
00388 static ffesymbol ffecom_nested_entry_ = NULL;
00389 static ffeinfoKind ffecom_primary_entry_kind_;
00390 static bool ffecom_primary_entry_is_proc_;
00391 static tree ffecom_outer_function_decl_;
00392 static tree ffecom_previous_function_decl_;
00393 static tree ffecom_which_entrypoint_decl_;
00394 static tree ffecom_float_zero_ = NULL_TREE;
00395 static tree ffecom_float_half_ = NULL_TREE;
00396 static tree ffecom_double_zero_ = NULL_TREE;
00397 static tree ffecom_double_half_ = NULL_TREE;
00398 static tree ffecom_func_result_;/* For functions. */
00399 static tree ffecom_func_length_;/* For CHARACTER fns. */
00400 static ffebld ffecom_list_blockdata_;
00401 static ffebld ffecom_list_common_;
00402 static ffebld ffecom_master_arglist_;
00403 static ffeinfoBasictype ffecom_master_bt_;
00404 static ffeinfoKindtype ffecom_master_kt_;
00405 static ffetargetCharacterSize ffecom_master_size_;
00406 static int ffecom_num_fns_ = 0;
00407 static int ffecom_num_entrypoints_ = 0;
00408 static bool ffecom_is_altreturning_ = FALSE;
00409 static tree ffecom_multi_type_node_;
00410 static tree ffecom_multi_retval_;
00411 static tree
00412   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
00413 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
00414 static bool ffecom_doing_entry_ = FALSE;
00415 static bool ffecom_transform_only_dummies_ = FALSE;
00416 static int ffecom_typesize_pointer_;
00417 static int ffecom_typesize_integer1_;
00418 
00419 /* Holds pointer-to-function expressions.  */
00420 
00421 static tree ffecom_gfrt_[FFECOM_gfrt]
00422 =
00423 {
00424 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
00425 #include "com-rt.def"
00426 #undef DEFGFRT
00427 };
00428 
00429 /* Holds the external names of the functions.  */
00430 
00431 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
00432 =
00433 {
00434 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
00435 #include "com-rt.def"
00436 #undef DEFGFRT
00437 };
00438 
00439 /* Whether the function returns.  */
00440 
00441 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
00442 =
00443 {
00444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
00445 #include "com-rt.def"
00446 #undef DEFGFRT
00447 };
00448 
00449 /* Whether the function returns type complex.  */
00450 
00451 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
00452 =
00453 {
00454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
00455 #include "com-rt.def"
00456 #undef DEFGFRT
00457 };
00458 
00459 /* Whether the function is const
00460    (i.e., has no side effects and only depends on its arguments).  */
00461 
00462 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
00463 =
00464 {
00465 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
00466 #include "com-rt.def"
00467 #undef DEFGFRT
00468 };
00469 
00470 /* Type code for the function return value.  */
00471 
00472 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
00473 =
00474 {
00475 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
00476 #include "com-rt.def"
00477 #undef DEFGFRT
00478 };
00479 
00480 /* String of codes for the function's arguments.  */
00481 
00482 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
00483 =
00484 {
00485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
00486 #include "com-rt.def"
00487 #undef DEFGFRT
00488 };
00489 
00490 /* Internal macros. */
00491 
00492 /* We let tm.h override the types used here, to handle trivial differences
00493    such as the choice of unsigned int or long unsigned int for size_t.
00494    When machines start needing nontrivial differences in the size type,
00495    it would be best to do something here to figure out automatically
00496    from other information what type to use.  */
00497 
00498 #ifndef SIZE_TYPE
00499 #define SIZE_TYPE "long unsigned int"
00500 #endif
00501 
00502 #define ffecom_concat_list_count_(catlist) ((catlist).count)
00503 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
00504 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
00505 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
00506 
00507 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
00508 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
00509 
00510 /* For each binding contour we allocate a binding_level structure
00511  * which records the names defined in that contour.
00512  * Contours include:
00513  *  0) the global one
00514  *  1) one for each function definition,
00515  *     where internal declarations of the parameters appear.
00516  *
00517  * The current meaning of a name can be found by searching the levels from
00518  * the current one out to the global one.
00519  */
00520 
00521 /* Note that the information in the `names' component of the global contour
00522    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
00523 
00524 struct binding_level
00525   {
00526     /* A chain of _DECL nodes for all variables, constants, functions,
00527        and typedef types.  These are in the reverse of the order supplied.
00528      */
00529     tree names;
00530 
00531     /* For each level (except not the global one),
00532        a chain of BLOCK nodes for all the levels
00533        that were entered and exited one level down.  */
00534     tree blocks;
00535 
00536     /* The BLOCK node for this level, if one has been preallocated.
00537        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
00538     tree this_block;
00539 
00540     /* The binding level which this one is contained in (inherits from).  */
00541     struct binding_level *level_chain;
00542 
00543     /* 0: no ffecom_prepare_* functions called at this level yet;
00544        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
00545        2: ffecom_prepare_end called.  */
00546     int prep_state;
00547   };
00548 
00549 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
00550 
00551 /* The binding level currently in effect.  */
00552 
00553 static struct binding_level *current_binding_level;
00554 
00555 /* A chain of binding_level structures awaiting reuse.  */
00556 
00557 static struct binding_level *free_binding_level;
00558 
00559 /* The outermost binding level, for names of file scope.
00560    This is created when the compiler is started and exists
00561    through the entire run.  */
00562 
00563 static struct binding_level *global_binding_level;
00564 
00565 /* Binding level structures are initialized by copying this one.  */
00566 
00567 static const struct binding_level clear_binding_level
00568 =
00569 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
00570 
00571 /* Language-dependent contents of an identifier.  */
00572 
00573 struct lang_identifier
00574   {
00575     struct tree_identifier ignore;
00576     tree global_value, local_value, label_value;
00577     bool invented;
00578   };
00579 
00580 /* Macros for access to language-specific slots in an identifier.  */
00581 /* Each of these slots contains a DECL node or null.  */
00582 
00583 /* This represents the value which the identifier has in the
00584    file-scope namespace.  */
00585 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
00586   (((struct lang_identifier *)(NODE))->global_value)
00587 /* This represents the value which the identifier has in the current
00588    scope.  */
00589 #define IDENTIFIER_LOCAL_VALUE(NODE)  \
00590   (((struct lang_identifier *)(NODE))->local_value)
00591 /* This represents the value which the identifier has as a label in
00592    the current label scope.  */
00593 #define IDENTIFIER_LABEL_VALUE(NODE)  \
00594   (((struct lang_identifier *)(NODE))->label_value)
00595 /* This is nonzero if the identifier was "made up" by g77 code.  */
00596 #define IDENTIFIER_INVENTED(NODE) \
00597   (((struct lang_identifier *)(NODE))->invented)
00598 
00599 /* In identifiers, C uses the following fields in a special way:
00600    TREE_PUBLIC        to record that there was a previous local extern decl.
00601    TREE_USED        to record that such a decl was used.
00602    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
00603 
00604 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
00605    that have names.  Here so we can clear out their names' definitions
00606    at the end of the function.  */
00607 
00608 static tree named_labels;
00609 
00610 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
00611 
00612 static tree shadowed_labels;
00613 
00614 /* Return the subscript expression, modified to do range-checking.
00615 
00616    `array' is the array to be checked against.
00617    `element' is the subscript expression to check.
00618    `dim' is the dimension number (starting at 0).
00619    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
00620 */
00621 
00622 static tree
00623 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
00624        const char *array_name)
00625 {
00626   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
00627   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
00628   tree cond;
00629   tree die;
00630   tree args;
00631 
00632   if (element == error_mark_node)
00633     return element;
00634 
00635   if (TREE_TYPE (low) != TREE_TYPE (element))
00636     {
00637       if (TYPE_PRECISION (TREE_TYPE (low))
00638     > TYPE_PRECISION (TREE_TYPE (element)))
00639   element = convert (TREE_TYPE (low), element);
00640       else
00641   {
00642     low = convert (TREE_TYPE (element), low);
00643     if (high)
00644       high = convert (TREE_TYPE (element), high);
00645   }
00646     }
00647 
00648   element = ffecom_save_tree (element);
00649   if (total_dims == 0)
00650     {
00651       /* Special handling for substring range checks.  Fortran allows the
00652          end subscript < begin subscript, which means that expressions like
00653        string(1:0) are valid (and yield a null string).  In view of this,
00654        enforce two simpler conditions:
00655           1) element<=high for end-substring;
00656           2) element>=low for start-substring.
00657        Run-time character movement will enforce remaining conditions.
00658 
00659        More complicated checks would be better, but present structure only
00660        provides one index element at a time, so it is not possible to
00661        enforce a check of both i and j in string(i:j).  If it were, the
00662        complete set of rules would read,
00663          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
00664               ((low<=i<=high) && (low<=j<=high)) )
00665            ok ;
00666          else
00667            range error ;
00668       */
00669       if (dim)
00670         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
00671       else
00672         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
00673     }
00674   else
00675     {
00676       /* Array reference substring range checking.  */
00677 
00678       cond = ffecom_2 (LE_EXPR, integer_type_node,
00679                      low,
00680                      element);
00681       if (high)
00682         {
00683           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
00684                          cond,
00685                          ffecom_2 (LE_EXPR, integer_type_node,
00686                                    element,
00687                                    high));
00688         }
00689     }
00690 
00691   {
00692     int len;
00693     char *proc;
00694     char *var;
00695     tree arg3;
00696     tree arg2;
00697     tree arg1;
00698     tree arg4;
00699 
00700     switch (total_dims)
00701       {
00702       case 0:
00703   var = concat (array_name, "[", (dim ? "end" : "start"),
00704           "-substring]", NULL);
00705   len = strlen (var) + 1;
00706   arg1 = build_string (len, var);
00707   free (var);
00708   break;
00709 
00710       case 1:
00711   len = strlen (array_name) + 1;
00712   arg1 = build_string (len, array_name);
00713   break;
00714 
00715       default:
00716   var = xmalloc (strlen (array_name) + 40);
00717   sprintf (var, "%s[subscript-%d-of-%d]",
00718      array_name,
00719      dim + 1, total_dims);
00720   len = strlen (var) + 1;
00721   arg1 = build_string (len, var);
00722   free (var);
00723   break;
00724       }
00725 
00726     TREE_TYPE (arg1)
00727       = build_type_variant (build_array_type (char_type_node,
00728                 build_range_type
00729                 (integer_type_node,
00730                  integer_one_node,
00731                  build_int_2 (len, 0))),
00732           1, 0);
00733     TREE_CONSTANT (arg1) = 1;
00734     TREE_STATIC (arg1) = 1;
00735     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
00736          arg1);
00737 
00738     /* s_rnge adds one to the element to print it, so bias against
00739        that -- want to print a faithful *subscript* value.  */
00740     arg2 = convert (ffecom_f2c_ftnint_type_node,
00741         ffecom_2 (MINUS_EXPR,
00742             TREE_TYPE (element),
00743             element,
00744             convert (TREE_TYPE (element),
00745                integer_one_node)));
00746 
00747     proc = concat (input_filename, "/",
00748        IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
00749        NULL);
00750     len = strlen (proc) + 1;
00751     arg3 = build_string (len, proc);
00752 
00753     free (proc);
00754 
00755     TREE_TYPE (arg3)
00756       = build_type_variant (build_array_type (char_type_node,
00757                 build_range_type
00758                 (integer_type_node,
00759                  integer_one_node,
00760                  build_int_2 (len, 0))),
00761           1, 0);
00762     TREE_CONSTANT (arg3) = 1;
00763     TREE_STATIC (arg3) = 1;
00764     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
00765          arg3);
00766 
00767     arg4 = convert (ffecom_f2c_ftnint_type_node,
00768         build_int_2 (lineno, 0));
00769 
00770     arg1 = build_tree_list (NULL_TREE, arg1);
00771     arg2 = build_tree_list (NULL_TREE, arg2);
00772     arg3 = build_tree_list (NULL_TREE, arg3);
00773     arg4 = build_tree_list (NULL_TREE, arg4);
00774     TREE_CHAIN (arg3) = arg4;
00775     TREE_CHAIN (arg2) = arg3;
00776     TREE_CHAIN (arg1) = arg2;
00777 
00778     args = arg1;
00779   }
00780   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
00781         args, NULL_TREE);
00782   TREE_SIDE_EFFECTS (die) = 1;
00783 
00784   element = ffecom_3 (COND_EXPR,
00785           TREE_TYPE (element),
00786           cond,
00787           element,
00788           die);
00789 
00790   return element;
00791 }
00792 
00793 /* Return the computed element of an array reference.
00794 
00795    `item' is NULL_TREE, or the transformed pointer to the array.
00796    `expr' is the original opARRAYREF expression, which is transformed
00797      if `item' is NULL_TREE.
00798    `want_ptr' is non-zero if a pointer to the element, instead of
00799      the element itself, is to be returned.  */
00800 
00801 static tree
00802 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
00803 {
00804   ffebld dims[FFECOM_dimensionsMAX];
00805   int i;
00806   int total_dims;
00807   int flatten = ffe_is_flatten_arrays ();
00808   int need_ptr;
00809   tree array;
00810   tree element;
00811   tree tree_type;
00812   tree tree_type_x;
00813   const char *array_name;
00814   ffetype type;
00815   ffebld list;
00816 
00817   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
00818     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
00819   else
00820     array_name = "[expr?]";
00821 
00822   /* Build up ARRAY_REFs in reverse order (since we're column major
00823      here in Fortran land). */
00824 
00825   for (i = 0, list = ffebld_right (expr);
00826        list != NULL;
00827        ++i, list = ffebld_trail (list))
00828     {
00829       dims[i] = ffebld_head (list);
00830       type = ffeinfo_type (ffebld_basictype (dims[i]),
00831          ffebld_kindtype (dims[i]));
00832       if (! flatten
00833     && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
00834     && ffetype_size (type) > ffecom_typesize_integer1_)
00835   /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
00836      pointers and 32-bit integers.  Do the full 64-bit pointer
00837      arithmetic, for codes using arrays for nonstandard heap-like
00838      work.  */
00839   flatten = 1;
00840     }
00841 
00842   total_dims = i;
00843 
00844   need_ptr = want_ptr || flatten;
00845 
00846   if (! item)
00847     {
00848       if (need_ptr)
00849   item = ffecom_ptr_to_expr (ffebld_left (expr));
00850       else
00851   item = ffecom_expr (ffebld_left (expr));
00852 
00853       if (item == error_mark_node)
00854   return item;
00855 
00856       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
00857     && ! mark_addressable (item))
00858   return error_mark_node;
00859     }
00860 
00861   if (item == error_mark_node)
00862     return item;
00863 
00864   if (need_ptr)
00865     {
00866       tree min;
00867 
00868       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
00869      i >= 0;
00870      --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
00871   {
00872     min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
00873     element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
00874     if (flag_bounds_check)
00875       element = ffecom_subscript_check_ (array, element, i, total_dims,
00876                  array_name);
00877     if (element == error_mark_node)
00878       return element;
00879 
00880     /* Widen integral arithmetic as desired while preserving
00881        signedness.  */
00882     tree_type = TREE_TYPE (element);
00883     tree_type_x = tree_type;
00884     if (tree_type
00885         && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
00886         && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
00887       tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
00888 
00889     if (TREE_TYPE (min) != tree_type_x)
00890       min = convert (tree_type_x, min);
00891     if (TREE_TYPE (element) != tree_type_x)
00892       element = convert (tree_type_x, element);
00893 
00894     item = ffecom_2 (PLUS_EXPR,
00895          build_pointer_type (TREE_TYPE (array)),
00896          item,
00897          size_binop (MULT_EXPR,
00898                size_in_bytes (TREE_TYPE (array)),
00899                convert (sizetype,
00900             fold (build (MINUS_EXPR,
00901                    tree_type_x,
00902                    element, min)))));
00903   }
00904       if (! want_ptr)
00905   {
00906     item = ffecom_1 (INDIRECT_REF,
00907          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
00908          item);
00909   }
00910     }
00911   else
00912     {
00913       for (--i;
00914      i >= 0;
00915      --i)
00916   {
00917     array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
00918 
00919     element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
00920     if (flag_bounds_check)
00921       element = ffecom_subscript_check_ (array, element, i, total_dims,
00922                  array_name);
00923     if (element == error_mark_node)
00924       return element;
00925 
00926     /* Widen integral arithmetic as desired while preserving
00927        signedness.  */
00928     tree_type = TREE_TYPE (element);
00929     tree_type_x = tree_type;
00930     if (tree_type
00931         && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
00932         && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
00933       tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
00934 
00935     element = convert (tree_type_x, element);
00936 
00937     item = ffecom_2 (ARRAY_REF,
00938          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
00939          item,
00940          element);
00941   }
00942     }
00943 
00944   return item;
00945 }
00946 
00947 /* This is like gcc's stabilize_reference -- in fact, most of the code
00948    comes from that -- but it handles the situation where the reference
00949    is going to have its subparts picked at, and it shouldn't change
00950    (or trigger extra invocations of functions in the subtrees) due to
00951    this.  save_expr is a bit overzealous, because we don't need the
00952    entire thing calculated and saved like a temp.  So, for DECLs, no
00953    change is needed, because these are stable aggregates, and ARRAY_REF
00954    and such might well be stable too, but for things like calculations,
00955    we do need to calculate a snapshot of a value before picking at it.  */
00956 
00957 static tree
00958 ffecom_stabilize_aggregate_ (tree ref)
00959 {
00960   tree result;
00961   enum tree_code code = TREE_CODE (ref);
00962 
00963   switch (code)
00964     {
00965     case VAR_DECL:
00966     case PARM_DECL:
00967     case RESULT_DECL:
00968       /* No action is needed in this case.  */
00969       return ref;
00970 
00971     case NOP_EXPR:
00972     case CONVERT_EXPR:
00973     case FLOAT_EXPR:
00974     case FIX_TRUNC_EXPR:
00975     case FIX_FLOOR_EXPR:
00976     case FIX_ROUND_EXPR:
00977     case FIX_CEIL_EXPR:
00978       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
00979       break;
00980 
00981     case INDIRECT_REF:
00982       result = build_nt (INDIRECT_REF,
00983        stabilize_reference_1 (TREE_OPERAND (ref, 0)));
00984       break;
00985 
00986     case COMPONENT_REF:
00987       result = build_nt (COMPONENT_REF,
00988        stabilize_reference (TREE_OPERAND (ref, 0)),
00989        TREE_OPERAND (ref, 1));
00990       break;
00991 
00992     case BIT_FIELD_REF:
00993       result = build_nt (BIT_FIELD_REF,
00994        stabilize_reference (TREE_OPERAND (ref, 0)),
00995        stabilize_reference_1 (TREE_OPERAND (ref, 1)),
00996        stabilize_reference_1 (TREE_OPERAND (ref, 2)));
00997       break;
00998 
00999     case ARRAY_REF:
01000       result = build_nt (ARRAY_REF,
01001        stabilize_reference (TREE_OPERAND (ref, 0)),
01002        stabilize_reference_1 (TREE_OPERAND (ref, 1)));
01003       break;
01004 
01005     case COMPOUND_EXPR:
01006       result = build_nt (COMPOUND_EXPR,
01007        stabilize_reference_1 (TREE_OPERAND (ref, 0)),
01008        stabilize_reference (TREE_OPERAND (ref, 1)));
01009       break;
01010 
01011     case RTL_EXPR:
01012       abort ();
01013 
01014 
01015     default:
01016       return save_expr (ref);
01017 
01018     case ERROR_MARK:
01019       return error_mark_node;
01020     }
01021 
01022   TREE_TYPE (result) = TREE_TYPE (ref);
01023   TREE_READONLY (result) = TREE_READONLY (ref);
01024   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
01025   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
01026 
01027   return result;
01028 }
01029 
01030 /* A rip-off of gcc's convert.c convert_to_complex function,
01031    reworked to handle complex implemented as C structures
01032    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
01033 
01034 static tree
01035 ffecom_convert_to_complex_ (tree type, tree expr)
01036 {
01037   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
01038   tree subtype;
01039 
01040   assert (TREE_CODE (type) == RECORD_TYPE);
01041 
01042   subtype = TREE_TYPE (TYPE_FIELDS (type));
01043 
01044   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
01045     {
01046       expr = convert (subtype, expr);
01047       return ffecom_2 (COMPLEX_EXPR, type, expr,
01048            convert (subtype, integer_zero_node));
01049     }
01050 
01051   if (form == RECORD_TYPE)
01052     {
01053       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
01054       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
01055   return expr;
01056       else
01057   {
01058     expr = save_expr (expr);
01059     return ffecom_2 (COMPLEX_EXPR,
01060          type,
01061          convert (subtype,
01062             ffecom_1 (REALPART_EXPR,
01063                 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
01064                 expr)),
01065          convert (subtype,
01066             ffecom_1 (IMAGPART_EXPR,
01067                 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
01068                 expr)));
01069   }
01070     }
01071 
01072   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
01073     error ("pointer value used where a complex was expected");
01074   else
01075     error ("aggregate value used where a complex was expected");
01076 
01077   return ffecom_2 (COMPLEX_EXPR, type,
01078        convert (subtype, integer_zero_node),
01079        convert (subtype, integer_zero_node));
01080 }
01081 
01082 /* Like gcc's convert(), but crashes if widening might happen.  */
01083 
01084 static tree
01085 ffecom_convert_narrow_ (type, expr)
01086      tree type, expr;
01087 {
01088   register tree e = expr;
01089   register enum tree_code code = TREE_CODE (type);
01090 
01091   if (type == TREE_TYPE (e)
01092       || TREE_CODE (e) == ERROR_MARK)
01093     return e;
01094   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
01095     return fold (build1 (NOP_EXPR, type, e));
01096   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
01097       || code == ERROR_MARK)
01098     return error_mark_node;
01099   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
01100     {
01101       assert ("void value not ignored as it ought to be" == NULL);
01102       return error_mark_node;
01103     }
01104   assert (code != VOID_TYPE);
01105   if ((code != RECORD_TYPE)
01106       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
01107     assert ("converting COMPLEX to REAL" == NULL);
01108   assert (code != ENUMERAL_TYPE);
01109   if (code == INTEGER_TYPE)
01110     {
01111       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
01112          && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
01113         || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
01114       && (TYPE_PRECISION (type)
01115           == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
01116       return fold (convert_to_integer (type, e));
01117     }
01118   if (code == POINTER_TYPE)
01119     {
01120       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
01121       return fold (convert_to_pointer (type, e));
01122     }
01123   if (code == REAL_TYPE)
01124     {
01125       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
01126       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
01127       return fold (convert_to_real (type, e));
01128     }
01129   if (code == COMPLEX_TYPE)
01130     {
01131       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
01132       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
01133       return fold (convert_to_complex (type, e));
01134     }
01135   if (code == RECORD_TYPE)
01136     {
01137       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
01138       /* Check that at least the first field name agrees.  */
01139       assert (DECL_NAME (TYPE_FIELDS (type))
01140         == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
01141       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
01142         <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
01143       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
01144     == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
01145   return e;
01146       return fold (ffecom_convert_to_complex_ (type, e));
01147     }
01148 
01149   assert ("conversion to non-scalar type requested" == NULL);
01150   return error_mark_node;
01151 }
01152 
01153 /* Like gcc's convert(), but crashes if narrowing might happen.  */
01154 
01155 static tree
01156 ffecom_convert_widen_ (type, expr)
01157      tree type, expr;
01158 {
01159   register tree e = expr;
01160   register enum tree_code code = TREE_CODE (type);
01161 
01162   if (type == TREE_TYPE (e)
01163       || TREE_CODE (e) == ERROR_MARK)
01164     return e;
01165   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
01166     return fold (build1 (NOP_EXPR, type, e));
01167   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
01168       || code == ERROR_MARK)
01169     return error_mark_node;
01170   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
01171     {
01172       assert ("void value not ignored as it ought to be" == NULL);
01173       return error_mark_node;
01174     }
01175   assert (code != VOID_TYPE);
01176   if ((code != RECORD_TYPE)
01177       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
01178     assert ("narrowing COMPLEX to REAL" == NULL);
01179   assert (code != ENUMERAL_TYPE);
01180   if (code == INTEGER_TYPE)
01181     {
01182       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
01183          && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
01184         || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
01185       && (TYPE_PRECISION (type)
01186           == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
01187       return fold (convert_to_integer (type, e));
01188     }
01189   if (code == POINTER_TYPE)
01190     {
01191       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
01192       return fold (convert_to_pointer (type, e));
01193     }
01194   if (code == REAL_TYPE)
01195     {
01196       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
01197       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
01198       return fold (convert_to_real (type, e));
01199     }
01200   if (code == COMPLEX_TYPE)
01201     {
01202       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
01203       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
01204       return fold (convert_to_complex (type, e));
01205     }
01206   if (code == RECORD_TYPE)
01207     {
01208       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
01209       /* Check that at least the first field name agrees.  */
01210       assert (DECL_NAME (TYPE_FIELDS (type))
01211         == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
01212       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
01213         >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
01214       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
01215     == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
01216   return e;
01217       return fold (ffecom_convert_to_complex_ (type, e));
01218     }
01219 
01220   assert ("conversion to non-scalar type requested" == NULL);
01221   return error_mark_node;
01222 }
01223 
01224 /* Handles making a COMPLEX type, either the standard
01225    (but buggy?) gbe way, or the safer (but less elegant?)
01226    f2c way.  */
01227 
01228 static tree
01229 ffecom_make_complex_type_ (tree subtype)
01230 {
01231   tree type;
01232   tree realfield;
01233   tree imagfield;
01234 
01235   if (ffe_is_emulate_complex ())
01236     {
01237       type = make_node (RECORD_TYPE);
01238       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
01239       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
01240       TYPE_FIELDS (type) = realfield;
01241       layout_type (type);
01242     }
01243   else
01244     {
01245       type = make_node (COMPLEX_TYPE);
01246       TREE_TYPE (type) = subtype;
01247       layout_type (type);
01248     }
01249 
01250   return type;
01251 }
01252 
01253 /* Chooses either the gbe or the f2c way to build a
01254    complex constant.  */
01255 
01256 static tree
01257 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
01258 {
01259   tree bothparts;
01260 
01261   if (ffe_is_emulate_complex ())
01262     {
01263       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
01264       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
01265       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
01266     }
01267   else
01268     {
01269       bothparts = build_complex (type, realpart, imagpart);
01270     }
01271 
01272   return bothparts;
01273 }
01274 
01275 static tree
01276 ffecom_arglist_expr_ (const char *c, ffebld expr)
01277 {
01278   tree list;
01279   tree *plist = &list;
01280   tree trail = NULL_TREE; /* Append char length args here. */
01281   tree *ptrail = &trail;
01282   tree length;
01283   ffebld exprh;
01284   tree item;
01285   bool ptr = FALSE;
01286   tree wanted = NULL_TREE;
01287   static const char zed[] = "0";
01288 
01289   if (c == NULL)
01290     c = &zed[0];
01291 
01292   while (expr != NULL)
01293     {
01294       if (*c != '\0')
01295   {
01296     ptr = FALSE;
01297     if (*c == '&')
01298       {
01299         ptr = TRUE;
01300         ++c;
01301       }
01302     switch (*(c++))
01303       {
01304       case '\0':
01305         ptr = TRUE;
01306         wanted = NULL_TREE;
01307         break;
01308 
01309       case 'a':
01310         assert (ptr);
01311         wanted = NULL_TREE;
01312         break;
01313 
01314       case 'c':
01315         wanted = ffecom_f2c_complex_type_node;
01316         break;
01317 
01318       case 'd':
01319         wanted = ffecom_f2c_doublereal_type_node;
01320         break;
01321 
01322       case 'e':
01323         wanted = ffecom_f2c_doublecomplex_type_node;
01324         break;
01325 
01326       case 'f':
01327         wanted = ffecom_f2c_real_type_node;
01328         break;
01329 
01330       case 'i':
01331         wanted = ffecom_f2c_integer_type_node;
01332         break;
01333 
01334       case 'j':
01335         wanted = ffecom_f2c_longint_type_node;
01336         break;
01337 
01338       default:
01339         assert ("bad argstring code" == NULL);
01340         wanted = NULL_TREE;
01341         break;
01342       }
01343   }
01344 
01345       exprh = ffebld_head (expr);
01346       if (exprh == NULL)
01347   wanted = NULL_TREE;
01348 
01349       if ((wanted == NULL_TREE)
01350     || (ptr
01351         && (TYPE_MODE
01352       (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
01353        [ffeinfo_kindtype (ffebld_info (exprh))])
01354        == TYPE_MODE (wanted))))
01355   *plist
01356     = build_tree_list (NULL_TREE,
01357            ffecom_arg_ptr_to_expr (exprh,
01358                  &length));
01359       else
01360   {
01361     item = ffecom_arg_expr (exprh, &length);
01362     item = ffecom_convert_widen_ (wanted, item);
01363     if (ptr)
01364       {
01365         item = ffecom_1 (ADDR_EXPR,
01366              build_pointer_type (TREE_TYPE (item)),
01367              item);
01368       }
01369     *plist
01370       = build_tree_list (NULL_TREE,
01371              item);
01372   }
01373 
01374       plist = &TREE_CHAIN (*plist);
01375       expr = ffebld_trail (expr);
01376       if (length != NULL_TREE)
01377   {
01378     *ptrail = build_tree_list (NULL_TREE, length);
01379     ptrail = &TREE_CHAIN (*ptrail);
01380   }
01381     }
01382 
01383   /* We've run out of args in the call; if the implementation expects
01384      more, supply null pointers for them, which the implementation can
01385      check to see if an arg was omitted. */
01386 
01387   while (*c != '\0' && *c != '0')
01388     {
01389       if (*c == '&')
01390   ++c;
01391       else
01392   assert ("missing arg to run-time routine!" == NULL);
01393 
01394       switch (*(c++))
01395   {
01396   case '\0':
01397   case 'a':
01398   case 'c':
01399   case 'd':
01400   case 'e':
01401   case 'f':
01402   case 'i':
01403   case 'j':
01404     break;
01405 
01406   default:
01407     assert ("bad arg string code" == NULL);
01408     break;
01409   }
01410       *plist
01411   = build_tree_list (NULL_TREE,
01412          null_pointer_node);
01413       plist = &TREE_CHAIN (*plist);
01414     }
01415 
01416   *plist = trail;
01417 
01418   return list;
01419 }
01420 
01421 static tree
01422 ffecom_widest_expr_type_ (ffebld list)
01423 {
01424   ffebld item;
01425   ffebld widest = NULL;
01426   ffetype type;
01427   ffetype widest_type = NULL;
01428   tree t;
01429 
01430   for (; list != NULL; list = ffebld_trail (list))
01431     {
01432       item = ffebld_head (list);
01433       if (item == NULL)
01434   continue;
01435       if ((widest != NULL)
01436     && (ffeinfo_basictype (ffebld_info (item))
01437         != ffeinfo_basictype (ffebld_info (widest))))
01438   continue;
01439       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
01440          ffeinfo_kindtype (ffebld_info (item)));
01441       if ((widest == FFEINFO_kindtypeNONE)
01442     || (ffetype_size (type)
01443         > ffetype_size (widest_type)))
01444   {
01445     widest = item;
01446     widest_type = type;
01447   }
01448     }
01449 
01450   assert (widest != NULL);
01451   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
01452     [ffeinfo_kindtype (ffebld_info (widest))];
01453   assert (t != NULL_TREE);
01454   return t;
01455 }
01456 
01457 /* Check whether a partial overlap between two expressions is possible.
01458 
01459    Can *starting* to write a portion of expr1 change the value
01460    computed (perhaps already, *partially*) by expr2?
01461 
01462    Currently, this is a concern only for a COMPLEX expr1.  But if it
01463    isn't in COMMON or local EQUIVALENCE, since we don't support
01464    aliasing of arguments, it isn't a concern.  */
01465 
01466 static bool
01467 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
01468 {
01469   ffesymbol sym;
01470   ffestorag st;
01471 
01472   switch (ffebld_op (expr1))
01473     {
01474     case FFEBLD_opSYMTER:
01475       sym = ffebld_symter (expr1);
01476       break;
01477 
01478     case FFEBLD_opARRAYREF:
01479       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
01480   return FALSE;
01481       sym = ffebld_symter (ffebld_left (expr1));
01482       break;
01483 
01484     default:
01485       return FALSE;
01486     }
01487 
01488   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
01489       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
01490     || ! (st = ffesymbol_storage (sym))
01491     || ! ffestorag_parent (st)))
01492     return FALSE;
01493 
01494   /* It's in COMMON or local EQUIVALENCE.  */
01495 
01496   return TRUE;
01497 }
01498 
01499 /* Check whether dest and source might overlap.  ffebld versions of these
01500    might or might not be passed, will be NULL if not.
01501 
01502    The test is really whether source_tree is modifiable and, if modified,
01503    might overlap destination such that the value(s) in the destination might
01504    change before it is finally modified.  dest_* are the canonized
01505    destination itself.  */
01506 
01507 static bool
01508 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
01509      tree source_tree, ffebld source UNUSED,
01510      bool scalar_arg)
01511 {
01512   tree source_decl;
01513   tree source_offset;
01514   tree source_size;
01515   tree t;
01516 
01517   if (source_tree == NULL_TREE)
01518     return FALSE;
01519 
01520   switch (TREE_CODE (source_tree))
01521     {
01522     case ERROR_MARK:
01523     case IDENTIFIER_NODE:
01524     case INTEGER_CST:
01525     case REAL_CST:
01526     case COMPLEX_CST:
01527     case STRING_CST:
01528     case CONST_DECL:
01529     case VAR_DECL:
01530     case RESULT_DECL:
01531     case FIELD_DECL:
01532     case MINUS_EXPR:
01533     case MULT_EXPR:
01534     case TRUNC_DIV_EXPR:
01535     case CEIL_DIV_EXPR:
01536     case FLOOR_DIV_EXPR:
01537     case ROUND_DIV_EXPR:
01538     case TRUNC_MOD_EXPR:
01539     case CEIL_MOD_EXPR:
01540     case FLOOR_MOD_EXPR:
01541     case ROUND_MOD_EXPR:
01542     case RDIV_EXPR:
01543     case EXACT_DIV_EXPR:
01544     case FIX_TRUNC_EXPR:
01545     case FIX_CEIL_EXPR:
01546     case FIX_FLOOR_EXPR:
01547     case FIX_ROUND_EXPR:
01548     case FLOAT_EXPR:
01549     case NEGATE_EXPR:
01550     case MIN_EXPR:
01551     case MAX_EXPR:
01552     case ABS_EXPR:
01553     case FFS_EXPR:
01554     case LSHIFT_EXPR:
01555     case RSHIFT_EXPR:
01556     case LROTATE_EXPR:
01557     case RROTATE_EXPR:
01558     case BIT_IOR_EXPR:
01559     case BIT_XOR_EXPR:
01560     case BIT_AND_EXPR:
01561     case BIT_ANDTC_EXPR:
01562     case BIT_NOT_EXPR:
01563     case TRUTH_ANDIF_EXPR:
01564     case TRUTH_ORIF_EXPR:
01565     case TRUTH_AND_EXPR:
01566     case TRUTH_OR_EXPR:
01567     case TRUTH_XOR_EXPR:
01568     case TRUTH_NOT_EXPR:
01569     case LT_EXPR:
01570     case LE_EXPR:
01571     case GT_EXPR:
01572     case GE_EXPR:
01573     case EQ_EXPR:
01574     case NE_EXPR:
01575     case COMPLEX_EXPR:
01576     case CONJ_EXPR:
01577     case REALPART_EXPR:
01578     case IMAGPART_EXPR:
01579     case LABEL_EXPR:
01580     case COMPONENT_REF:
01581       return FALSE;
01582 
01583     case COMPOUND_EXPR:
01584       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
01585             TREE_OPERAND (source_tree, 1), NULL,
01586             scalar_arg);
01587 
01588     case MODIFY_EXPR:
01589       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
01590             TREE_OPERAND (source_tree, 0), NULL,
01591             scalar_arg);
01592 
01593     case CONVERT_EXPR:
01594     case NOP_EXPR:
01595     case NON_LVALUE_EXPR:
01596     case PLUS_EXPR:
01597       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
01598   return TRUE;
01599 
01600       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
01601          source_tree);
01602       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
01603       break;
01604 
01605     case COND_EXPR:
01606       return
01607   ffecom_overlap_ (dest_decl, dest_offset, dest_size,
01608        TREE_OPERAND (source_tree, 1), NULL,
01609        scalar_arg)
01610     || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
01611             TREE_OPERAND (source_tree, 2), NULL,
01612             scalar_arg);
01613 
01614 
01615     case ADDR_EXPR:
01616       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
01617          &source_size,
01618          TREE_OPERAND (source_tree, 0));
01619       break;
01620 
01621     case PARM_DECL:
01622       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
01623   return TRUE;
01624 
01625       source_decl = source_tree;
01626       source_offset = bitsize_zero_node;
01627       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
01628       break;
01629 
01630     case SAVE_EXPR:
01631     case REFERENCE_EXPR:
01632     case PREDECREMENT_EXPR:
01633     case PREINCREMENT_EXPR:
01634     case POSTDECREMENT_EXPR:
01635     case POSTINCREMENT_EXPR:
01636     case INDIRECT_REF:
01637     case ARRAY_REF:
01638     case CALL_EXPR:
01639     default:
01640       return TRUE;
01641     }
01642 
01643   /* Come here when source_decl, source_offset, and source_size filled
01644      in appropriately.  */
01645 
01646   if (source_decl == NULL_TREE)
01647     return FALSE;   /* No decl involved, so no overlap. */
01648 
01649   if (source_decl != dest_decl)
01650     return FALSE;   /* Different decl, no overlap. */
01651 
01652   if (TREE_CODE (dest_size) == ERROR_MARK)
01653     return TRUE;    /* Assignment into entire assumed-size
01654            array?  Shouldn't happen.... */
01655 
01656   t = ffecom_2 (LE_EXPR, integer_type_node,
01657     ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
01658         dest_offset,
01659         convert (TREE_TYPE (dest_offset),
01660            dest_size)),
01661     convert (TREE_TYPE (dest_offset),
01662        source_offset));
01663 
01664   if (integer_onep (t))
01665     return FALSE;   /* Destination precedes source. */
01666 
01667   if (!scalar_arg
01668       || (source_size == NULL_TREE)
01669       || (TREE_CODE (source_size) == ERROR_MARK)
01670       || integer_zerop (source_size))
01671     return TRUE;    /* No way to tell if dest follows source. */
01672 
01673   t = ffecom_2 (LE_EXPR, integer_type_node,
01674     ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
01675         source_offset,
01676         convert (TREE_TYPE (source_offset),
01677            source_size)),
01678     convert (TREE_TYPE (source_offset),
01679        dest_offset));
01680 
01681   if (integer_onep (t))
01682     return FALSE;   /* Destination follows source. */
01683 
01684   return TRUE;    /* Destination and source overlap. */
01685 }
01686 
01687 /* Check whether dest might overlap any of a list of arguments or is
01688    in a COMMON area the callee might know about (and thus modify).  */
01689 
01690 static bool
01691 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
01692         tree args, tree callee_commons,
01693         bool scalar_args)
01694 {
01695   tree arg;
01696   tree dest_decl;
01697   tree dest_offset;
01698   tree dest_size;
01699 
01700   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
01701            dest_tree);
01702 
01703   if (dest_decl == NULL_TREE)
01704     return FALSE;   /* Seems unlikely! */
01705 
01706   /* If the decl cannot be determined reliably, or if its in COMMON
01707      and the callee isn't known to not futz with COMMON via other
01708      means, overlap might happen.  */
01709 
01710   if ((TREE_CODE (dest_decl) == ERROR_MARK)
01711       || ((callee_commons != NULL_TREE)
01712     && TREE_PUBLIC (dest_decl)))
01713     return TRUE;
01714 
01715   for (; args != NULL_TREE; args = TREE_CHAIN (args))
01716     {
01717       if (((arg = TREE_VALUE (args)) != NULL_TREE)
01718     && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
01719             arg, NULL, scalar_args))
01720   return TRUE;
01721     }
01722 
01723   return FALSE;
01724 }
01725 
01726 /* Build a string for a variable name as used by NAMELIST.  This means that
01727    if we're using the f2c library, we build an uppercase string, since
01728    f2c does this.  */
01729 
01730 static tree
01731 ffecom_build_f2c_string_ (int i, const char *s)
01732 {
01733   if (!ffe_is_f2c_library ())
01734     return build_string (i, s);
01735 
01736   {
01737     char *tmp;
01738     const char *p;
01739     char *q;
01740     char space[34];
01741     tree t;
01742 
01743     if (((size_t) i) > ARRAY_SIZE (space))
01744       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
01745     else
01746       tmp = &space[0];
01747 
01748     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
01749       *q = TOUPPER (*p);
01750     *q = '\0';
01751 
01752     t = build_string (i, tmp);
01753 
01754     if (((size_t) i) > ARRAY_SIZE (space))
01755       malloc_kill_ks (malloc_pool_image (), tmp, i);
01756 
01757     return t;
01758   }
01759 }
01760 
01761 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
01762    type to just get whatever the function returns), handling the
01763    f2c value-returning convention, if required, by prepending
01764    to the arglist a pointer to a temporary to receive the return value.  */
01765 
01766 static tree
01767 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
01768         tree type, tree args, tree dest_tree,
01769         ffebld dest, bool *dest_used, tree callee_commons,
01770         bool scalar_args, tree hook)
01771 {
01772   tree item;
01773   tree tempvar;
01774 
01775   if (dest_used != NULL)
01776     *dest_used = FALSE;
01777 
01778   if (is_f2c_complex)
01779     {
01780       if ((dest_used == NULL)
01781     || (dest == NULL)
01782     || (ffeinfo_basictype (ffebld_info (dest))
01783         != FFEINFO_basictypeCOMPLEX)
01784     || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
01785     || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
01786     || ffecom_args_overlapping_ (dest_tree, dest, args,
01787                callee_commons,
01788                scalar_args))
01789   {
01790 #ifdef HOHO
01791     tempvar = ffecom_make_tempvar (ffecom_tree_type
01792            [FFEINFO_basictypeCOMPLEX][kt],
01793            FFETARGET_charactersizeNONE,
01794            -1);
01795 #else
01796     tempvar = hook;
01797     assert (tempvar);
01798 #endif
01799   }
01800       else
01801   {
01802     *dest_used = TRUE;
01803     tempvar = dest_tree;
01804     type = NULL_TREE;
01805   }
01806 
01807       item
01808   = build_tree_list (NULL_TREE,
01809          ffecom_1 (ADDR_EXPR,
01810              build_pointer_type (TREE_TYPE (tempvar)),
01811              tempvar));
01812       TREE_CHAIN (item) = args;
01813 
01814       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
01815       item, NULL_TREE);
01816 
01817       if (tempvar != dest_tree)
01818   item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
01819     }
01820   else
01821     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
01822           args, NULL_TREE);
01823 
01824   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
01825     item = ffecom_convert_narrow_ (type, item);
01826 
01827   return item;
01828 }
01829 
01830 /* Given two arguments, transform them and make a call to the given
01831    function via ffecom_call_.  */
01832 
01833 static tree
01834 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
01835         tree type, ffebld left, ffebld right,
01836         tree dest_tree, ffebld dest, bool *dest_used,
01837         tree callee_commons, bool scalar_args, bool ref, tree hook)
01838 {
01839   tree left_tree;
01840   tree right_tree;
01841   tree left_length;
01842   tree right_length;
01843 
01844   if (ref)
01845     {
01846       /* Pass arguments by reference.  */
01847       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
01848       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
01849     }
01850   else
01851     {
01852       /* Pass arguments by value.  */
01853       left_tree = ffecom_arg_expr (left, &left_length);
01854       right_tree = ffecom_arg_expr (right, &right_length);
01855     }
01856 
01857 
01858   left_tree = build_tree_list (NULL_TREE, left_tree);
01859   right_tree = build_tree_list (NULL_TREE, right_tree);
01860   TREE_CHAIN (left_tree) = right_tree;
01861 
01862   if (left_length != NULL_TREE)
01863     {
01864       left_length = build_tree_list (NULL_TREE, left_length);
01865       TREE_CHAIN (right_tree) = left_length;
01866     }
01867 
01868   if (right_length != NULL_TREE)
01869     {
01870       right_length = build_tree_list (NULL_TREE, right_length);
01871       if (left_length != NULL_TREE)
01872   TREE_CHAIN (left_length) = right_length;
01873       else
01874   TREE_CHAIN (right_tree) = right_length;
01875     }
01876 
01877   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
01878            dest_tree, dest, dest_used, callee_commons,
01879            scalar_args, hook);
01880 }
01881 
01882 /* Return ptr/length args for char subexpression
01883 
01884    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
01885    subexpressions by constructing the appropriate trees for the ptr-to-
01886    character-text and length-of-character-text arguments in a calling
01887    sequence.
01888 
01889    Note that if with_null is TRUE, and the expression is an opCONTER,
01890    a null byte is appended to the string.  */
01891 
01892 static void
01893 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
01894 {
01895   tree item;
01896   tree high;
01897   ffetargetCharacter1 val;
01898   ffetargetCharacterSize newlen;
01899 
01900   switch (ffebld_op (expr))
01901     {
01902     case FFEBLD_opCONTER:
01903       val = ffebld_constant_character1 (ffebld_conter (expr));
01904       newlen = ffetarget_length_character1 (val);
01905       if (with_null)
01906   {
01907     /* Begin FFETARGET-NULL-KLUDGE.  */
01908     if (newlen != 0)
01909       ++newlen;
01910   }
01911       *length = build_int_2 (newlen, 0);
01912       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
01913       high = build_int_2 (newlen, 0);
01914       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
01915       item = build_string (newlen,
01916          ffetarget_text_character1 (val));
01917       /* End FFETARGET-NULL-KLUDGE.  */
01918       TREE_TYPE (item)
01919   = build_type_variant
01920     (build_array_type
01921      (char_type_node,
01922       build_range_type
01923       (ffecom_f2c_ftnlen_type_node,
01924        ffecom_f2c_ftnlen_one_node,
01925        high)),
01926      1, 0);
01927       TREE_CONSTANT (item) = 1;
01928       TREE_STATIC (item) = 1;
01929       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
01930            item);
01931       break;
01932 
01933     case FFEBLD_opSYMTER:
01934       {
01935   ffesymbol s = ffebld_symter (expr);
01936 
01937   item = ffesymbol_hook (s).decl_tree;
01938   if (item == NULL_TREE)
01939     {
01940       s = ffecom_sym_transform_ (s);
01941       item = ffesymbol_hook (s).decl_tree;
01942     }
01943   if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
01944     {
01945       if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
01946         *length = ffesymbol_hook (s).length_tree;
01947       else
01948         {
01949     *length = build_int_2 (ffesymbol_size (s), 0);
01950     TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
01951         }
01952     }
01953   else if (item == error_mark_node)
01954     *length = error_mark_node;
01955   else
01956     /* FFEINFO_kindFUNCTION.  */
01957     *length = NULL_TREE;
01958   if (!ffesymbol_hook (s).addr
01959       && (item != error_mark_node))
01960     item = ffecom_1 (ADDR_EXPR,
01961          build_pointer_type (TREE_TYPE (item)),
01962          item);
01963       }
01964       break;
01965 
01966     case FFEBLD_opARRAYREF:
01967       {
01968   ffecom_char_args_ (&item, length, ffebld_left (expr));
01969 
01970   if (item == error_mark_node || *length == error_mark_node)
01971     {
01972       item = *length = error_mark_node;
01973       break;
01974     }
01975 
01976   item = ffecom_arrayref_ (item, expr, 1);
01977       }
01978       break;
01979 
01980     case FFEBLD_opSUBSTR:
01981       {
01982   ffebld start;
01983   ffebld end;
01984   ffebld thing = ffebld_right (expr);
01985   tree start_tree;
01986   tree end_tree;
01987   const char *char_name;
01988   ffebld left_symter;
01989   tree array;
01990 
01991   assert (ffebld_op (thing) == FFEBLD_opITEM);
01992   start = ffebld_head (thing);
01993   thing = ffebld_trail (thing);
01994   assert (ffebld_trail (thing) == NULL);
01995   end = ffebld_head (thing);
01996 
01997   /* Determine name for pretty-printing range-check errors.  */
01998   for (left_symter = ffebld_left (expr);
01999        left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
02000        left_symter = ffebld_left (left_symter))
02001     ;
02002   if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
02003     char_name = ffesymbol_text (ffebld_symter (left_symter));
02004   else
02005     char_name = "[expr?]";
02006 
02007   ffecom_char_args_ (&item, length, ffebld_left (expr));
02008 
02009   if (item == error_mark_node || *length == error_mark_node)
02010     {
02011       item = *length = error_mark_node;
02012       break;
02013     }
02014 
02015   array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
02016 
02017   /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
02018 
02019   if (start == NULL)
02020     {
02021       if (end == NULL)
02022         ;
02023       else
02024         {
02025     end_tree = ffecom_expr (end);
02026     if (flag_bounds_check)
02027       end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
02028                   char_name);
02029     end_tree = convert (ffecom_f2c_ftnlen_type_node,
02030             end_tree);
02031 
02032     if (end_tree == error_mark_node)
02033       {
02034         item = *length = error_mark_node;
02035         break;
02036       }
02037 
02038     *length = end_tree;
02039         }
02040     }
02041   else
02042     {
02043       start_tree = ffecom_expr (start);
02044       if (flag_bounds_check)
02045         start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
02046                 char_name);
02047       start_tree = convert (ffecom_f2c_ftnlen_type_node,
02048           start_tree);
02049 
02050       if (start_tree == error_mark_node)
02051         {
02052     item = *length = error_mark_node;
02053     break;
02054         }
02055 
02056       start_tree = ffecom_save_tree (start_tree);
02057 
02058       item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
02059            item,
02060            ffecom_2 (MINUS_EXPR,
02061                TREE_TYPE (start_tree),
02062                start_tree,
02063                ffecom_f2c_ftnlen_one_node));
02064 
02065       if (end == NULL)
02066         {
02067     *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
02068             ffecom_f2c_ftnlen_one_node,
02069             ffecom_2 (MINUS_EXPR,
02070                 ffecom_f2c_ftnlen_type_node,
02071                 *length,
02072                 start_tree));
02073         }
02074       else
02075         {
02076     end_tree = ffecom_expr (end);
02077     if (flag_bounds_check)
02078       end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
02079                   char_name);
02080     end_tree = convert (ffecom_f2c_ftnlen_type_node,
02081             end_tree);
02082 
02083     if (end_tree == error_mark_node)
02084       {
02085         item = *length = error_mark_node;
02086         break;
02087       }
02088 
02089     *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
02090             ffecom_f2c_ftnlen_one_node,
02091             ffecom_2 (MINUS_EXPR,
02092                 ffecom_f2c_ftnlen_type_node,
02093                 end_tree, start_tree));
02094         }
02095     }
02096       }
02097       break;
02098 
02099     case FFEBLD_opFUNCREF:
02100       {
02101   ffesymbol s = ffebld_symter (ffebld_left (expr));
02102   tree tempvar;
02103   tree args;
02104   ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
02105   ffecomGfrt ix;
02106 
02107   if (size == FFETARGET_charactersizeNONE)
02108     /* ~~Kludge alert!  This should someday be fixed. */
02109     size = 24;
02110 
02111   *length = build_int_2 (size, 0);
02112   TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
02113 
02114   if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
02115       == FFEINFO_whereINTRINSIC)
02116     {
02117       if (size == 1)
02118         {
02119     /* Invocation of an intrinsic returning CHARACTER*1.  */
02120     item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
02121                  NULL, NULL);
02122     break;
02123         }
02124       ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
02125       assert (ix != FFECOM_gfrt);
02126       item = ffecom_gfrt_tree_ (ix);
02127     }
02128   else
02129     {
02130       ix = FFECOM_gfrt;
02131       item = ffesymbol_hook (s).decl_tree;
02132       if (item == NULL_TREE)
02133         {
02134     s = ffecom_sym_transform_ (s);
02135     item = ffesymbol_hook (s).decl_tree;
02136         }
02137       if (item == error_mark_node)
02138         {
02139     item = *length = error_mark_node;
02140     break;
02141         }
02142 
02143       if (!ffesymbol_hook (s).addr)
02144         item = ffecom_1_fn (item);
02145     }
02146 
02147 #ifdef HOHO
02148   tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
02149 #else
02150   tempvar = ffebld_nonter_hook (expr);
02151   assert (tempvar);
02152 #endif
02153   tempvar = ffecom_1 (ADDR_EXPR,
02154           build_pointer_type (TREE_TYPE (tempvar)),
02155           tempvar);
02156 
02157   args = build_tree_list (NULL_TREE, tempvar);
02158 
02159   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
02160     TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
02161   else
02162     {
02163       TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
02164       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
02165         {
02166     TREE_CHAIN (TREE_CHAIN (args))
02167       = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
02168             ffebld_right (expr));
02169         }
02170       else
02171         {
02172     TREE_CHAIN (TREE_CHAIN (args))
02173       = ffecom_list_ptr_to_expr (ffebld_right (expr));
02174         }
02175     }
02176 
02177   item = ffecom_3s (CALL_EXPR,
02178         TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
02179         item, args, NULL_TREE);
02180   item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
02181        tempvar);
02182       }
02183       break;
02184 
02185     case FFEBLD_opCONVERT:
02186 
02187       ffecom_char_args_ (&item, length, ffebld_left (expr));
02188 
02189       if (item == error_mark_node || *length == error_mark_node)
02190   {
02191     item = *length = error_mark_node;
02192     break;
02193   }
02194 
02195       if ((ffebld_size_known (ffebld_left (expr))
02196      == FFETARGET_charactersizeNONE)
02197     || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
02198   {     /* Possible blank-padding needed, copy into
02199            temporary. */
02200     tree tempvar;
02201     tree args;
02202     tree newlen;
02203 
02204 #ifdef HOHO
02205     tempvar = ffecom_make_tempvar (char_type_node,
02206            ffebld_size (expr), -1);
02207 #else
02208     tempvar = ffebld_nonter_hook (expr);
02209     assert (tempvar);
02210 #endif
02211     tempvar = ffecom_1 (ADDR_EXPR,
02212             build_pointer_type (TREE_TYPE (tempvar)),
02213             tempvar);
02214 
02215     newlen = build_int_2 (ffebld_size (expr), 0);
02216     TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
02217 
02218     args = build_tree_list (NULL_TREE, tempvar);
02219     TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
02220     TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
02221     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
02222       = build_tree_list (NULL_TREE, *length);
02223 
02224     item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
02225     TREE_SIDE_EFFECTS (item) = 1;
02226     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
02227          tempvar);
02228     *length = newlen;
02229   }
02230       else
02231   {     /* Just truncate the length. */
02232     *length = build_int_2 (ffebld_size (expr), 0);
02233     TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
02234   }
02235       break;
02236 
02237     default:
02238       assert ("bad op for single char arg expr" == NULL);
02239       item = NULL_TREE;
02240       break;
02241     }
02242 
02243   *xitem = item;
02244 }
02245 
02246 /* Check the size of the type to be sure it doesn't overflow the
02247    "portable" capacities of the compiler back end.  `dummy' types
02248    can generally overflow the normal sizes as long as the computations
02249    themselves don't overflow.  A particular target of the back end
02250    must still enforce its size requirements, though, and the back
02251    end takes care of this in stor-layout.c.  */
02252 
02253 static tree
02254 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
02255 {
02256   if (TREE_CODE (type) == ERROR_MARK)
02257     return type;
02258 
02259   if (TYPE_SIZE (type) == NULL_TREE)
02260     return type;
02261 
02262   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
02263     return type;
02264 
02265   /* An array is too large if size is negative or the type_size overflows
02266      or its "upper half" is larger than 3 (which would make the signed
02267      byte size and offset computations overflow).  */
02268 
02269   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
02270       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
02271                || TREE_OVERFLOW (TYPE_SIZE (type)))))
02272     {
02273       ffebad_start (FFEBAD_ARRAY_LARGE);
02274       ffebad_string (ffesymbol_text (s));
02275       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
02276       ffebad_finish ();
02277 
02278       return error_mark_node;
02279     }
02280 
02281   return type;
02282 }
02283 
02284 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
02285    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
02286    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
02287 
02288 static tree
02289 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
02290 {
02291   ffetargetCharacterSize sz = ffesymbol_size (s);
02292   tree highval;
02293   tree tlen;
02294   tree type = *xtype;
02295 
02296   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
02297     tlen = NULL_TREE;   /* A statement function, no length passed. */
02298   else
02299     {
02300       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
02301   tlen = ffecom_get_invented_identifier ("__g77_length_%s",
02302                  ffesymbol_text (s));
02303       else
02304   tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
02305       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
02306       DECL_ARTIFICIAL (tlen) = 1;
02307     }
02308 
02309   if (sz == FFETARGET_charactersizeNONE)
02310     {
02311       assert (tlen != NULL_TREE);
02312       highval = variable_size (tlen);
02313     }
02314   else
02315     {
02316       highval = build_int_2 (sz, 0);
02317       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
02318     }
02319 
02320   type = build_array_type (type,
02321          build_range_type (ffecom_f2c_ftnlen_type_node,
02322                ffecom_f2c_ftnlen_one_node,
02323                highval));
02324 
02325   *xtype = type;
02326   return tlen;
02327 }
02328 
02329 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
02330 
02331    ffecomConcatList_ catlist;
02332    ffebld expr;  // expr of CHARACTER basictype.
02333    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
02334    catlist = ffecom_concat_list_gather_(catlist,expr,max);
02335 
02336    Scans expr for character subexpressions, updates and returns catlist
02337    accordingly.  */
02338 
02339 static ffecomConcatList_
02340 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
02341           ffetargetCharacterSize max)
02342 {
02343   ffetargetCharacterSize sz;
02344 
02345  recurse:
02346 
02347   if (expr == NULL)
02348     return catlist;
02349 
02350   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
02351     return catlist;   /* Don't append any more items. */
02352 
02353   switch (ffebld_op (expr))
02354     {
02355     case FFEBLD_opCONTER:
02356     case FFEBLD_opSYMTER:
02357     case FFEBLD_opARRAYREF:
02358     case FFEBLD_opFUNCREF:
02359     case FFEBLD_opSUBSTR:
02360     case FFEBLD_opCONVERT:  /* Callers should strip this off beforehand
02361            if they don't need to preserve it. */
02362       if (catlist.count == catlist.max)
02363   {     /* Make a (larger) list. */
02364     ffebld *newx;
02365     int newmax;
02366 
02367     newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
02368     newx = malloc_new_ks (malloc_pool_image (), "catlist",
02369         newmax * sizeof (newx[0]));
02370     if (catlist.max != 0)
02371       {
02372         memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
02373         malloc_kill_ks (malloc_pool_image (), catlist.exprs,
02374             catlist.max * sizeof (newx[0]));
02375       }
02376     catlist.max = newmax;
02377     catlist.exprs = newx;
02378   }
02379       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
02380   catlist.minlen += sz;
02381       else
02382   ++catlist.minlen; /* Not true for F90; can be 0 length. */
02383       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
02384   catlist.maxlen = sz;
02385       else
02386   catlist.maxlen += sz;
02387       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
02388   {     /* This item overlaps (or is beyond) the end
02389            of the destination. */
02390     switch (ffebld_op (expr))
02391       {
02392       case FFEBLD_opCONTER:
02393       case FFEBLD_opSYMTER:
02394       case FFEBLD_opARRAYREF:
02395       case FFEBLD_opFUNCREF:
02396       case FFEBLD_opSUBSTR:
02397         /* ~~Do useful truncations here. */
02398         break;
02399 
02400       default:
02401         assert ("op changed or inconsistent switches!" == NULL);
02402         break;
02403       }
02404   }
02405       catlist.exprs[catlist.count++] = expr;
02406       return catlist;
02407 
02408     case FFEBLD_opPAREN:
02409       expr = ffebld_left (expr);
02410       goto recurse;   /* :::::::::::::::::::: */
02411 
02412     case FFEBLD_opCONCATENATE:
02413       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
02414       expr = ffebld_right (expr);
02415       goto recurse;   /* :::::::::::::::::::: */
02416 
02417 #if 0       /* Breaks passing small actual arg to larger
02418            dummy arg of sfunc */
02419     case FFEBLD_opCONVERT:
02420       expr = ffebld_left (expr);
02421       {
02422   ffetargetCharacterSize cmax;
02423 
02424   cmax = catlist.len + ffebld_size_known (expr);
02425 
02426   if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
02427     max = cmax;
02428       }
02429       goto recurse;   /* :::::::::::::::::::: */
02430 #endif
02431 
02432     case FFEBLD_opANY:
02433       return catlist;
02434 
02435     default:
02436       assert ("bad op in _gather_" == NULL);
02437       return catlist;
02438     }
02439 }
02440 
02441 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
02442 
02443    ffecomConcatList_ catlist;
02444    ffecom_concat_list_kill_(catlist);
02445 
02446    Anything allocated within the list info is deallocated.  */
02447 
02448 static void
02449 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
02450 {
02451   if (catlist.max != 0)
02452     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
02453         catlist.max * sizeof (catlist.exprs[0]));
02454 }
02455 
02456 /* Make list of concatenated string exprs.
02457 
02458    Returns a flattened list of concatenated subexpressions given a
02459    tree of such expressions.  */
02460 
02461 static ffecomConcatList_
02462 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
02463 {
02464   ffecomConcatList_ catlist;
02465 
02466   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
02467   return ffecom_concat_list_gather_ (catlist, expr, max);
02468 }
02469 
02470 /* Provide some kind of useful info on member of aggregate area,
02471    since current g77/gcc technology does not provide debug info
02472    on these members.  */
02473 
02474 static void
02475 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
02476           tree member_type UNUSED, ffetargetOffset offset)
02477 {
02478   tree value;
02479   tree decl;
02480   int len;
02481   char *buff;
02482   char space[120];
02483 #if 0
02484   tree type_id;
02485 
02486   for (type_id = member_type;
02487        TREE_CODE (type_id) != IDENTIFIER_NODE;
02488        )
02489     {
02490       switch (TREE_CODE (type_id))
02491   {
02492   case INTEGER_TYPE:
02493   case REAL_TYPE:
02494     type_id = TYPE_NAME (type_id);
02495     break;
02496 
02497   case ARRAY_TYPE:
02498   case COMPLEX_TYPE:
02499     type_id = TREE_TYPE (type_id);
02500     break;
02501 
02502   default:
02503     assert ("no IDENTIFIER_NODE for type!" == NULL);
02504     type_id = error_mark_node;
02505     break;
02506   }
02507     }
02508 #endif
02509 
02510   if (ffecom_transform_only_dummies_
02511       || !ffe_is_debug_kludge ())
02512     return; /* Can't do this yet, maybe later. */
02513 
02514   len = 60
02515     + strlen (aggr_type)
02516     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
02517 #if 0
02518     + IDENTIFIER_LENGTH (type_id);
02519 #endif
02520 
02521   if (((size_t) len) >= ARRAY_SIZE (space))
02522     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
02523   else
02524     buff = &space[0];
02525 
02526   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
02527      aggr_type,
02528      IDENTIFIER_POINTER (DECL_NAME (aggr)),
02529      (long int) offset);
02530 
02531   value = build_string (len, buff);
02532   TREE_TYPE (value)
02533     = build_type_variant (build_array_type (char_type_node,
02534               build_range_type
02535               (integer_type_node,
02536                integer_one_node,
02537                build_int_2 (strlen (buff), 0))),
02538         1, 0);
02539   decl = build_decl (VAR_DECL,
02540          ffecom_get_identifier_ (ffesymbol_text (member)),
02541          TREE_TYPE (value));
02542   TREE_CONSTANT (decl) = 1;
02543   TREE_STATIC (decl) = 1;
02544   DECL_INITIAL (decl) = error_mark_node;
02545   DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
02546   decl = start_decl (decl, FALSE);
02547   finish_decl (decl, value, FALSE);
02548 
02549   if (buff != &space[0])
02550     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
02551 }
02552 
02553 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
02554 
02555    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
02556    int i;  // entry# for this entrypoint (used by master fn)
02557    ffecom_do_entrypoint_(s,i);
02558 
02559    Makes a public entry point that calls our private master fn (already
02560    compiled).  */
02561 
02562 static void
02563 ffecom_do_entry_ (ffesymbol fn, int entrynum)
02564 {
02565   ffebld item;
02566   tree type;      /* Type of function. */
02567   tree multi_retval;    /* Var holding return value (union). */
02568   tree result;      /* Var holding result. */
02569   ffeinfoBasictype bt;
02570   ffeinfoKindtype kt;
02571   ffeglobal g;
02572   ffeglobalType gt;
02573   bool charfunc;    /* All entry points return same type
02574            CHARACTER. */
02575   bool cmplxfunc;   /* Use f2c way of returning COMPLEX. */
02576   bool multi;     /* Master fn has multiple return types. */
02577   bool altreturning = FALSE;  /* This entry point has alternate returns. */
02578   int old_lineno = lineno;
02579   const char *old_input_filename = input_filename;
02580 
02581   input_filename = ffesymbol_where_filename (fn);
02582   lineno = ffesymbol_where_filelinenum (fn);
02583 
02584   ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
02585 
02586   switch (ffecom_primary_entry_kind_)
02587     {
02588     case FFEINFO_kindFUNCTION:
02589 
02590       /* Determine actual return type for function. */
02591 
02592       gt = FFEGLOBAL_typeFUNC;
02593       bt = ffesymbol_basictype (fn);
02594       kt = ffesymbol_kindtype (fn);
02595       if (bt == FFEINFO_basictypeNONE)
02596   {
02597     ffeimplic_establish_symbol (fn);
02598     if (ffesymbol_funcresult (fn) != NULL)
02599       ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
02600     bt = ffesymbol_basictype (fn);
02601     kt = ffesymbol_kindtype (fn);
02602   }
02603 
02604       if (bt == FFEINFO_basictypeCHARACTER)
02605   charfunc = TRUE, cmplxfunc = FALSE;
02606       else if ((bt == FFEINFO_basictypeCOMPLEX)
02607          && ffesymbol_is_f2c (fn))
02608   charfunc = FALSE, cmplxfunc = TRUE;
02609       else
02610   charfunc = cmplxfunc = FALSE;
02611 
02612       if (charfunc)
02613   type = ffecom_tree_fun_type_void;
02614       else if (ffesymbol_is_f2c (fn))
02615   type = ffecom_tree_fun_type[bt][kt];
02616       else
02617   type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
02618 
02619       if ((type == NULL_TREE)
02620     || (TREE_TYPE (type) == NULL_TREE))
02621   type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
02622 
02623       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
02624       break;
02625 
02626     case FFEINFO_kindSUBROUTINE:
02627       gt = FFEGLOBAL_typeSUBR;
02628       bt = FFEINFO_basictypeNONE;
02629       kt = FFEINFO_kindtypeNONE;
02630       if (ffecom_is_altreturning_)
02631   {     /* Am _I_ altreturning? */
02632     for (item = ffesymbol_dummyargs (fn);
02633          item != NULL;
02634          item = ffebld_trail (item))
02635       {
02636         if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
02637     {
02638       altreturning = TRUE;
02639       break;
02640     }
02641       }
02642     if (altreturning)
02643       type = ffecom_tree_subr_type;
02644     else
02645       type = ffecom_tree_fun_type_void;
02646   }
02647       else
02648   type = ffecom_tree_fun_type_void;
02649       charfunc = FALSE;
02650       cmplxfunc = FALSE;
02651       multi = FALSE;
02652       break;
02653 
02654     default:
02655       assert ("say what??" == NULL);
02656       /* Fall through. */
02657     case FFEINFO_kindANY:
02658       gt = FFEGLOBAL_typeANY;
02659       bt = FFEINFO_basictypeNONE;
02660       kt = FFEINFO_kindtypeNONE;
02661       type = error_mark_node;
02662       charfunc = FALSE;
02663       cmplxfunc = FALSE;
02664       multi = FALSE;
02665       break;
02666     }
02667 
02668   /* build_decl uses the current lineno and input_filename to set the decl
02669      source info.  So, I've putzed with ffestd and ffeste code to update that
02670      source info to point to the appropriate statement just before calling
02671      ffecom_do_entrypoint (which calls this fn).  */
02672 
02673   start_function (ffecom_get_external_identifier_ (fn),
02674       type,
02675       0,    /* nested/inline */
02676       1);   /* TREE_PUBLIC */
02677 
02678   if (((g = ffesymbol_global (fn)) != NULL)
02679       && ((ffeglobal_type (g) == gt)
02680     || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
02681     {
02682       ffeglobal_set_hook (g, current_function_decl);
02683     }
02684 
02685   /* Reset args in master arg list so they get retransitioned. */
02686 
02687   for (item = ffecom_master_arglist_;
02688        item != NULL;
02689        item = ffebld_trail (item))
02690     {
02691       ffebld arg;
02692       ffesymbol s;
02693 
02694       arg = ffebld_head (item);
02695       if (ffebld_op (arg) != FFEBLD_opSYMTER)
02696   continue;   /* Alternate return or some such thing. */
02697       s = ffebld_symter (arg);
02698       ffesymbol_hook (s).decl_tree = NULL_TREE;
02699       ffesymbol_hook (s).length_tree = NULL_TREE;
02700     }
02701 
02702   /* Build dummy arg list for this entry point. */
02703 
02704   if (charfunc || cmplxfunc)
02705     {       /* Prepend arg for where result goes. */
02706       tree type;
02707       tree length;
02708 
02709       if (charfunc)
02710   type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
02711       else
02712   type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
02713 
02714       result = ffecom_get_invented_identifier ("__g77_%s", "result");
02715 
02716       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
02717 
02718       if (charfunc)
02719   length = ffecom_char_enhance_arg_ (&type, fn);
02720       else
02721   length = NULL_TREE; /* Not ref'd if !charfunc. */
02722 
02723       type = build_pointer_type (type);
02724       result = build_decl (PARM_DECL, result, type);
02725 
02726       push_parm_decl (result);
02727       ffecom_func_result_ = result;
02728 
02729       if (charfunc)
02730   {
02731     push_parm_decl (length);
02732     ffecom_func_length_ = length;
02733   }
02734     }
02735   else
02736     result = DECL_RESULT (current_function_decl);
02737 
02738   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
02739 
02740   store_parm_decls (0);
02741 
02742   ffecom_start_compstmt ();
02743   /* Disallow temp vars at this level.  */
02744   current_binding_level->prep_state = 2;
02745 
02746   /* Make local var to hold return type for multi-type master fn. */
02747 
02748   if (multi)
02749     {
02750       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
02751                  "multi_retval");
02752       multi_retval = build_decl (VAR_DECL, multi_retval,
02753          ffecom_multi_type_node_);
02754       multi_retval = start_decl (multi_retval, FALSE);
02755       finish_decl (multi_retval, NULL_TREE, FALSE);
02756     }
02757   else
02758     multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
02759 
02760   /* Here we emit the actual code for the entry point. */
02761 
02762   {
02763     ffebld list;
02764     ffebld arg;
02765     ffesymbol s;
02766     tree arglist = NULL_TREE;
02767     tree *plist = &arglist;
02768     tree prepend;
02769     tree call;
02770     tree actarg;
02771     tree master_fn;
02772 
02773     /* Prepare actual arg list based on master arg list. */
02774 
02775     for (list = ffecom_master_arglist_;
02776    list != NULL;
02777    list = ffebld_trail (list))
02778       {
02779   arg = ffebld_head (list);
02780   if (ffebld_op (arg) != FFEBLD_opSYMTER)
02781     continue;
02782   s = ffebld_symter (arg);
02783   if (ffesymbol_hook (s).decl_tree == NULL_TREE
02784       || ffesymbol_hook (s).decl_tree == error_mark_node)
02785     actarg = null_pointer_node; /* We don't have this arg. */
02786   else
02787     actarg = ffesymbol_hook (s).decl_tree;
02788   *plist = build_tree_list (NULL_TREE, actarg);
02789   plist = &TREE_CHAIN (*plist);
02790       }
02791 
02792     /* This code appends the length arguments for character
02793        variables/arrays.  */
02794 
02795     for (list = ffecom_master_arglist_;
02796    list != NULL;
02797    list = ffebld_trail (list))
02798       {
02799   arg = ffebld_head (list);
02800   if (ffebld_op (arg) != FFEBLD_opSYMTER)
02801     continue;
02802   s = ffebld_symter (arg);
02803   if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
02804     continue;   /* Only looking for CHARACTER arguments. */
02805   if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
02806     continue;   /* Only looking for variables and arrays. */
02807   if (ffesymbol_hook (s).length_tree == NULL_TREE
02808       || ffesymbol_hook (s).length_tree == error_mark_node)
02809     actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
02810   else
02811     actarg = ffesymbol_hook (s).length_tree;
02812   *plist = build_tree_list (NULL_TREE, actarg);
02813   plist = &TREE_CHAIN (*plist);
02814       }
02815 
02816     /* Prepend character-value return info to actual arg list. */
02817 
02818     if (charfunc)
02819       {
02820   prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
02821   TREE_CHAIN (prepend)
02822     = build_tree_list (NULL_TREE, ffecom_func_length_);
02823   TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
02824   arglist = prepend;
02825       }
02826 
02827     /* Prepend multi-type return value to actual arg list. */
02828 
02829     if (multi)
02830       {
02831   prepend
02832     = build_tree_list (NULL_TREE,
02833            ffecom_1 (ADDR_EXPR,
02834             build_pointer_type (TREE_TYPE (multi_retval)),
02835                multi_retval));
02836   TREE_CHAIN (prepend) = arglist;
02837   arglist = prepend;
02838       }
02839 
02840     /* Prepend my entry-point number to the actual arg list. */
02841 
02842     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
02843     TREE_CHAIN (prepend) = arglist;
02844     arglist = prepend;
02845 
02846     /* Build the call to the master function. */
02847 
02848     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
02849     call = ffecom_3s (CALL_EXPR,
02850           TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
02851           master_fn, arglist, NULL_TREE);
02852 
02853     /* Decide whether the master function is a function or subroutine, and
02854        handle the return value for my entry point. */
02855 
02856     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
02857          && !altreturning))
02858       {
02859   expand_expr_stmt (call);
02860   expand_null_return ();
02861       }
02862     else if (multi && cmplxfunc)
02863       {
02864   expand_expr_stmt (call);
02865   result
02866     = ffecom_1 (INDIRECT_REF,
02867           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
02868           result);
02869   result = ffecom_modify (NULL_TREE, result,
02870         ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
02871             multi_retval,
02872             ffecom_multi_fields_[bt][kt]));
02873   expand_expr_stmt (result);
02874   expand_null_return ();
02875       }
02876     else if (multi)
02877       {
02878   expand_expr_stmt (call);
02879   result
02880     = ffecom_modify (NULL_TREE, result,
02881          convert (TREE_TYPE (result),
02882             ffecom_2 (COMPONENT_REF,
02883                 ffecom_tree_type[bt][kt],
02884                 multi_retval,
02885                 ffecom_multi_fields_[bt][kt])));
02886   expand_return (result);
02887       }
02888     else if (cmplxfunc)
02889       {
02890   result
02891     = ffecom_1 (INDIRECT_REF,
02892           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
02893           result);
02894   result = ffecom_modify (NULL_TREE, result, call);
02895   expand_expr_stmt (result);
02896   expand_null_return ();
02897       }
02898     else
02899       {
02900   result = ffecom_modify (NULL_TREE,
02901         result,
02902         convert (TREE_TYPE (result),
02903            call));
02904   expand_return (result);
02905       }
02906   }
02907 
02908   ffecom_end_compstmt ();
02909 
02910   finish_function (0);
02911 
02912   lineno = old_lineno;
02913   input_filename = old_input_filename;
02914 
02915   ffecom_doing_entry_ = FALSE;
02916 }
02917 
02918 /* Transform expr into gcc tree with possible destination
02919 
02920    Recursive descent on expr while making corresponding tree nodes and
02921    attaching type info and such.  If destination supplied and compatible
02922    with temporary that would be made in certain cases, temporary isn't
02923    made, destination used instead, and dest_used flag set TRUE.  */
02924 
02925 static tree
02926 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
02927         bool *dest_used, bool assignp, bool widenp)
02928 {
02929   tree item;
02930   tree list;
02931   tree args;
02932   ffeinfoBasictype bt;
02933   ffeinfoKindtype kt;
02934   tree t;
02935   tree dt;      /* decl_tree for an ffesymbol. */
02936   tree tree_type, tree_type_x;
02937   tree left, right;
02938   ffesymbol s;
02939   enum tree_code code;
02940 
02941   assert (expr != NULL);
02942 
02943   if (dest_used != NULL)
02944     *dest_used = FALSE;
02945 
02946   bt = ffeinfo_basictype (ffebld_info (expr));
02947   kt = ffeinfo_kindtype (ffebld_info (expr));
02948   tree_type = ffecom_tree_type[bt][kt];
02949 
02950   /* Widen integral arithmetic as desired while preserving signedness.  */
02951   tree_type_x = NULL_TREE;
02952   if (widenp && tree_type
02953       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
02954       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
02955     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
02956 
02957   switch (ffebld_op (expr))
02958     {
02959     case FFEBLD_opACCTER:
02960       {
02961   ffebitCount i;
02962   ffebit bits = ffebld_accter_bits (expr);
02963   ffetargetOffset source_offset = 0;
02964   ffetargetOffset dest_offset = ffebld_accter_pad (expr);
02965   tree purpose;
02966 
02967   assert (dest_offset == 0
02968     || (bt == FFEINFO_basictypeCHARACTER
02969         && kt == FFEINFO_kindtypeCHARACTER1));
02970 
02971   list = item = NULL;
02972   for (;;)
02973     {
02974       ffebldConstantUnion cu;
02975       ffebitCount length;
02976       bool value;
02977       ffebldConstantArray ca = ffebld_accter (expr);
02978 
02979       ffebit_test (bits, source_offset, &value, &length);
02980       if (length == 0)
02981         break;
02982 
02983       if (value)
02984         {
02985     for (i = 0; i < length; ++i)
02986       {
02987         cu = ffebld_constantarray_get (ca, bt, kt,
02988                source_offset + i);
02989 
02990         t = ffecom_constantunion (&cu, bt, kt, tree_type);
02991 
02992         if (i == 0
02993       && dest_offset != 0)
02994           purpose = build_int_2 (dest_offset, 0);
02995         else
02996           purpose = NULL_TREE;
02997 
02998         if (list == NULL_TREE)
02999           list = item = build_tree_list (purpose, t);
03000         else
03001           {
03002       TREE_CHAIN (item) = build_tree_list (purpose, t);
03003       item = TREE_CHAIN (item);
03004           }
03005       }
03006         }
03007       source_offset += length;
03008       dest_offset += length;
03009     }
03010       }
03011 
03012       item = build_int_2 ((ffebld_accter_size (expr)
03013          + ffebld_accter_pad (expr)) - 1, 0);
03014       ffebit_kill (ffebld_accter_bits (expr));
03015       TREE_TYPE (item) = ffecom_integer_type_node;
03016       item
03017   = build_array_type
03018     (tree_type,
03019      build_range_type (ffecom_integer_type_node,
03020            ffecom_integer_zero_node,
03021            item));
03022       list = build (CONSTRUCTOR, item, NULL_TREE, list);
03023       TREE_CONSTANT (list) = 1;
03024       TREE_STATIC (list) = 1;
03025       return list;
03026 
03027     case FFEBLD_opARRTER:
03028       {
03029   ffetargetOffset i;
03030 
03031   list = NULL_TREE;
03032   if (ffebld_arrter_pad (expr) == 0)
03033     item = NULL_TREE;
03034   else
03035     {
03036       assert (bt == FFEINFO_basictypeCHARACTER
03037         && kt == FFEINFO_kindtypeCHARACTER1);
03038 
03039       /* Becomes PURPOSE first time through loop.  */
03040       item = build_int_2 (ffebld_arrter_pad (expr), 0);
03041     }
03042 
03043   for (i = 0; i < ffebld_arrter_size (expr); ++i)
03044     {
03045       ffebldConstantUnion cu
03046       = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
03047 
03048       t = ffecom_constantunion (&cu, bt, kt, tree_type);
03049 
03050       if (list == NULL_TREE)
03051         /* Assume item is PURPOSE first time through loop.  */
03052         list = item = build_tree_list (item, t);
03053       else
03054         {
03055     TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
03056     item = TREE_CHAIN (item);
03057         }
03058     }
03059       }
03060 
03061       item = build_int_2 ((ffebld_arrter_size (expr)
03062         + ffebld_arrter_pad (expr)) - 1, 0);
03063       TREE_TYPE (item) = ffecom_integer_type_node;
03064       item
03065   = build_array_type
03066     (tree_type,
03067      build_range_type (ffecom_integer_type_node,
03068            ffecom_integer_zero_node,
03069            item));
03070       list = build (CONSTRUCTOR, item, NULL_TREE, list);
03071       TREE_CONSTANT (list) = 1;
03072       TREE_STATIC (list) = 1;
03073       return list;
03074 
03075     case FFEBLD_opCONTER:
03076       assert (ffebld_conter_pad (expr) == 0);
03077       item
03078   = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
03079         bt, kt, tree_type);
03080       return item;
03081 
03082     case FFEBLD_opSYMTER:
03083       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
03084     || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
03085   return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
03086       s = ffebld_symter (expr);
03087       t = ffesymbol_hook (s).decl_tree;
03088 
03089       if (assignp)
03090   {     /* ASSIGN'ed-label expr. */
03091     if (ffe_is_ugly_assign ())
03092       {
03093         /* User explicitly wants ASSIGN'ed variables to be at the same
03094      memory address as the variables when used in non-ASSIGN
03095      contexts.  That can make old, arcane, non-standard code
03096      work, but don't try to do it when a pointer wouldn't fit
03097      in the normal variable (take other approach, and warn,
03098      instead).  */
03099 
03100         if (t == NULL_TREE)
03101     {
03102       s = ffecom_sym_transform_ (s);
03103       t = ffesymbol_hook (s).decl_tree;
03104       assert (t != NULL_TREE);
03105     }
03106 
03107         if (t == error_mark_node)
03108     return t;
03109 
03110         if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
03111       >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
03112     {
03113       if (ffesymbol_hook (s).addr)
03114         t = ffecom_1 (INDIRECT_REF,
03115           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
03116       return t;
03117     }
03118 
03119         if (ffesymbol_hook (s).assign_tree == NULL_TREE)
03120     {
03121       /* xgettext:no-c-format */
03122       ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
03123             FFEBAD_severityWARNING);
03124       ffebad_string (ffesymbol_text (s));
03125       ffebad_here (0, ffesymbol_where_line (s),
03126              ffesymbol_where_column (s));
03127       ffebad_finish ();
03128     }
03129       }
03130 
03131     /* Don't use the normal variable's tree for ASSIGN, though mark
03132        it as in the system header (housekeeping).  Use an explicit,
03133        specially created sibling that is known to be wide enough
03134        to hold pointers to labels.  */
03135 
03136     if (t != NULL_TREE
03137         && TREE_CODE (t) == VAR_DECL)
03138       DECL_IN_SYSTEM_HEADER (t) = 1;  /* Don't let -Wunused complain. */
03139 
03140     t = ffesymbol_hook (s).assign_tree;
03141     if (t == NULL_TREE)
03142       {
03143         s = ffecom_sym_transform_assign_ (s);
03144         t = ffesymbol_hook (s).assign_tree;
03145         assert (t != NULL_TREE);
03146       }
03147   }
03148       else
03149   {
03150     if (t == NULL_TREE)
03151       {
03152         s = ffecom_sym_transform_ (s);
03153         t = ffesymbol_hook (s).decl_tree;
03154         assert (t != NULL_TREE);
03155       }
03156     if (ffesymbol_hook (s).addr)
03157       t = ffecom_1 (INDIRECT_REF,
03158         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
03159   }
03160       return t;
03161 
03162     case FFEBLD_opARRAYREF:
03163       return ffecom_arrayref_ (NULL_TREE, expr, 0);
03164 
03165     case FFEBLD_opUPLUS:
03166       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
03167       return ffecom_1 (NOP_EXPR, tree_type, left);
03168 
03169     case FFEBLD_opPAREN:
03170       /* ~~~Make sure Fortran rules respected here */
03171       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
03172       return ffecom_1 (NOP_EXPR, tree_type, left);
03173 
03174     case FFEBLD_opUMINUS:
03175       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
03176       if (tree_type_x)
03177   {
03178     tree_type = tree_type_x;
03179     left = convert (tree_type, left);
03180   }
03181       return ffecom_1 (NEGATE_EXPR, tree_type, left);
03182 
03183     case FFEBLD_opADD:
03184       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
03185       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
03186       if (tree_type_x)
03187   {
03188     tree_type = tree_type_x;
03189     left = convert (tree_type, left);
03190     right = convert (tree_type, right);
03191   }
03192       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
03193 
03194     case FFEBLD_opSUBTRACT:
03195       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
03196       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
03197       if (tree_type_x)
03198   {
03199     tree_type = tree_type_x;
03200     left = convert (tree_type, left);
03201     right = convert (tree_type, right);
03202   }
03203       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
03204 
03205     case FFEBLD_opMULTIPLY:
03206       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
03207       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
03208       if (tree_type_x)
03209   {
03210     tree_type = tree_type_x;
03211     left = convert (tree_type, left);
03212     right = convert (tree_type, right);
03213   }
03214       return ffecom_2 (MULT_EXPR, tree_type, left, right);
03215 
03216     case FFEBLD_opDIVIDE:
03217       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
03218       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
03219       if (tree_type_x)
03220   {
03221     tree_type = tree_type_x;
03222     left = convert (tree_type, left);
03223     right = convert (tree_type, right);
03224   }
03225       return ffecom_tree_divide_ (tree_type, left, right,
03226                 dest_tree, dest, dest_used,
03227           ffebld_nonter_hook (expr));
03228 
03229     case FFEBLD_opPOWER:
03230       {
03231   ffebld left = ffebld_left (expr);
03232   ffebld right = ffebld_right (expr);
03233   ffecomGfrt code;
03234   ffeinfoKindtype rtkt;
03235   ffeinfoKindtype ltkt;
03236   bool ref = TRUE;
03237 
03238   switch (ffeinfo_basictype (ffebld_info (right)))
03239     {
03240 
03241     case FFEINFO_basictypeINTEGER:
03242       if (1 || optimize)
03243         {
03244     item = ffecom_expr_power_integer_ (expr);
03245     if (item != NULL_TREE)
03246       return item;
03247         }
03248 
03249       rtkt = FFEINFO_kindtypeINTEGER1;
03250       switch (ffeinfo_basictype (ffebld_info (left)))
03251         {
03252         case FFEINFO_basictypeINTEGER:
03253     if ((ffeinfo_kindtype (ffebld_info (left))
03254         == FFEINFO_kindtypeINTEGER4)
03255         || (ffeinfo_kindtype (ffebld_info (right))
03256       == FFEINFO_kindtypeINTEGER4))
03257       {
03258         code = FFECOM_gfrtPOW_QQ;
03259         ltkt = FFEINFO_kindtypeINTEGER4;
03260         rtkt = FFEINFO_kindtypeINTEGER4;
03261       }
03262     else
03263       {
03264         code = FFECOM_gfrtPOW_II;
03265         ltkt = FFEINFO_kindtypeINTEGER1;
03266       }
03267     break;
03268 
03269         case FFEINFO_basictypeREAL:
03270     if (ffeinfo_kindtype (ffebld_info (left))
03271         == FFEINFO_kindtypeREAL1)
03272       {
03273         code = FFECOM_gfrtPOW_RI;
03274         ltkt = FFEINFO_kindtypeREAL1;
03275       }
03276     else
03277       {
03278         code = FFECOM_gfrtPOW_DI;
03279         ltkt = FFEINFO_kindtypeREAL2;
03280       }
03281     break;
03282 
03283         case FFEINFO_basictypeCOMPLEX:
03284     if (ffeinfo_kindtype (ffebld_info (left))
03285         == FFEINFO_kindtypeREAL1)
03286       {
03287         code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
03288         ltkt = FFEINFO_kindtypeREAL1;
03289       }
03290     else
03291       {
03292         code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
03293         ltkt = FFEINFO_kindtypeREAL2;
03294       }
03295     break;
03296 
03297         default:
03298     assert ("bad pow_*i" == NULL);
03299     code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
03300     ltkt = FFEINFO_kindtypeREAL1;
03301     break;
03302         }
03303       if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
03304         left = ffeexpr_convert (left, NULL, NULL,
03305               ffeinfo_basictype (ffebld_info (left)),
03306               ltkt, 0,
03307               FFETARGET_charactersizeNONE,
03308               FFEEXPR_contextLET);
03309       if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
03310         right = ffeexpr_convert (right, NULL, NULL,
03311                FFEINFO_basictypeINTEGER,
03312                rtkt, 0,
03313                FFETARGET_charactersizeNONE,
03314                FFEEXPR_contextLET);
03315       break;
03316 
03317     case FFEINFO_basictypeREAL:
03318       if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
03319         left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
03320               FFEINFO_kindtypeREALDOUBLE, 0,
03321               FFETARGET_charactersizeNONE,
03322               FFEEXPR_contextLET);
03323       if (ffeinfo_kindtype (ffebld_info (right))
03324     == FFEINFO_kindtypeREAL1)
03325         right = ffeexpr_convert (right, NULL, NULL,
03326                FFEINFO_basictypeREAL,
03327                FFEINFO_kindtypeREALDOUBLE, 0,
03328                FFETARGET_charactersizeNONE,
03329                FFEEXPR_contextLET);
03330       /* We used to call FFECOM_gfrtPOW_DD here,
03331          which passes arguments by reference.  */
03332       code = FFECOM_gfrtL_POW;
03333       /* Pass arguments by value. */
03334       ref  = FALSE;
03335       break;
03336 
03337     case FFEINFO_basictypeCOMPLEX:
03338       if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
03339         left = ffeexpr_convert (left, NULL, NULL,
03340               FFEINFO_basictypeCOMPLEX,
03341               FFEINFO_kindtypeREALDOUBLE, 0,
03342               FFETARGET_charactersizeNONE,
03343               FFEEXPR_contextLET);
03344       if (ffeinfo_kindtype (ffebld_info (right))
03345     == FFEINFO_kindtypeREAL1)
03346         right = ffeexpr_convert (right, NULL, NULL,
03347                FFEINFO_basictypeCOMPLEX,
03348                FFEINFO_kindtypeREALDOUBLE, 0,
03349                FFETARGET_charactersizeNONE,
03350                FFEEXPR_contextLET);
03351       code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
03352       ref = TRUE;     /* Pass arguments by reference. */
03353       break;
03354 
03355     default:
03356       assert ("bad pow_x*" == NULL);
03357       code = FFECOM_gfrtPOW_II;
03358       break;
03359     }
03360   return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
03361            ffecom_gfrt_kindtype (code),
03362            (ffe_is_f2c_library ()
03363             && ffecom_gfrt_complex_[code]),
03364            tree_type, left, right,
03365            dest_tree, dest, dest_used,
03366            NULL_TREE, FALSE, ref,
03367            ffebld_nonter_hook (expr));
03368       }
03369 
03370     case FFEBLD_opNOT:
03371       switch (bt)
03372   {
03373   case FFEINFO_basictypeLOGICAL:
03374     item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
03375     return convert (tree_type, item);
03376 
03377   case FFEINFO_basictypeINTEGER:
03378     return ffecom_1 (BIT_NOT_EXPR, tree_type,
03379          ffecom_expr (ffebld_left (expr)));
03380 
03381   default:
03382     assert ("NOT bad basictype" == NULL);
03383     /* Fall through. */
03384   case FFEINFO_basictypeANY:
03385     return error_mark_node;
03386   }
03387       break;
03388 
03389     case FFEBLD_opFUNCREF:
03390       assert (ffeinfo_basictype (ffebld_info (expr))
03391         != FFEINFO_basictypeCHARACTER);
03392       /* Fall through.   */
03393     case FFEBLD_opSUBRREF:
03394       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
03395     == FFEINFO_whereINTRINSIC)
03396   {     /* Invocation of an intrinsic. */
03397     item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
03398            dest_used);
03399     return item;
03400   }
03401       s = ffebld_symter (ffebld_left (expr));
03402       dt = ffesymbol_hook (s).decl_tree;
03403       if (dt == NULL_TREE)
03404   {
03405     s = ffecom_sym_transform_ (s);
03406     dt = ffesymbol_hook (s).decl_tree;
03407   }
03408       if (dt == error_mark_node)
03409   return dt;
03410 
03411       if (ffesymbol_hook (s).addr)
03412   item = dt;
03413       else
03414   item = ffecom_1_fn (dt);
03415 
03416       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
03417   args = ffecom_list_expr (ffebld_right (expr));
03418       else
03419   args = ffecom_list_ptr_to_expr (ffebld_right (expr));
03420 
03421       if (args == error_mark_node)
03422   return error_mark_node;
03423 
03424       item = ffecom_call_ (item, kt,
03425          ffesymbol_is_f2c (s)
03426          && (bt == FFEINFO_basictypeCOMPLEX)
03427          && (ffesymbol_where (s)
03428              != FFEINFO_whereCONSTANT),
03429          tree_type,
03430          args,
03431          dest_tree, dest, dest_used,
03432          error_mark_node, FALSE,
03433          ffebld_nonter_hook (expr));
03434       TREE_SIDE_EFFECTS (item) = 1;
03435       return item;
03436 
03437     case FFEBLD_opAND:
03438       switch (bt)
03439   {
03440   case FFEINFO_basictypeLOGICAL:
03441     item
03442       = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
03443            ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
03444          ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
03445     return convert (tree_type, item);
03446 
03447   case FFEINFO_basictypeINTEGER:
03448     return ffecom_2 (BIT_AND_EXPR, tree_type,
03449          ffecom_expr (ffebld_left (expr)),
03450          ffecom_expr (ffebld_right (expr)));
03451 
03452   default:
03453     assert ("AND bad basictype" == NULL);
03454     /* Fall through. */
03455   case FFEINFO_basictypeANY:
03456     return error_mark_node;
03457   }
03458       break;
03459 
03460     case FFEBLD_opOR:
03461       switch (bt)
03462   {
03463   case FFEINFO_basictypeLOGICAL:
03464     item
03465       = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
03466            ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
03467          ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
03468     return convert (tree_type, item);
03469 
03470   case FFEINFO_basictypeINTEGER:
03471     return ffecom_2 (BIT_IOR_EXPR, tree_type,
03472          ffecom_expr (ffebld_left (expr)),
03473          ffecom_expr (ffebld_right (expr)));
03474 
03475   default:
03476     assert ("OR bad basictype" == NULL);
03477     /* Fall through. */
03478   case FFEINFO_basictypeANY:
03479     return error_mark_node;
03480   }
03481       break;
03482 
03483     case FFEBLD_opXOR:
03484     case FFEBLD_opNEQV:
03485       switch (bt)
03486   {
03487   case FFEINFO_basictypeLOGICAL:
03488     item
03489       = ffecom_2 (NE_EXPR, integer_type_node,
03490       ffecom_expr (ffebld_left (expr)),
03491       ffecom_expr (ffebld_right (expr)));
03492     return convert (tree_type, ffecom_truth_value (item));
03493 
03494   case FFEINFO_basictypeINTEGER:
03495     return ffecom_2 (BIT_XOR_EXPR, tree_type,
03496          ffecom_expr (ffebld_left (expr)),
03497          ffecom_expr (ffebld_right (expr)));
03498 
03499   default:
03500     assert ("XOR/NEQV bad basictype" == NULL);
03501     /* Fall through. */
03502   case FFEINFO_basictypeANY:
03503     return error_mark_node;
03504   }
03505       break;
03506 
03507     case FFEBLD_opEQV:
03508       switch (bt)
03509   {
03510   case FFEINFO_basictypeLOGICAL:
03511     item
03512       = ffecom_2 (EQ_EXPR, integer_type_node,
03513       ffecom_expr (ffebld_left (expr)),
03514       ffecom_expr (ffebld_right (expr)));
03515     return convert (tree_type, ffecom_truth_value (item));
03516 
03517   case FFEINFO_basictypeINTEGER:
03518     return
03519       ffecom_1 (BIT_NOT_EXPR, tree_type,
03520           ffecom_2 (BIT_XOR_EXPR, tree_type,
03521         ffecom_expr (ffebld_left (expr)),
03522         ffecom_expr (ffebld_right (expr))));
03523 
03524   default:
03525     assert ("EQV bad basictype" == NULL);
03526     /* Fall through. */
03527   case FFEINFO_basictypeANY:
03528     return error_mark_node;
03529   }
03530       break;
03531 
03532     case FFEBLD_opCONVERT:
03533       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
03534   return error_mark_node;
03535 
03536       switch (bt)
03537   {
03538   case FFEINFO_basictypeLOGICAL:
03539   case FFEINFO_basictypeINTEGER:
03540   case FFEINFO_basictypeREAL:
03541     return convert (tree_type, ffecom_expr (ffebld_left (expr)));
03542 
03543   case FFEINFO_basictypeCOMPLEX:
03544     switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
03545       {
03546       case FFEINFO_basictypeINTEGER:
03547       case FFEINFO_basictypeLOGICAL:
03548       case FFEINFO_basictypeREAL:
03549         item = ffecom_expr (ffebld_left (expr));
03550         if (item == error_mark_node)
03551     return error_mark_node;
03552         /* convert() takes care of converting to the subtype first,
03553      at least in gcc-2.7.2. */
03554         item = convert (tree_type, item);
03555         return item;
03556 
03557       case FFEINFO_basictypeCOMPLEX:
03558         return convert (tree_type, ffecom_expr (ffebld_left (expr)));
03559 
03560       default:
03561         assert ("CONVERT COMPLEX bad basictype" == NULL);
03562         /* Fall through. */
03563       case FFEINFO_basictypeANY:
03564         return error_mark_node;
03565       }
03566     break;
03567 
03568   default:
03569     assert ("CONVERT bad basictype" == NULL);
03570     /* Fall through. */
03571   case FFEINFO_basictypeANY:
03572     return error_mark_node;
03573   }
03574       break;
03575 
03576     case FFEBLD_opLT:
03577       code = LT_EXPR;
03578       goto relational;    /* :::::::::::::::::::: */
03579 
03580     case FFEBLD_opLE:
03581       code = LE_EXPR;
03582       goto relational;    /* :::::::::::::::::::: */
03583 
03584     case FFEBLD_opEQ:
03585       code = EQ_EXPR;
03586       goto relational;    /* :::::::::::::::::::: */
03587 
03588     case FFEBLD_opNE:
03589       code = NE_EXPR;
03590       goto relational;    /* :::::::::::::::::::: */
03591 
03592     case FFEBLD_opGT:
03593       code = GT_EXPR;
03594       goto relational;    /* :::::::::::::::::::: */
03595 
03596     case FFEBLD_opGE:
03597       code = GE_EXPR;
03598 
03599     relational:   /* :::::::::::::::::::: */
03600       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
03601   {
03602   case FFEINFO_basictypeLOGICAL:
03603   case FFEINFO_basictypeINTEGER:
03604   case FFEINFO_basictypeREAL:
03605     item = ffecom_2 (code, integer_type_node,
03606          ffecom_expr (ffebld_left (expr)),
03607          ffecom_expr (ffebld_right (expr)));
03608     return convert (tree_type, item);
03609 
03610   case FFEINFO_basictypeCOMPLEX:
03611     assert (code == EQ_EXPR || code == NE_EXPR);
03612     {
03613       tree real_type;
03614       tree arg1 = ffecom_expr (ffebld_left (expr));
03615       tree arg2 = ffecom_expr (ffebld_right (expr));
03616 
03617       if (arg1 == error_mark_node || arg2 == error_mark_node)
03618         return error_mark_node;
03619 
03620       arg1 = ffecom_save_tree (arg1);
03621       arg2 = ffecom_save_tree (arg2);
03622 
03623       if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
03624         {
03625     real_type = TREE_TYPE (TREE_TYPE (arg1));
03626     assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
03627         }
03628       else
03629         {
03630     real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
03631     assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
03632         }
03633 
03634       item
03635         = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
03636         ffecom_2 (EQ_EXPR, integer_type_node,
03637           ffecom_1 (REALPART_EXPR, real_type, arg1),
03638          ffecom_1 (REALPART_EXPR, real_type, arg2)),
03639         ffecom_2 (EQ_EXPR, integer_type_node,
03640           ffecom_1 (IMAGPART_EXPR, real_type, arg1),
03641             ffecom_1 (IMAGPART_EXPR, real_type,
03642                 arg2)));
03643       if (code == EQ_EXPR)
03644         item = ffecom_truth_value (item);
03645       else
03646         item = ffecom_truth_value_invert (item);
03647       return convert (tree_type, item);
03648     }
03649 
03650   case FFEINFO_basictypeCHARACTER:
03651     {
03652       ffebld left = ffebld_left (expr);
03653       ffebld right = ffebld_right (expr);
03654       tree left_tree;
03655       tree right_tree;
03656       tree left_length;
03657       tree right_length;
03658 
03659       /* f2c run-time functions do the implicit blank-padding for us,
03660          so we don't usually have to implement blank-padding ourselves.
03661          (The exception is when we pass an argument to a separately
03662          compiled statement function -- if we know the arg is not the
03663          same length as the dummy, we must truncate or extend it.  If
03664          we "inline" statement functions, that necessity goes away as
03665          well.)
03666 
03667          Strip off the CONVERT operators that blank-pad.  (Truncation by
03668          CONVERT shouldn't happen here, but it can happen in
03669          assignments.) */
03670 
03671       while (ffebld_op (left) == FFEBLD_opCONVERT)
03672         left = ffebld_left (left);
03673       while (ffebld_op (right) == FFEBLD_opCONVERT)
03674         right = ffebld_left (right);
03675 
03676       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
03677       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
03678 
03679       if (left_tree == error_mark_node || left_length == error_mark_node
03680     || right_tree == error_mark_node
03681     || right_length == error_mark_node)
03682         return error_mark_node;
03683 
03684       if ((ffebld_size_known (left) == 1)
03685     && (ffebld_size_known (right) == 1))
03686         {
03687     left_tree
03688       = ffecom_1 (INDIRECT_REF,
03689           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
03690             left_tree);
03691     right_tree
03692       = ffecom_1 (INDIRECT_REF,
03693          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
03694             right_tree);
03695 
03696     item
03697       = ffecom_2 (code, integer_type_node,
03698             ffecom_2 (ARRAY_REF,
03699           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
03700           left_tree,
03701           integer_one_node),
03702             ffecom_2 (ARRAY_REF,
03703          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
03704           right_tree,
03705           integer_one_node));
03706         }
03707       else
03708         {
03709     item = build_tree_list (NULL_TREE, left_tree);
03710     TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
03711     TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
03712                      left_length);
03713     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
03714       = build_tree_list (NULL_TREE, right_length);
03715     item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
03716     item = ffecom_2 (code, integer_type_node,
03717          item,
03718          convert (TREE_TYPE (item),
03719             integer_zero_node));
03720         }
03721       item = convert (tree_type, item);
03722     }
03723 
03724     return item;
03725 
03726   default:
03727     assert ("relational bad basictype" == NULL);
03728     /* Fall through. */
03729   case FFEINFO_basictypeANY:
03730     return error_mark_node;
03731   }
03732       break;
03733 
03734     case FFEBLD_opPERCENT_LOC:
03735       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
03736       return convert (tree_type, item);
03737 
03738     case FFEBLD_opPERCENT_VAL:
03739       item = ffecom_arg_expr (ffebld_left (expr), &list);
03740       return convert (tree_type, item);
03741 
03742     case FFEBLD_opITEM:
03743     case FFEBLD_opSTAR:
03744     case FFEBLD_opBOUNDS:
03745     case FFEBLD_opREPEAT:
03746     case FFEBLD_opLABTER:
03747     case FFEBLD_opLABTOK:
03748     case FFEBLD_opIMPDO:
03749     case FFEBLD_opCONCATENATE:
03750     case FFEBLD_opSUBSTR:
03751     default:
03752       assert ("bad op" == NULL);
03753       /* Fall through. */
03754     case FFEBLD_opANY:
03755       return error_mark_node;
03756     }
03757 
03758 #if 1
03759   assert ("didn't think anything got here anymore!!" == NULL);
03760 #else
03761   switch (ffebld_arity (expr))
03762     {
03763     case 2:
03764       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
03765       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
03766       if (TREE_OPERAND (item, 0) == error_mark_node
03767     || TREE_OPERAND (item, 1) == error_mark_node)
03768   return error_mark_node;
03769       break;
03770 
03771     case 1:
03772       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
03773       if (TREE_OPERAND (item, 0) == error_mark_node)
03774   return error_mark_node;
03775       break;
03776 
03777     default:
03778       break;
03779     }
03780 
03781   return fold (item);
03782 #endif
03783 }
03784 
03785 /* Returns the tree that does the intrinsic invocation.
03786 
03787    Note: this function applies only to intrinsics returning
03788    CHARACTER*1 or non-CHARACTER results, and to intrinsic
03789    subroutines.  */
03790 
03791 static tree
03792 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
03793       ffebld dest, bool *dest_used)
03794 {
03795   tree expr_tree;
03796   tree saved_expr1;   /* For those who need it. */
03797   tree saved_expr2;   /* For those who need it. */
03798   ffeinfoBasictype bt;
03799   ffeinfoKindtype kt;
03800   tree tree_type;
03801   tree arg1_type;
03802   tree real_type;   /* REAL type corresponding to COMPLEX. */
03803   tree tempvar;
03804   ffebld list = ffebld_right (expr);  /* List of (some) args. */
03805   ffebld arg1;      /* For handy reference. */
03806   ffebld arg2;
03807   ffebld arg3;
03808   ffeintrinImp codegen_imp;
03809   ffecomGfrt gfrt;
03810 
03811   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
03812 
03813   if (dest_used != NULL)
03814     *dest_used = FALSE;
03815 
03816   bt = ffeinfo_basictype (ffebld_info (expr));
03817   kt = ffeinfo_kindtype (ffebld_info (expr));
03818   tree_type = ffecom_tree_type[bt][kt];
03819 
03820   if (list != NULL)
03821     {
03822       arg1 = ffebld_head (list);
03823       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
03824   return error_mark_node;
03825       if ((list = ffebld_trail (list)) != NULL)
03826   {
03827     arg2 = ffebld_head (list);
03828     if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
03829       return error_mark_node;
03830     if ((list = ffebld_trail (list)) != NULL)
03831       {
03832         arg3 = ffebld_head (list);
03833         if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
03834     return error_mark_node;
03835       }
03836     else
03837       arg3 = NULL;
03838   }
03839       else
03840   arg2 = arg3 = NULL;
03841     }
03842   else
03843     arg1 = arg2 = arg3 = NULL;
03844 
03845   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
03846      args.  This is used by the MAX/MIN expansions. */
03847 
03848   if (arg1 != NULL)
03849     arg1_type = ffecom_tree_type
03850       [ffeinfo_basictype (ffebld_info (arg1))]
03851       [ffeinfo_kindtype (ffebld_info (arg1))];
03852   else
03853     arg1_type = NULL_TREE;  /* Really not needed, but might catch bugs
03854            here. */
03855 
03856   /* There are several ways for each of the cases in the following switch
03857      statements to exit (from simplest to use to most complicated):
03858 
03859      break;  (when expr_tree == NULL)
03860 
03861      A standard call is made to the specific intrinsic just as if it had been
03862      passed in as a dummy procedure and called as any old procedure.  This
03863      method can produce slower code but in some cases it's the easiest way for
03864      now.  However, if a (presumably faster) direct call is available,
03865      that is used, so this is the easiest way in many more cases now.
03866 
03867      gfrt = FFECOM_gfrtWHATEVER;
03868      break;
03869 
03870      gfrt contains the gfrt index of a library function to call, passing the
03871      argument(s) by value rather than by reference.  Used when a more
03872      careful choice of library function is needed than that provided
03873      by the vanilla `break;'.
03874 
03875      return expr_tree;
03876 
03877      The expr_tree has been completely set up and is ready to be returned
03878      as is.  No further actions are taken.  Use this when the tree is not
03879      in the simple form for one of the arity_n labels.   */
03880 
03881   /* For info on how the switch statement cases were written, see the files
03882      enclosed in comments below the switch statement. */
03883 
03884   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
03885   gfrt = ffeintrin_gfrt_direct (codegen_imp);
03886   if (gfrt == FFECOM_gfrt)
03887     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
03888 
03889   switch (codegen_imp)
03890     {
03891     case FFEINTRIN_impABS:
03892     case FFEINTRIN_impCABS:
03893     case FFEINTRIN_impCDABS:
03894     case FFEINTRIN_impDABS:
03895     case FFEINTRIN_impIABS:
03896       if (ffeinfo_basictype (ffebld_info (arg1))
03897     == FFEINFO_basictypeCOMPLEX)
03898   {
03899     if (kt == FFEINFO_kindtypeREAL1)
03900       gfrt = FFECOM_gfrtCABS;
03901     else if (kt == FFEINFO_kindtypeREAL2)
03902       gfrt = FFECOM_gfrtCDABS;
03903     break;
03904   }
03905       return ffecom_1 (ABS_EXPR, tree_type,
03906            convert (tree_type, ffecom_expr (arg1)));
03907 
03908     case FFEINTRIN_impACOS:
03909     case FFEINTRIN_impDACOS:
03910       break;
03911 
03912     case FFEINTRIN_impAIMAG:
03913     case FFEINTRIN_impDIMAG:
03914     case FFEINTRIN_impIMAGPART:
03915       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
03916   arg1_type = TREE_TYPE (arg1_type);
03917       else
03918   arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
03919 
03920       return
03921   convert (tree_type,
03922      ffecom_1 (IMAGPART_EXPR, arg1_type,
03923          ffecom_expr (arg1)));
03924 
03925     case FFEINTRIN_impAINT:
03926     case FFEINTRIN_impDINT:
03927 #if 0
03928       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
03929       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
03930 #else /* in the meantime, must use floor to avoid range problems with ints */
03931       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
03932       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
03933       return
03934   convert (tree_type,
03935      ffecom_3 (COND_EXPR, double_type_node,
03936          ffecom_truth_value
03937          (ffecom_2 (GE_EXPR, integer_type_node,
03938               saved_expr1,
03939               convert (arg1_type,
03940                  ffecom_float_zero_))),
03941          ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
03942                build_tree_list (NULL_TREE,
03943               convert (double_type_node,
03944                  saved_expr1)),
03945                NULL_TREE),
03946          ffecom_1 (NEGATE_EXPR, double_type_node,
03947              ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
03948              build_tree_list (NULL_TREE,
03949               convert (double_type_node,
03950                   ffecom_1 (NEGATE_EXPR,
03951                 arg1_type,
03952                      saved_expr1))),
03953                    NULL_TREE)
03954              ))
03955      );
03956 #endif
03957 
03958     case FFEINTRIN_impANINT:
03959     case FFEINTRIN_impDNINT:
03960 #if 0       /* This way of doing it won't handle real
03961            numbers of large magnitudes. */
03962       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
03963       expr_tree = convert (tree_type,
03964          convert (integer_type_node,
03965             ffecom_3 (COND_EXPR, tree_type,
03966                 ffecom_truth_value
03967                 (ffecom_2 (GE_EXPR,
03968                integer_type_node,
03969                saved_expr1,
03970                    ffecom_float_zero_)),
03971                 ffecom_2 (PLUS_EXPR,
03972               tree_type,
03973               saved_expr1,
03974               ffecom_float_half_),
03975                 ffecom_2 (MINUS_EXPR,
03976               tree_type,
03977               saved_expr1,
03978                  ffecom_float_half_))));
03979       return expr_tree;
03980 #else /* So we instead call floor. */
03981       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
03982       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
03983       return
03984   convert (tree_type,
03985      ffecom_3 (COND_EXPR, double_type_node,
03986          ffecom_truth_value
03987          (ffecom_2 (GE_EXPR, integer_type_node,
03988               saved_expr1,
03989               convert (arg1_type,
03990                  ffecom_float_zero_))),
03991          ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
03992                build_tree_list (NULL_TREE,
03993               convert (double_type_node,
03994                  ffecom_2 (PLUS_EXPR,
03995                      arg1_type,
03996                      saved_expr1,
03997                      convert (arg1_type,
03998                         ffecom_float_half_)))),
03999                NULL_TREE),
04000          ffecom_1 (NEGATE_EXPR, double_type_node,
04001              ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
04002                    build_tree_list (NULL_TREE,
04003                   convert (double_type_node,
04004                      ffecom_2 (MINUS_EXPR,
04005                          arg1_type,
04006                          convert (arg1_type,
04007                             ffecom_float_half_),
04008                          saved_expr1))),
04009                    NULL_TREE))
04010          )
04011      );
04012 #endif
04013 
04014     case FFEINTRIN_impASIN:
04015     case FFEINTRIN_impDASIN:
04016     case FFEINTRIN_impATAN:
04017     case FFEINTRIN_impDATAN:
04018     case FFEINTRIN_impATAN2:
04019     case FFEINTRIN_impDATAN2:
04020       break;
04021 
04022     case FFEINTRIN_impCHAR:
04023     case FFEINTRIN_impACHAR:
04024 #ifdef HOHO
04025       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
04026 #else
04027       tempvar = ffebld_nonter_hook (expr);
04028       assert (tempvar);
04029 #endif
04030       {
04031   tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
04032 
04033   expr_tree = ffecom_modify (tmv,
04034            ffecom_2 (ARRAY_REF, tmv, tempvar,
04035                integer_one_node),
04036            convert (tmv, ffecom_expr (arg1)));
04037       }
04038       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
04039           expr_tree,
04040           tempvar);
04041       expr_tree = ffecom_1 (ADDR_EXPR,
04042           build_pointer_type (TREE_TYPE (expr_tree)),
04043           expr_tree);
04044       return expr_tree;
04045 
04046     case FFEINTRIN_impCMPLX:
04047     case FFEINTRIN_impDCMPLX:
04048       if (arg2 == NULL)
04049   return
04050     convert (tree_type, ffecom_expr (arg1));
04051 
04052       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
04053       return
04054   ffecom_2 (COMPLEX_EXPR, tree_type,
04055       convert (real_type, ffecom_expr (arg1)),
04056       convert (real_type,
04057          ffecom_expr (arg2)));
04058 
04059     case FFEINTRIN_impCOMPLEX:
04060       return
04061   ffecom_2 (COMPLEX_EXPR, tree_type,
04062       ffecom_expr (arg1),
04063       ffecom_expr (arg2));
04064 
04065     case FFEINTRIN_impCONJG:
04066     case FFEINTRIN_impDCONJG:
04067       {
04068   tree arg1_tree;
04069 
04070   real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
04071   arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
04072   return
04073     ffecom_2 (COMPLEX_EXPR, tree_type,
04074         ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
04075         ffecom_1 (NEGATE_EXPR, real_type,
04076             ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
04077       }
04078 
04079     case FFEINTRIN_impCOS:
04080     case FFEINTRIN_impCCOS:
04081     case FFEINTRIN_impCDCOS:
04082     case FFEINTRIN_impDCOS:
04083       if (bt == FFEINFO_basictypeCOMPLEX)
04084   {
04085     if (kt == FFEINFO_kindtypeREAL1)
04086       gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
04087     else if (kt == FFEINFO_kindtypeREAL2)
04088       gfrt = FFECOM_gfrtCDCOS;  /* Overlapping result okay. */
04089   }
04090       break;
04091 
04092     case FFEINTRIN_impCOSH:
04093     case FFEINTRIN_impDCOSH:
04094       break;
04095 
04096     case FFEINTRIN_impDBLE:
04097     case FFEINTRIN_impDFLOAT:
04098     case FFEINTRIN_impDREAL:
04099     case FFEINTRIN_impFLOAT:
04100     case FFEINTRIN_impIDINT:
04101     case FFEINTRIN_impIFIX:
04102     case FFEINTRIN_impINT2:
04103     case FFEINTRIN_impINT8:
04104     case FFEINTRIN_impINT:
04105     case FFEINTRIN_impLONG:
04106     case FFEINTRIN_impREAL:
04107     case FFEINTRIN_impSHORT:
04108     case FFEINTRIN_impSNGL:
04109       return convert (tree_type, ffecom_expr (arg1));
04110 
04111     case FFEINTRIN_impDIM:
04112     case FFEINTRIN_impDDIM:
04113     case FFEINTRIN_impIDIM:
04114       saved_expr1 = ffecom_save_tree (convert (tree_type,
04115                  ffecom_expr (arg1)));
04116       saved_expr2 = ffecom_save_tree (convert (tree_type,
04117                  ffecom_expr (arg2)));
04118       return
04119   ffecom_3 (COND_EXPR, tree_type,
04120       ffecom_truth_value
04121       (ffecom_2 (GT_EXPR, integer_type_node,
04122            saved_expr1,
04123            saved_expr2)),
04124       ffecom_2 (MINUS_EXPR, tree_type,
04125           saved_expr1,
04126           saved_expr2),
04127       convert (tree_type, ffecom_float_zero_));
04128 
04129     case FFEINTRIN_impDPROD:
04130       return
04131   ffecom_2 (MULT_EXPR, tree_type,
04132       convert (tree_type, ffecom_expr (arg1)),
04133       convert (tree_type, ffecom_expr (arg2)));
04134 
04135     case FFEINTRIN_impEXP:
04136     case FFEINTRIN_impCDEXP:
04137     case FFEINTRIN_impCEXP:
04138     case FFEINTRIN_impDEXP:
04139       if (bt == FFEINFO_basictypeCOMPLEX)
04140   {
04141     if (kt == FFEINFO_kindtypeREAL1)
04142       gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
04143     else if (kt == FFEINFO_kindtypeREAL2)
04144       gfrt = FFECOM_gfrtCDEXP;  /* Overlapping result okay. */
04145   }
04146       break;
04147 
04148     case FFEINTRIN_impICHAR:
04149     case FFEINTRIN_impIACHAR:
04150 #if 0       /* The simple approach. */
04151       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
04152       expr_tree
04153   = ffecom_1 (INDIRECT_REF,
04154         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
04155         expr_tree);
04156       expr_tree
04157   = ffecom_2 (ARRAY_REF,
04158         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
04159         expr_tree,
04160         integer_one_node);
04161       return convert (tree_type, expr_tree);
04162 #else /* The more interesting (and more optimal) approach. */
04163       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
04164       expr_tree = ffecom_3 (COND_EXPR, tree_type,
04165           saved_expr1,
04166           expr_tree,
04167           convert (tree_type, integer_zero_node));
04168       return expr_tree;
04169 #endif
04170 
04171     case FFEINTRIN_impINDEX:
04172       break;
04173 
04174     case FFEINTRIN_impLEN:
04175 #if 0
04176       break;          /* The simple approach. */
04177 #else
04178       return ffecom_intrinsic_len_ (arg1);  /* The more optimal approach. */
04179 #endif
04180 
04181     case FFEINTRIN_impLGE:
04182     case FFEINTRIN_impLGT:
04183     case FFEINTRIN_impLLE:
04184     case FFEINTRIN_impLLT:
04185       break;
04186 
04187     case FFEINTRIN_impLOG:
04188     case FFEINTRIN_impALOG:
04189     case FFEINTRIN_impCDLOG:
04190     case FFEINTRIN_impCLOG:
04191     case FFEINTRIN_impDLOG:
04192       if (bt == FFEINFO_basictypeCOMPLEX)
04193   {
04194     if (kt == FFEINFO_kindtypeREAL1)
04195       gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
04196     else if (kt == FFEINFO_kindtypeREAL2)
04197       gfrt = FFECOM_gfrtCDLOG;  /* Overlapping result okay. */
04198   }
04199       break;
04200 
04201     case FFEINTRIN_impLOG10:
04202     case FFEINTRIN_impALOG10:
04203     case FFEINTRIN_impDLOG10:
04204       if (gfrt != FFECOM_gfrt)
04205   break;  /* Already picked one, stick with it. */
04206 
04207       if (kt == FFEINFO_kindtypeREAL1)
04208   /* We used to call FFECOM_gfrtALOG10 here.  */
04209   gfrt = FFECOM_gfrtL_LOG10;
04210       else if (kt == FFEINFO_kindtypeREAL2)
04211   /* We used to call FFECOM_gfrtDLOG10 here.  */
04212   gfrt = FFECOM_gfrtL_LOG10;
04213       break;
04214 
04215     case FFEINTRIN_impMAX:
04216     case FFEINTRIN_impAMAX0:
04217     case FFEINTRIN_impAMAX1:
04218     case FFEINTRIN_impDMAX1:
04219     case FFEINTRIN_impMAX0:
04220     case FFEINTRIN_impMAX1:
04221       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
04222   arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
04223       else
04224   arg1_type = tree_type;
04225       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
04226           convert (arg1_type, ffecom_expr (arg1)),
04227           convert (arg1_type, ffecom_expr (arg2)));
04228       for (; list != NULL; list = ffebld_trail (list))
04229   {
04230     if ((ffebld_head (list) == NULL)
04231         || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
04232       continue;
04233     expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
04234         expr_tree,
04235         convert (arg1_type,
04236            ffecom_expr (ffebld_head (list))));
04237   }
04238       return convert (tree_type, expr_tree);
04239 
04240     case FFEINTRIN_impMIN:
04241     case FFEINTRIN_impAMIN0:
04242     case FFEINTRIN_impAMIN1:
04243     case FFEINTRIN_impDMIN1:
04244     case FFEINTRIN_impMIN0:
04245     case FFEINTRIN_impMIN1:
04246       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
04247   arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
04248       else
04249   arg1_type = tree_type;
04250       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
04251           convert (arg1_type, ffecom_expr (arg1)),
04252           convert (arg1_type, ffecom_expr (arg2)));
04253       for (; list != NULL; list = ffebld_trail (list))
04254   {
04255     if ((ffebld_head (list) == NULL)
04256         || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
04257       continue;
04258     expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
04259         expr_tree,
04260         convert (arg1_type,
04261            ffecom_expr (ffebld_head (list))));
04262   }
04263       return convert (tree_type, expr_tree);
04264 
04265     case FFEINTRIN_impMOD:
04266     case FFEINTRIN_impAMOD:
04267     case FFEINTRIN_impDMOD:
04268       if (bt != FFEINFO_basictypeREAL)
04269   return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
04270        convert (tree_type, ffecom_expr (arg1)),
04271        convert (tree_type, ffecom_expr (arg2)));
04272 
04273       if (kt == FFEINFO_kindtypeREAL1)
04274   /* We used to call FFECOM_gfrtAMOD here.  */
04275   gfrt = FFECOM_gfrtL_FMOD;
04276       else if (kt == FFEINFO_kindtypeREAL2)
04277   /* We used to call FFECOM_gfrtDMOD here.  */
04278   gfrt = FFECOM_gfrtL_FMOD;
04279       break;
04280 
04281     case FFEINTRIN_impNINT:
04282     case FFEINTRIN_impIDNINT:
04283 #if 0
04284       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
04285       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
04286 #else
04287       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
04288       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
04289       return
04290   convert (ffecom_integer_type_node,
04291      ffecom_3 (COND_EXPR, arg1_type,
04292          ffecom_truth_value
04293          (ffecom_2 (GE_EXPR, integer_type_node,
04294               saved_expr1,
04295               convert (arg1_type,
04296                  ffecom_float_zero_))),
04297          ffecom_2 (PLUS_EXPR, arg1_type,
04298              saved_expr1,
04299              convert (arg1_type,
04300                 ffecom_float_half_)),
04301          ffecom_2 (MINUS_EXPR, arg1_type,
04302              saved_expr1,
04303              convert (arg1_type,
04304                 ffecom_float_half_))));
04305 #endif
04306 
04307     case FFEINTRIN_impSIGN:
04308     case FFEINTRIN_impDSIGN:
04309     case FFEINTRIN_impISIGN:
04310       {
04311   tree arg2_tree = ffecom_expr (arg2);
04312 
04313   saved_expr1
04314     = ffecom_save_tree
04315     (ffecom_1 (ABS_EXPR, tree_type,
04316          convert (tree_type,
04317             ffecom_expr (arg1))));
04318   expr_tree
04319     = ffecom_3 (COND_EXPR, tree_type,
04320           ffecom_truth_value
04321           (ffecom_2 (GE_EXPR, integer_type_node,
04322          arg2_tree,
04323          convert (TREE_TYPE (arg2_tree),
04324             integer_zero_node))),
04325           saved_expr1,
04326           ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
04327   /* Make sure SAVE_EXPRs get referenced early enough. */
04328   expr_tree
04329     = ffecom_2 (COMPOUND_EXPR, tree_type,
04330           convert (void_type_node, saved_expr1),
04331           expr_tree);
04332       }
04333       return expr_tree;
04334 
04335     case FFEINTRIN_impSIN:
04336     case FFEINTRIN_impCDSIN:
04337     case FFEINTRIN_impCSIN:
04338     case FFEINTRIN_impDSIN:
04339       if (bt == FFEINFO_basictypeCOMPLEX)
04340   {
04341     if (kt == FFEINFO_kindtypeREAL1)
04342       gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
04343     else if (kt == FFEINFO_kindtypeREAL2)
04344       gfrt = FFECOM_gfrtCDSIN;  /* Overlapping result okay. */
04345   }
04346       break;
04347 
04348     case FFEINTRIN_impSINH:
04349     case FFEINTRIN_impDSINH:
04350       break;
04351 
04352     case FFEINTRIN_impSQRT:
04353     case FFEINTRIN_impCDSQRT:
04354     case FFEINTRIN_impCSQRT:
04355     case FFEINTRIN_impDSQRT:
04356       if (bt == FFEINFO_basictypeCOMPLEX)
04357   {
04358     if (kt == FFEINFO_kindtypeREAL1)
04359       gfrt = FFECOM_gfrtCSQRT;  /* Overlapping result okay. */
04360     else if (kt == FFEINFO_kindtypeREAL2)
04361       gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
04362   }
04363       break;
04364 
04365     case FFEINTRIN_impTAN:
04366     case FFEINTRIN_impDTAN:
04367     case FFEINTRIN_impTANH:
04368     case FFEINTRIN_impDTANH:
04369       break;
04370 
04371     case FFEINTRIN_impREALPART:
04372       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
04373   arg1_type = TREE_TYPE (arg1_type);
04374       else
04375   arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
04376 
04377       return
04378   convert (tree_type,
04379      ffecom_1 (REALPART_EXPR, arg1_type,
04380          ffecom_expr (arg1)));
04381 
04382     case FFEINTRIN_impIAND:
04383     case FFEINTRIN_impAND:
04384       return ffecom_2 (BIT_AND_EXPR, tree_type,
04385            convert (tree_type,
04386         ffecom_expr (arg1)),
04387            convert (tree_type,
04388         ffecom_expr (arg2)));
04389 
04390     case FFEINTRIN_impIOR:
04391     case FFEINTRIN_impOR:
04392       return ffecom_2 (BIT_IOR_EXPR, tree_type,
04393            convert (tree_type,
04394         ffecom_expr (arg1)),
04395            convert (tree_type,
04396         ffecom_expr (arg2)));
04397 
04398     case FFEINTRIN_impIEOR:
04399     case FFEINTRIN_impXOR:
04400       return ffecom_2 (BIT_XOR_EXPR, tree_type,
04401            convert (tree_type,
04402         ffecom_expr (arg1)),
04403            convert (tree_type,
04404         ffecom_expr (arg2)));
04405 
04406     case FFEINTRIN_impLSHIFT:
04407       return ffecom_2 (LSHIFT_EXPR, tree_type,
04408            ffecom_expr (arg1),
04409            convert (integer_type_node,
04410         ffecom_expr (arg2)));
04411 
04412     case FFEINTRIN_impRSHIFT:
04413       return ffecom_2 (RSHIFT_EXPR, tree_type,
04414            ffecom_expr (arg1),
04415            convert (integer_type_node,
04416         ffecom_expr (arg2)));
04417 
04418     case FFEINTRIN_impNOT:
04419       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
04420 
04421     case FFEINTRIN_impBIT_SIZE:
04422       return convert (tree_type, TYPE_SIZE (arg1_type));
04423 
04424     case FFEINTRIN_impBTEST:
04425       {
04426   ffetargetLogical1 target_true;
04427   ffetargetLogical1 target_false;
04428   tree true_tree;
04429   tree false_tree;
04430 
04431   ffetarget_logical1 (&target_true, TRUE);
04432   ffetarget_logical1 (&target_false, FALSE);
04433   if (target_true == 1)
04434     true_tree = convert (tree_type, integer_one_node);
04435   else
04436     true_tree = convert (tree_type, build_int_2 (target_true, 0));
04437   if (target_false == 0)
04438     false_tree = convert (tree_type, integer_zero_node);
04439   else
04440     false_tree = convert (tree_type, build_int_2 (target_false, 0));
04441 
04442   return
04443     ffecom_3 (COND_EXPR, tree_type,
04444         ffecom_truth_value
04445         (ffecom_2 (EQ_EXPR, integer_type_node,
04446              ffecom_2 (BIT_AND_EXPR, arg1_type,
04447            ffecom_expr (arg1),
04448            ffecom_2 (LSHIFT_EXPR, arg1_type,
04449                convert (arg1_type,
04450                 integer_one_node),
04451                convert (integer_type_node,
04452                   ffecom_expr (arg2)))),
04453              convert (arg1_type,
04454           integer_zero_node))),
04455         false_tree,
04456         true_tree);
04457       }
04458 
04459     case FFEINTRIN_impIBCLR:
04460       return
04461   ffecom_2 (BIT_AND_EXPR, tree_type,
04462       ffecom_expr (arg1),
04463       ffecom_1 (BIT_NOT_EXPR, tree_type,
04464           ffecom_2 (LSHIFT_EXPR, tree_type,
04465               convert (tree_type,
04466                  integer_one_node),
04467               convert (integer_type_node,
04468                  ffecom_expr (arg2)))));
04469 
04470     case FFEINTRIN_impIBITS:
04471       {
04472   tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
04473                 ffecom_expr (arg3)));
04474   tree uns_type
04475   = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
04476 
04477   expr_tree
04478     = ffecom_2 (BIT_AND_EXPR, tree_type,
04479           ffecom_2 (RSHIFT_EXPR, tree_type,
04480         ffecom_expr (arg1),
04481         convert (integer_type_node,
04482            ffecom_expr (arg2))),
04483           convert (tree_type,
04484              ffecom_2 (RSHIFT_EXPR, uns_type,
04485            ffecom_1 (BIT_NOT_EXPR,
04486                uns_type,
04487                convert (uns_type,
04488               integer_zero_node)),
04489            ffecom_2 (MINUS_EXPR,
04490                integer_type_node,
04491                TYPE_SIZE (uns_type),
04492                arg3_tree))));
04493   /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
04494   expr_tree
04495     = ffecom_3 (COND_EXPR, tree_type,
04496           ffecom_truth_value
04497           (ffecom_2 (NE_EXPR, integer_type_node,
04498          arg3_tree,
04499          integer_zero_node)),
04500           expr_tree,
04501           convert (tree_type, integer_zero_node));
04502       }
04503       return expr_tree;
04504 
04505     case FFEINTRIN_impIBSET:
04506       return
04507   ffecom_2 (BIT_IOR_EXPR, tree_type,
04508       ffecom_expr (arg1),
04509       ffecom_2 (LSHIFT_EXPR, tree_type,
04510           convert (tree_type, integer_one_node),
04511           convert (integer_type_node,
04512              ffecom_expr (arg2))));
04513 
04514     case FFEINTRIN_impISHFT:
04515       {
04516   tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
04517   tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
04518                 ffecom_expr (arg2)));
04519   tree uns_type
04520   = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
04521 
04522   expr_tree
04523     = ffecom_3 (COND_EXPR, tree_type,
04524           ffecom_truth_value
04525           (ffecom_2 (GE_EXPR, integer_type_node,
04526          arg2_tree,
04527          integer_zero_node)),
04528           ffecom_2 (LSHIFT_EXPR, tree_type,
04529         arg1_tree,
04530         arg2_tree),
04531           convert (tree_type,
04532              ffecom_2 (RSHIFT_EXPR, uns_type,
04533            convert (uns_type, arg1_tree),
04534            ffecom_1 (NEGATE_EXPR,
04535                integer_type_node,
04536                arg2_tree))));
04537   /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
04538   expr_tree
04539     = ffecom_3 (COND_EXPR, tree_type,
04540           ffecom_truth_value
04541           (ffecom_2 (NE_EXPR, integer_type_node,
04542          ffecom_1 (ABS_EXPR,
04543              integer_type_node,
04544              arg2_tree),
04545          TYPE_SIZE (uns_type))),
04546           expr_tree,
04547           convert (tree_type, integer_zero_node));
04548   /* Make sure SAVE_EXPRs get referenced early enough. */
04549   expr_tree
04550     = ffecom_2 (COMPOUND_EXPR, tree_type,
04551           convert (void_type_node, arg1_tree),
04552           ffecom_2 (COMPOUND_EXPR, tree_type,
04553         convert (void_type_node, arg2_tree),
04554         expr_tree));
04555       }
04556       return expr_tree;
04557 
04558     case FFEINTRIN_impISHFTC:
04559       {
04560   tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
04561   tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
04562                 ffecom_expr (arg2)));
04563   tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
04564   : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
04565   tree shift_neg;
04566   tree shift_pos;
04567   tree mask_arg1;
04568   tree masked_arg1;
04569   tree uns_type
04570   = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
04571 
04572   mask_arg1
04573     = ffecom_2 (LSHIFT_EXPR, tree_type,
04574           ffecom_1 (BIT_NOT_EXPR, tree_type,
04575         convert (tree_type, integer_zero_node)),
04576           arg3_tree);
04577   /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
04578   mask_arg1
04579     = ffecom_3 (COND_EXPR, tree_type,
04580           ffecom_truth_value
04581           (ffecom_2 (NE_EXPR, integer_type_node,
04582          arg3_tree,
04583          TYPE_SIZE (uns_type))),
04584           mask_arg1,
04585           convert (tree_type, integer_zero_node));
04586   mask_arg1 = ffecom_save_tree (mask_arg1);
04587   masked_arg1
04588     = ffecom_2 (BIT_AND_EXPR, tree_type,
04589           arg1_tree,
04590           ffecom_1 (BIT_NOT_EXPR, tree_type,
04591         mask_arg1));
04592   masked_arg1 = ffecom_save_tree (masked_arg1);
04593   shift_neg
04594     = ffecom_2 (BIT_IOR_EXPR, tree_type,
04595           convert (tree_type,
04596              ffecom_2 (RSHIFT_EXPR, uns_type,
04597            convert (uns_type, masked_arg1),
04598            ffecom_1 (NEGATE_EXPR,
04599                integer_type_node,
04600                arg2_tree))),
04601           ffecom_2 (LSHIFT_EXPR, tree_type,
04602         arg1_tree,
04603         ffecom_2 (PLUS_EXPR, integer_type_node,
04604             arg2_tree,
04605             arg3_tree)));
04606   shift_pos
04607     = ffecom_2 (BIT_IOR_EXPR, tree_type,
04608           ffecom_2 (LSHIFT_EXPR, tree_type,
04609         arg1_tree,
04610         arg2_tree),
04611           convert (tree_type,
04612              ffecom_2 (RSHIFT_EXPR, uns_type,
04613            convert (uns_type, masked_arg1),
04614            ffecom_2 (MINUS_EXPR,
04615                integer_type_node,
04616                arg3_tree,
04617                arg2_tree))));
04618   expr_tree
04619     = ffecom_3 (COND_EXPR, tree_type,
04620           ffecom_truth_value
04621           (ffecom_2 (LT_EXPR, integer_type_node,
04622          arg2_tree,
04623          integer_zero_node)),
04624           shift_neg,
04625           shift_pos);
04626   expr_tree
04627     = ffecom_2 (BIT_IOR_EXPR, tree_type,
04628           ffecom_2 (BIT_AND_EXPR, tree_type,
04629         mask_arg1,
04630         arg1_tree),
04631           ffecom_2 (BIT_AND_EXPR, tree_type,
04632         ffecom_1 (BIT_NOT_EXPR, tree_type,
04633             mask_arg1),
04634         expr_tree));
04635   expr_tree
04636     = ffecom_3 (COND_EXPR, tree_type,
04637           ffecom_truth_value
04638           (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
04639          ffecom_2 (EQ_EXPR, integer_type_node,
04640              ffecom_1 (ABS_EXPR,
04641                  integer_type_node,
04642                  arg2_tree),
04643              arg3_tree),
04644          ffecom_2 (EQ_EXPR, integer_type_node,
04645              arg2_tree,
04646              integer_zero_node))),
04647           arg1_tree,
04648           expr_tree);
04649   /* Make sure SAVE_EXPRs get referenced early enough. */
04650   expr_tree
04651     = ffecom_2 (COMPOUND_EXPR, tree_type,
04652           convert (void_type_node, arg1_tree),
04653           ffecom_2 (COMPOUND_EXPR, tree_type,
04654         convert (void_type_node, arg2_tree),
04655         ffecom_2 (COMPOUND_EXPR, tree_type,
04656             convert (void_type_node,
04657                mask_arg1),
04658             ffecom_2 (COMPOUND_EXPR, tree_type,
04659                 convert (void_type_node,
04660                    masked_arg1),
04661                 expr_tree))));
04662   expr_tree
04663     = ffecom_2 (COMPOUND_EXPR, tree_type,
04664           convert (void_type_node,
04665              arg3_tree),
04666           expr_tree);
04667       }
04668       return expr_tree;
04669 
04670     case FFEINTRIN_impLOC:
04671       {
04672   tree arg1_tree = ffecom_expr (arg1);
04673 
04674   expr_tree
04675     = convert (tree_type,
04676          ffecom_1 (ADDR_EXPR,
04677              build_pointer_type (TREE_TYPE (arg1_tree)),
04678              arg1_tree));
04679       }
04680       return expr_tree;
04681 
04682     case FFEINTRIN_impMVBITS:
04683       {
04684   tree arg1_tree;
04685   tree arg2_tree;
04686   tree arg3_tree;
04687   ffebld arg4 = ffebld_head (ffebld_trail (list));
04688   tree arg4_tree;
04689   tree arg4_type;
04690   ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
04691   tree arg5_tree;
04692   tree prep_arg1;
04693   tree prep_arg4;
04694   tree arg5_plus_arg3;
04695 
04696   arg2_tree = convert (integer_type_node,
04697            ffecom_expr (arg2));
04698   arg3_tree = ffecom_save_tree (convert (integer_type_node,
04699                  ffecom_expr (arg3)));
04700   arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
04701   arg4_type = TREE_TYPE (arg4_tree);
04702 
04703   arg1_tree = ffecom_save_tree (convert (arg4_type,
04704                  ffecom_expr (arg1)));
04705 
04706   arg5_tree = ffecom_save_tree (convert (integer_type_node,
04707                  ffecom_expr (arg5)));
04708 
04709   prep_arg1
04710     = ffecom_2 (LSHIFT_EXPR, arg4_type,
04711           ffecom_2 (BIT_AND_EXPR, arg4_type,
04712         ffecom_2 (RSHIFT_EXPR, arg4_type,
04713             arg1_tree,
04714             arg2_tree),
04715         ffecom_1 (BIT_NOT_EXPR, arg4_type,
04716             ffecom_2 (LSHIFT_EXPR, arg4_type,
04717                 ffecom_1 (BIT_NOT_EXPR,
04718                     arg4_type,
04719                     convert
04720                     (arg4_type,
04721               integer_zero_node)),
04722                 arg3_tree))),
04723           arg5_tree);
04724   arg5_plus_arg3
04725     = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
04726           arg5_tree,
04727           arg3_tree));
04728   prep_arg4
04729     = ffecom_2 (LSHIFT_EXPR, arg4_type,
04730           ffecom_1 (BIT_NOT_EXPR, arg4_type,
04731         convert (arg4_type,
04732            integer_zero_node)),
04733           arg5_plus_arg3);
04734   /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
04735   prep_arg4
04736     = ffecom_3 (COND_EXPR, arg4_type,
04737           ffecom_truth_value
04738           (ffecom_2 (NE_EXPR, integer_type_node,
04739          arg5_plus_arg3,
04740          convert (TREE_TYPE (arg5_plus_arg3),
04741             TYPE_SIZE (arg4_type)))),
04742           prep_arg4,
04743           convert (arg4_type, integer_zero_node));
04744   prep_arg4
04745     = ffecom_2 (BIT_AND_EXPR, arg4_type,
04746           arg4_tree,
04747           ffecom_2 (BIT_IOR_EXPR, arg4_type,
04748         prep_arg4,
04749         ffecom_1 (BIT_NOT_EXPR, arg4_type,
04750             ffecom_2 (LSHIFT_EXPR, arg4_type,
04751                 ffecom_1 (BIT_NOT_EXPR,
04752                     arg4_type,
04753                     convert
04754                     (arg4_type,
04755               integer_zero_node)),
04756                 arg5_tree))));
04757   prep_arg1
04758     = ffecom_2 (BIT_IOR_EXPR, arg4_type,
04759           prep_arg1,
04760           prep_arg4);
04761   /* Fix up (twice), because LSHIFT_EXPR above
04762      can't shift over TYPE_SIZE.  */
04763   prep_arg1
04764     = ffecom_3 (COND_EXPR, arg4_type,
04765           ffecom_truth_value
04766           (ffecom_2 (NE_EXPR, integer_type_node,
04767          arg3_tree,
04768          convert (TREE_TYPE (arg3_tree),
04769             integer_zero_node))),
04770           prep_arg1,
04771           arg4_tree);
04772   prep_arg1
04773     = ffecom_3 (COND_EXPR, arg4_type,
04774           ffecom_truth_value
04775           (ffecom_2 (NE_EXPR, integer_type_node,
04776          arg3_tree,
04777          convert (TREE_TYPE (arg3_tree),
04778             TYPE_SIZE (arg4_type)))),
04779           prep_arg1,
04780           arg1_tree);
04781   expr_tree
04782     = ffecom_2s (MODIFY_EXPR, void_type_node,
04783            arg4_tree,
04784            prep_arg1);
04785   /* Make sure SAVE_EXPRs get referenced early enough. */
04786   expr_tree
04787     = ffecom_2 (COMPOUND_EXPR, void_type_node,
04788           arg1_tree,
04789           ffecom_2 (COMPOUND_EXPR, void_type_node,
04790         arg3_tree,
04791         ffecom_2 (COMPOUND_EXPR, void_type_node,
04792             arg5_tree,
04793             ffecom_2 (COMPOUND_EXPR, void_type_node,
04794                 arg5_plus_arg3,
04795                 expr_tree))));
04796   expr_tree
04797     = ffecom_2 (COMPOUND_EXPR, void_type_node,
04798           arg4_tree,
04799           expr_tree);
04800 
04801       }
04802       return expr_tree;
04803 
04804     case FFEINTRIN_impDERF:
04805     case FFEINTRIN_impERF:
04806     case FFEINTRIN_impDERFC:
04807     case FFEINTRIN_impERFC:
04808       break;
04809 
04810     case FFEINTRIN_impIARGC:
04811       /* extern int xargc; i__1 = xargc - 1; */
04812       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
04813           ffecom_tree_xargc_,
04814           convert (TREE_TYPE (ffecom_tree_xargc_),
04815              integer_one_node));
04816       return expr_tree;
04817 
04818     case FFEINTRIN_impSIGNAL_func:
04819     case FFEINTRIN_impSIGNAL_subr:
04820       {
04821   tree arg1_tree;
04822   tree arg2_tree;
04823   tree arg3_tree;
04824 
04825   arg1_tree = convert (ffecom_f2c_integer_type_node,
04826            ffecom_expr (arg1));
04827   arg1_tree = ffecom_1 (ADDR_EXPR,
04828             build_pointer_type (TREE_TYPE (arg1_tree)),
04829             arg1_tree);
04830 
04831   /* Pass procedure as a pointer to it, anything else by value.  */
04832   if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
04833     arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
04834   else
04835     arg2_tree = ffecom_ptr_to_expr (arg2);
04836   arg2_tree = convert (TREE_TYPE (null_pointer_node),
04837            arg2_tree);
04838 
04839   if (arg3 != NULL)
04840     arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
04841   else
04842     arg3_tree = NULL_TREE;
04843 
04844   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
04845   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
04846   TREE_CHAIN (arg1_tree) = arg2_tree;
04847 
04848   expr_tree
04849     = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
04850         ffecom_gfrt_kindtype (gfrt),
04851         FALSE,
04852         ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
04853          NULL_TREE :
04854          tree_type),
04855         arg1_tree,
04856         NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
04857         ffebld_nonter_hook (expr));
04858 
04859   if (arg3_tree != NULL_TREE)
04860     expr_tree
04861       = ffecom_modify (NULL_TREE, arg3_tree,
04862            convert (TREE_TYPE (arg3_tree),
04863               expr_tree));
04864       }
04865       return expr_tree;
04866 
04867     case FFEINTRIN_impALARM:
04868       {
04869   tree arg1_tree;
04870   tree arg2_tree;
04871   tree arg3_tree;
04872 
04873   arg1_tree = convert (ffecom_f2c_integer_type_node,
04874            ffecom_expr (arg1));
04875   arg1_tree = ffecom_1 (ADDR_EXPR,
04876             build_pointer_type (TREE_TYPE (arg1_tree)),
04877             arg1_tree);
04878 
04879   /* Pass procedure as a pointer to it, anything else by value.  */
04880   if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
04881     arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
04882   else
04883     arg2_tree = ffecom_ptr_to_expr (arg2);
04884   arg2_tree = convert (TREE_TYPE (null_pointer_node),
04885            arg2_tree);
04886 
04887   if (arg3 != NULL)
04888     arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
04889   else
04890     arg3_tree = NULL_TREE;
04891 
04892   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
04893   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
04894   TREE_CHAIN (arg1_tree) = arg2_tree;
04895 
04896   expr_tree
04897     = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
04898         ffecom_gfrt_kindtype (gfrt),
04899         FALSE,
04900         NULL_TREE,
04901         arg1_tree,
04902         NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
04903         ffebld_nonter_hook (expr));
04904 
04905   if (arg3_tree != NULL_TREE)
04906     expr_tree
04907       = ffecom_modify (NULL_TREE, arg3_tree,
04908            convert (TREE_TYPE (arg3_tree),
04909               expr_tree));
04910       }
04911       return expr_tree;
04912 
04913     case FFEINTRIN_impCHDIR_subr:
04914     case FFEINTRIN_impFDATE_subr:
04915     case FFEINTRIN_impFGET_subr:
04916     case FFEINTRIN_impFPUT_subr:
04917     case FFEINTRIN_impGETCWD_subr:
04918     case FFEINTRIN_impHOSTNM_subr:
04919     case FFEINTRIN_impSYSTEM_subr:
04920     case FFEINTRIN_impUNLINK_subr:
04921       {
04922   tree arg1_len = integer_zero_node;
04923   tree arg1_tree;
04924   tree arg2_tree;
04925 
04926   arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
04927 
04928   if (arg2 != NULL)
04929     arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
04930   else
04931     arg2_tree = NULL_TREE;
04932 
04933   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
04934   arg1_len = build_tree_list (NULL_TREE, arg1_len);
04935   TREE_CHAIN (arg1_tree) = arg1_len;
04936 
04937   expr_tree
04938     = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
04939         ffecom_gfrt_kindtype (gfrt),
04940         FALSE,
04941         NULL_TREE,
04942         arg1_tree,
04943         NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
04944         ffebld_nonter_hook (expr));
04945 
04946   if (arg2_tree != NULL_TREE)
04947     expr_tree
04948       = ffecom_modify (NULL_TREE, arg2_tree,
04949            convert (TREE_TYPE (arg2_tree),
04950               expr_tree));
04951       }
04952       return expr_tree;
04953 
04954     case FFEINTRIN_impEXIT:
04955       if (arg1 != NULL)
04956   break;
04957 
04958       expr_tree = build_tree_list (NULL_TREE,
04959            ffecom_1 (ADDR_EXPR,
04960                build_pointer_type
04961                (ffecom_integer_type_node),
04962                integer_zero_node));
04963 
04964       return
04965   ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
04966           ffecom_gfrt_kindtype (gfrt),
04967           FALSE,
04968           void_type_node,
04969           expr_tree,
04970           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
04971           ffebld_nonter_hook (expr));
04972 
04973     case FFEINTRIN_impFLUSH:
04974       if (arg1 == NULL)
04975   gfrt = FFECOM_gfrtFLUSH;
04976       else
04977   gfrt = FFECOM_gfrtFLUSH1;
04978       break;
04979 
04980     case FFEINTRIN_impCHMOD_subr:
04981     case FFEINTRIN_impLINK_subr:
04982     case FFEINTRIN_impRENAME_subr:
04983     case FFEINTRIN_impSYMLNK_subr:
04984       {
04985   tree arg1_len = integer_zero_node;
04986   tree arg1_tree;
04987   tree arg2_len = integer_zero_node;
04988   tree arg2_tree;
04989   tree arg3_tree;
04990 
04991   arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
04992   arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
04993   if (arg3 != NULL)
04994     arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
04995   else
04996     arg3_tree = NULL_TREE;
04997 
04998   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
04999   arg1_len = build_tree_list (NULL_TREE, arg1_len);
05000   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
05001   arg2_len = build_tree_list (NULL_TREE, arg2_len);
05002   TREE_CHAIN (arg1_tree) = arg2_tree;
05003   TREE_CHAIN (arg2_tree) = arg1_len;
05004   TREE_CHAIN (arg1_len) = arg2_len;
05005   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05006           ffecom_gfrt_kindtype (gfrt),
05007           FALSE,
05008           NULL_TREE,
05009           arg1_tree,
05010           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
05011           ffebld_nonter_hook (expr));
05012   if (arg3_tree != NULL_TREE)
05013     expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
05014              convert (TREE_TYPE (arg3_tree),
05015                 expr_tree));
05016       }
05017       return expr_tree;
05018 
05019     case FFEINTRIN_impLSTAT_subr:
05020     case FFEINTRIN_impSTAT_subr:
05021       {
05022   tree arg1_len = integer_zero_node;
05023   tree arg1_tree;
05024   tree arg2_tree;
05025   tree arg3_tree;
05026 
05027   arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
05028 
05029   arg2_tree = ffecom_ptr_to_expr (arg2);
05030 
05031   if (arg3 != NULL)
05032     arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
05033   else
05034     arg3_tree = NULL_TREE;
05035 
05036   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
05037   arg1_len = build_tree_list (NULL_TREE, arg1_len);
05038   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
05039   TREE_CHAIN (arg1_tree) = arg2_tree;
05040   TREE_CHAIN (arg2_tree) = arg1_len;
05041   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05042           ffecom_gfrt_kindtype (gfrt),
05043           FALSE,
05044           NULL_TREE,
05045           arg1_tree,
05046           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
05047           ffebld_nonter_hook (expr));
05048   if (arg3_tree != NULL_TREE)
05049     expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
05050              convert (TREE_TYPE (arg3_tree),
05051                 expr_tree));
05052       }
05053       return expr_tree;
05054 
05055     case FFEINTRIN_impFGETC_subr:
05056     case FFEINTRIN_impFPUTC_subr:
05057       {
05058   tree arg1_tree;
05059   tree arg2_tree;
05060   tree arg2_len = integer_zero_node;
05061   tree arg3_tree;
05062 
05063   arg1_tree = convert (ffecom_f2c_integer_type_node,
05064            ffecom_expr (arg1));
05065   arg1_tree = ffecom_1 (ADDR_EXPR,
05066             build_pointer_type (TREE_TYPE (arg1_tree)),
05067             arg1_tree);
05068 
05069   arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
05070   if (arg3 != NULL)
05071     arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
05072   else
05073     arg3_tree = NULL_TREE;
05074 
05075   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
05076   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
05077   arg2_len = build_tree_list (NULL_TREE, arg2_len);
05078   TREE_CHAIN (arg1_tree) = arg2_tree;
05079   TREE_CHAIN (arg2_tree) = arg2_len;
05080 
05081   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05082           ffecom_gfrt_kindtype (gfrt),
05083           FALSE,
05084           NULL_TREE,
05085           arg1_tree,
05086           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
05087           ffebld_nonter_hook (expr));
05088   if (arg3_tree != NULL_TREE)
05089     expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
05090              convert (TREE_TYPE (arg3_tree),
05091                 expr_tree));
05092       }
05093       return expr_tree;
05094 
05095     case FFEINTRIN_impFSTAT_subr:
05096       {
05097   tree arg1_tree;
05098   tree arg2_tree;
05099   tree arg3_tree;
05100 
05101   arg1_tree = convert (ffecom_f2c_integer_type_node,
05102            ffecom_expr (arg1));
05103   arg1_tree = ffecom_1 (ADDR_EXPR,
05104             build_pointer_type (TREE_TYPE (arg1_tree)),
05105             arg1_tree);
05106 
05107   arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
05108            ffecom_ptr_to_expr (arg2));
05109 
05110   if (arg3 == NULL)
05111     arg3_tree = NULL_TREE;
05112   else
05113     arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
05114 
05115   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
05116   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
05117   TREE_CHAIN (arg1_tree) = arg2_tree;
05118   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05119           ffecom_gfrt_kindtype (gfrt),
05120           FALSE,
05121           NULL_TREE,
05122           arg1_tree,
05123           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
05124           ffebld_nonter_hook (expr));
05125   if (arg3_tree != NULL_TREE) {
05126     expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
05127              convert (TREE_TYPE (arg3_tree),
05128                 expr_tree));
05129   }
05130       }
05131       return expr_tree;
05132 
05133     case FFEINTRIN_impKILL_subr:
05134       {
05135   tree arg1_tree;
05136   tree arg2_tree;
05137   tree arg3_tree;
05138 
05139   arg1_tree = convert (ffecom_f2c_integer_type_node,
05140            ffecom_expr (arg1));
05141   arg1_tree = ffecom_1 (ADDR_EXPR,
05142             build_pointer_type (TREE_TYPE (arg1_tree)),
05143             arg1_tree);
05144 
05145   arg2_tree = convert (ffecom_f2c_integer_type_node,
05146            ffecom_expr (arg2));
05147   arg2_tree = ffecom_1 (ADDR_EXPR,
05148             build_pointer_type (TREE_TYPE (arg2_tree)),
05149             arg2_tree);
05150 
05151   if (arg3 == NULL)
05152     arg3_tree = NULL_TREE;
05153   else
05154     arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
05155 
05156   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
05157   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
05158   TREE_CHAIN (arg1_tree) = arg2_tree;
05159   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05160           ffecom_gfrt_kindtype (gfrt),
05161           FALSE,
05162           NULL_TREE,
05163           arg1_tree,
05164           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
05165           ffebld_nonter_hook (expr));
05166   if (arg3_tree != NULL_TREE) {
05167     expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
05168              convert (TREE_TYPE (arg3_tree),
05169                 expr_tree));
05170   }
05171       }
05172       return expr_tree;
05173 
05174     case FFEINTRIN_impCTIME_subr:
05175     case FFEINTRIN_impTTYNAM_subr:
05176       {
05177   tree arg1_len = integer_zero_node;
05178   tree arg1_tree;
05179   tree arg2_tree;
05180 
05181   arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
05182 
05183   arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
05184             ffecom_f2c_longint_type_node :
05185             ffecom_f2c_integer_type_node),
05186            ffecom_expr (arg1));
05187   arg2_tree = ffecom_1 (ADDR_EXPR,
05188             build_pointer_type (TREE_TYPE (arg2_tree)),
05189             arg2_tree);
05190 
05191   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
05192   arg1_len = build_tree_list (NULL_TREE, arg1_len);
05193   arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
05194   TREE_CHAIN (arg1_len) = arg2_tree;
05195   TREE_CHAIN (arg1_tree) = arg1_len;
05196 
05197   expr_tree
05198     = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05199         ffecom_gfrt_kindtype (gfrt),
05200         FALSE,
05201         NULL_TREE,
05202         arg1_tree,
05203         NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
05204         ffebld_nonter_hook (expr));
05205   TREE_SIDE_EFFECTS (expr_tree) = 1;
05206       }
05207       return expr_tree;
05208 
05209     case FFEINTRIN_impIRAND:
05210     case FFEINTRIN_impRAND:
05211       /* Arg defaults to 0 (normal random case) */
05212       {
05213   tree arg1_tree;
05214 
05215   if (arg1 == NULL)
05216     arg1_tree = ffecom_integer_zero_node;
05217   else
05218     arg1_tree = ffecom_expr (arg1);
05219   arg1_tree = convert (ffecom_f2c_integer_type_node,
05220            arg1_tree);
05221   arg1_tree = ffecom_1 (ADDR_EXPR,
05222             build_pointer_type (TREE_TYPE (arg1_tree)),
05223             arg1_tree);
05224   arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
05225 
05226   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05227           ffecom_gfrt_kindtype (gfrt),
05228           FALSE,
05229           ((codegen_imp == FFEINTRIN_impIRAND) ?
05230            ffecom_f2c_integer_type_node :
05231            ffecom_f2c_real_type_node),
05232           arg1_tree,
05233           dest_tree, dest, dest_used,
05234           NULL_TREE, TRUE,
05235           ffebld_nonter_hook (expr));
05236       }
05237       return expr_tree;
05238 
05239     case FFEINTRIN_impFTELL_subr:
05240     case FFEINTRIN_impUMASK_subr:
05241       {
05242   tree arg1_tree;
05243   tree arg2_tree;
05244 
05245   arg1_tree = convert (ffecom_f2c_integer_type_node,
05246            ffecom_expr (arg1));
05247   arg1_tree = ffecom_1 (ADDR_EXPR,
05248             build_pointer_type (TREE_TYPE (arg1_tree)),
05249             arg1_tree);
05250 
05251   if (arg2 == NULL)
05252     arg2_tree = NULL_TREE;
05253   else
05254     arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
05255 
05256   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05257           ffecom_gfrt_kindtype (gfrt),
05258           FALSE,
05259           NULL_TREE,
05260           build_tree_list (NULL_TREE, arg1_tree),
05261           NULL_TREE, NULL, NULL, NULL_TREE,
05262           TRUE,
05263           ffebld_nonter_hook (expr));
05264   if (arg2_tree != NULL_TREE) {
05265     expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
05266              convert (TREE_TYPE (arg2_tree),
05267                 expr_tree));
05268   }
05269       }
05270       return expr_tree;
05271 
05272     case FFEINTRIN_impCPU_TIME:
05273     case FFEINTRIN_impSECOND_subr:
05274       {
05275   tree arg1_tree;
05276 
05277   arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
05278 
05279   expr_tree
05280     = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05281         ffecom_gfrt_kindtype (gfrt),
05282         FALSE,
05283         NULL_TREE,
05284         NULL_TREE,
05285         NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
05286         ffebld_nonter_hook (expr));
05287 
05288   expr_tree
05289     = ffecom_modify (NULL_TREE, arg1_tree,
05290          convert (TREE_TYPE (arg1_tree),
05291             expr_tree));
05292       }
05293       return expr_tree;
05294 
05295     case FFEINTRIN_impDTIME_subr:
05296     case FFEINTRIN_impETIME_subr:
05297       {
05298   tree arg1_tree;
05299   tree result_tree;
05300 
05301   result_tree = ffecom_expr_w (NULL_TREE, arg2);
05302 
05303   arg1_tree = ffecom_ptr_to_expr (arg1);
05304 
05305   expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
05306           ffecom_gfrt_kindtype (gfrt),
05307           FALSE,
05308           NULL_TREE,
05309           build_tree_list (NULL_TREE, arg1_tree),
05310           NULL_TREE, NULL, NULL, NULL_TREE,
05311           TRUE,
05312           ffebld_nonter_hook (expr));
05313   expr_tree = ffecom_modify (NULL_TREE, result_tree,
05314            convert (TREE_TYPE (result_tree),
05315               expr_tree));
05316       }
05317       return expr_tree;
05318 
05319       /* Straightforward calls of libf2c routines: */
05320     case FFEINTRIN_impABORT:
05321     case FFEINTRIN_impACCESS:
05322     case FFEINTRIN_impBESJ0:
05323     case FFEINTRIN_impBESJ1:
05324     case FFEINTRIN_impBESJN:
05325     case FFEINTRIN_impBESY0:
05326     case FFEINTRIN_impBESY1:
05327     case FFEINTRIN_impBESYN:
05328     case FFEINTRIN_impCHDIR_func:
05329     case FFEINTRIN_impCHMOD_func:
05330     case FFEINTRIN_impDATE:
05331     case FFEINTRIN_impDATE_AND_TIME:
05332     case FFEINTRIN_impDBESJ0:
05333     case FFEINTRIN_impDBESJ1:
05334     case FFEINTRIN_impDBESJN:
05335     case FFEINTRIN_impDBESY0:
05336     case FFEINTRIN_impDBESY1:
05337     case FFEINTRIN_impDBESYN:
05338     case FFEINTRIN_impDTIME_func:
05339     case FFEINTRIN_impETIME_func:
05340     case FFEINTRIN_impFGETC_func:
05341     case FFEINTRIN_impFGET_func:
05342     case FFEINTRIN_impFNUM:
05343     case FFEINTRIN_impFPUTC_func:
05344     case FFEINTRIN_impFPUT_func:
05345     case FFEINTRIN_impFSEEK:
05346     case FFEINTRIN_impFSTAT_func:
05347     case FFEINTRIN_impFTELL_func:
05348     case FFEINTRIN_impGERROR:
05349     case FFEINTRIN_impGETARG:
05350     case FFEINTRIN_impGETCWD_func:
05351     case FFEINTRIN_impGETENV:
05352     case FFEINTRIN_impGETGID:
05353     case FFEINTRIN_impGETLOG:
05354     case FFEINTRIN_impGETPID:
05355     case FFEINTRIN_impGETUID:
05356     case FFEINTRIN_impGMTIME:
05357     case FFEINTRIN_impHOSTNM_func:
05358     case FFEINTRIN_impIDATE_unix:
05359     case FFEINTRIN_impIDATE_vxt:
05360     case FFEINTRIN_impIERRNO:
05361     case FFEINTRIN_impISATTY:
05362     case FFEINTRIN_impITIME:
05363     case FFEINTRIN_impKILL_func:
05364     case FFEINTRIN_impLINK_func:
05365     case FFEINTRIN_impLNBLNK:
05366     case FFEINTRIN_impLSTAT_func:
05367     case FFEINTRIN_impLTIME:
05368     case FFEINTRIN_impMCLOCK8:
05369     case FFEINTRIN_impMCLOCK:
05370     case FFEINTRIN_impPERROR:
05371     case FFEINTRIN_impRENAME_func:
05372     case FFEINTRIN_impSECNDS:
05373     case FFEINTRIN_impSECOND_func:
05374     case FFEINTRIN_impSLEEP:
05375     case FFEINTRIN_impSRAND:
05376     case FFEINTRIN_impSTAT_func:
05377     case FFEINTRIN_impSYMLNK_func:
05378     case FFEINTRIN_impSYSTEM_CLOCK:
05379     case FFEINTRIN_impSYSTEM_func:
05380     case FFEINTRIN_impTIME8:
05381     case FFEINTRIN_impTIME_unix:
05382     case FFEINTRIN_impTIME_vxt:
05383     case FFEINTRIN_impUMASK_func:
05384     case FFEINTRIN_impUNLINK_func:
05385       break;
05386 
05387     case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
05388     case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
05389     case FFEINTRIN_impTTYNAM_func:  /* CHARACTER functions not handled here. */
05390     case FFEINTRIN_impNONE:
05391     case FFEINTRIN_imp:   /* Hush up gcc warning. */
05392       fprintf (stderr, "No %s implementation.\n",
05393          ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
05394       assert ("unimplemented intrinsic" == NULL);
05395       return error_mark_node;
05396     }
05397 
05398   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
05399 
05400   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
05401             ffebld_right (expr));
05402 
05403   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
05404            (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
05405            tree_type,
05406            expr_tree, dest_tree, dest, dest_used,
05407            NULL_TREE, TRUE,
05408            ffebld_nonter_hook (expr));
05409 
05410   /* See bottom of this file for f2c transforms used to determine
05411      many of the above implementations.  The info seems to confuse
05412      Emacs's C mode indentation, which is why it's been moved to
05413      the bottom of this source file.  */
05414 }
05415 
05416 /* For power (exponentiation) where right-hand operand is type INTEGER,
05417    generate in-line code to do it the fast way (which, if the operand
05418    is a constant, might just mean a series of multiplies).  */
05419 
05420 static tree
05421 ffecom_expr_power_integer_ (ffebld expr)
05422 {
05423   tree l = ffecom_expr (ffebld_left (expr));
05424   tree r = ffecom_expr (ffebld_right (expr));
05425   tree ltype = TREE_TYPE (l);
05426   tree rtype = TREE_TYPE (r);
05427   tree result = NULL_TREE;
05428 
05429   if (l == error_mark_node
05430       || r == error_mark_node)
05431     return error_mark_node;
05432 
05433   if (TREE_CODE (r) == INTEGER_CST)
05434     {
05435       int sgn = tree_int_cst_sgn (r);
05436 
05437       if (sgn == 0)
05438   return convert (ltype, integer_one_node);
05439 
05440       if ((TREE_CODE (ltype) == INTEGER_TYPE)
05441     && (sgn < 0))
05442   {
05443     /* Reciprocal of integer is either 0, -1, or 1, so after
05444        calculating that (which we leave to the back end to do
05445        or not do optimally), don't bother with any multiplying.  */
05446 
05447     result = ffecom_tree_divide_ (ltype,
05448           convert (ltype, integer_one_node),
05449           l,
05450           NULL_TREE, NULL, NULL, NULL_TREE);
05451     r = ffecom_1 (NEGATE_EXPR,
05452       rtype,
05453       r);
05454     if ((TREE_INT_CST_LOW (r) & 1) == 0)
05455       result = ffecom_1 (ABS_EXPR, rtype,
05456              result);
05457   }
05458 
05459       /* Generate appropriate series of multiplies, preceded
05460    by divide if the exponent is negative.  */
05461 
05462       l = save_expr (l);
05463 
05464       if (sgn < 0)
05465   {
05466     l = ffecom_tree_divide_ (ltype,
05467            convert (ltype, integer_one_node),
05468            l,
05469            NULL_TREE, NULL, NULL,
05470            ffebld_nonter_hook (expr));
05471     r = ffecom_1 (NEGATE_EXPR, rtype, r);
05472     assert (TREE_CODE (r) == INTEGER_CST);
05473 
05474     if (tree_int_cst_sgn (r) < 0)
05475       {     /* The "most negative" number.  */
05476         r = ffecom_1 (NEGATE_EXPR, rtype,
05477           ffecom_2 (RSHIFT_EXPR, rtype,
05478               r,
05479               integer_one_node));
05480         l = save_expr (l);
05481         l = ffecom_2 (MULT_EXPR, ltype,
05482           l,
05483           l);
05484       }
05485   }
05486 
05487       for (;;)
05488   {
05489     if (TREE_INT_CST_LOW (r) & 1)
05490       {
05491         if (result == NULL_TREE)
05492     result = l;
05493         else
05494     result = ffecom_2 (MULT_EXPR, ltype,
05495            result,
05496            l);
05497       }
05498 
05499     r = ffecom_2 (RSHIFT_EXPR, rtype,
05500       r,
05501       integer_one_node);
05502     if (integer_zerop (r))
05503       break;
05504     assert (TREE_CODE (r) == INTEGER_CST);
05505 
05506     l = save_expr (l);
05507     l = ffecom_2 (MULT_EXPR, ltype,
05508       l,
05509       l);
05510   }
05511       return result;
05512     }
05513 
05514   /* Though rhs isn't a constant, in-line code cannot be expanded
05515      while transforming dummies
05516      because the back end cannot be easily convinced to generate
05517      stores (MODIFY_EXPR), handle temporaries, and so on before
05518      all the appropriate rtx's have been generated for things like
05519      dummy args referenced in rhs -- which doesn't happen until
05520      store_parm_decls() is called (expand_function_start, I believe,
05521      does the actual rtx-stuffing of PARM_DECLs).
05522 
05523      So, in this case, let the caller generate the call to the
05524      run-time-library function to evaluate the power for us.  */
05525 
05526   if (ffecom_transform_only_dummies_)
05527     return NULL_TREE;
05528 
05529   /* Right-hand operand not a constant, expand in-line code to figure
05530      out how to do the multiplies, &c.
05531 
05532      The returned expression is expressed this way in GNU C, where l and
05533      r are the "inputs":
05534 
05535      ({ typeof (r) rtmp = r;
05536   typeof (l) ltmp = l;
05537   typeof (l) result;
05538 
05539   if (rtmp == 0)
05540     result = 1;
05541   else
05542     {
05543       if ((basetypeof (l) == basetypeof (int))
05544     && (rtmp < 0))
05545         {
05546           result = ((typeof (l)) 1) / ltmp;
05547           if ((ltmp < 0) && (((-rtmp) & 1) == 0))
05548       result = -result;
05549         }
05550       else
05551         {
05552     result = 1;
05553     if ((basetypeof (l) != basetypeof (int))
05554         && (rtmp < 0))
05555       {
05556         ltmp = ((typeof (l)) 1) / ltmp;
05557         rtmp = -rtmp;
05558         if (rtmp < 0)
05559           {
05560             rtmp = -(rtmp >> 1);
05561             ltmp *= ltmp;
05562           }
05563       }
05564     for (;;)
05565       {
05566         if (rtmp & 1)
05567           result *= ltmp;
05568         if ((rtmp >>= 1) == 0)
05569           break;
05570         ltmp *= ltmp;
05571       }
05572         }
05573     }
05574   result;
05575      })
05576 
05577      Note that some of the above is compile-time collapsable, such as
05578      the first part of the if statements that checks the base type of
05579      l against int.  The if statements are phrased that way to suggest
05580      an easy way to generate the if/else constructs here, knowing that
05581      the back end should (and probably does) eliminate the resulting
05582      dead code (either the int case or the non-int case), something
05583      it couldn't do without the redundant phrasing, requiring explicit
05584      dead-code elimination here, which would be kind of difficult to
05585      read.  */
05586 
05587   {
05588     tree rtmp;
05589     tree ltmp;
05590     tree divide;
05591     tree basetypeof_l_is_int;
05592     tree se;
05593     tree t;
05594 
05595     basetypeof_l_is_int
05596       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
05597 
05598     se = expand_start_stmt_expr (/*has_scope=*/1);
05599 
05600     ffecom_start_compstmt ();
05601 
05602 #ifndef HAHA
05603     rtmp = ffecom_make_tempvar ("power_r", rtype,
05604         FFETARGET_charactersizeNONE, -1);
05605     ltmp = ffecom_make_tempvar ("power_l", ltype,
05606         FFETARGET_charactersizeNONE, -1);
05607     result = ffecom_make_tempvar ("power_res", ltype,
05608           FFETARGET_charactersizeNONE, -1);
05609     if (TREE_CODE (ltype) == COMPLEX_TYPE
05610   || TREE_CODE (ltype) == RECORD_TYPE)
05611       divide = ffecom_make_tempvar ("power_div", ltype,
05612             FFETARGET_charactersizeNONE, -1);
05613     else
05614       divide = NULL_TREE;
05615 #else  /* HAHA */
05616     {
05617       tree hook;
05618 
05619       hook = ffebld_nonter_hook (expr);
05620       assert (hook);
05621       assert (TREE_CODE (hook) == TREE_VEC);
05622       assert (TREE_VEC_LENGTH (hook) == 4);
05623       rtmp = TREE_VEC_ELT (hook, 0);
05624       ltmp = TREE_VEC_ELT (hook, 1);
05625       result = TREE_VEC_ELT (hook, 2);
05626       divide = TREE_VEC_ELT (hook, 3);
05627       if (TREE_CODE (ltype) == COMPLEX_TYPE
05628     || TREE_CODE (ltype) == RECORD_TYPE)
05629   assert (divide);
05630       else
05631   assert (! divide);
05632     }
05633 #endif  /* HAHA */
05634 
05635     expand_expr_stmt (ffecom_modify (void_type_node,
05636              rtmp,
05637              r));
05638     expand_expr_stmt (ffecom_modify (void_type_node,
05639              ltmp,
05640              l));
05641     expand_start_cond (ffecom_truth_value
05642            (ffecom_2 (EQ_EXPR, integer_type_node,
05643           rtmp,
05644           convert (rtype, integer_zero_node))),
05645            0);
05646     expand_expr_stmt (ffecom_modify (void_type_node,
05647              result,
05648              convert (ltype, integer_one_node)));
05649     expand_start_else ();
05650     if (! integer_zerop (basetypeof_l_is_int))
05651       {
05652   expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
05653              rtmp,
05654              convert (rtype,
05655                 integer_zero_node)),
05656          0);
05657   expand_expr_stmt (ffecom_modify (void_type_node,
05658            result,
05659            ffecom_tree_divide_
05660            (ltype,
05661             convert (ltype, integer_one_node),
05662             ltmp,
05663             NULL_TREE, NULL, NULL,
05664             divide)));
05665   expand_start_cond (ffecom_truth_value
05666          (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
05667               ffecom_2 (LT_EXPR, integer_type_node,
05668             ltmp,
05669             convert (ltype,
05670                integer_zero_node)),
05671               ffecom_2 (EQ_EXPR, integer_type_node,
05672             ffecom_2 (BIT_AND_EXPR,
05673                 rtype,
05674                 ffecom_1 (NEGATE_EXPR,
05675                     rtype,
05676                     rtmp),
05677                 convert (rtype,
05678                    integer_one_node)),
05679             convert (rtype,
05680                integer_zero_node)))),
05681          0);
05682   expand_expr_stmt (ffecom_modify (void_type_node,
05683            result,
05684            ffecom_1 (NEGATE_EXPR,
05685                ltype,
05686                result)));
05687   expand_end_cond ();
05688   expand_start_else ();
05689       }
05690     expand_expr_stmt (ffecom_modify (void_type_node,
05691              result,
05692              convert (ltype, integer_one_node)));
05693     expand_start_cond (ffecom_truth_value
05694            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
05695           ffecom_truth_value_invert
05696           (basetypeof_l_is_int),
05697           ffecom_2 (LT_EXPR, integer_type_node,
05698               rtmp,
05699               convert (rtype,
05700                  integer_zero_node)))),
05701            0);
05702     expand_expr_stmt (ffecom_modify (void_type_node,
05703              ltmp,
05704              ffecom_tree_divide_
05705              (ltype,
05706               convert (ltype, integer_one_node),
05707               ltmp,
05708               NULL_TREE, NULL, NULL,
05709               divide)));
05710     expand_expr_stmt (ffecom_modify (void_type_node,
05711              rtmp,
05712              ffecom_1 (NEGATE_EXPR, rtype,
05713                  rtmp)));
05714     expand_start_cond (ffecom_truth_value
05715            (ffecom_2 (LT_EXPR, integer_type_node,
05716           rtmp,
05717           convert (rtype, integer_zero_node))),
05718            0);
05719     expand_expr_stmt (ffecom_modify (void_type_node,
05720              rtmp,
05721              ffecom_1 (NEGATE_EXPR, rtype,
05722                  ffecom_2 (RSHIFT_EXPR,
05723                rtype,
05724                rtmp,
05725                integer_one_node))));
05726     expand_expr_stmt (ffecom_modify (void_type_node,
05727              ltmp,
05728              ffecom_2 (MULT_EXPR, ltype,
05729                  ltmp,
05730                  ltmp)));
05731     expand_end_cond ();
05732     expand_end_cond ();
05733     expand_start_loop (1);
05734     expand_start_cond (ffecom_truth_value
05735            (ffecom_2 (BIT_AND_EXPR, rtype,
05736           rtmp,
05737           convert (rtype, integer_one_node))),
05738            0);
05739     expand_expr_stmt (ffecom_modify (void_type_node,
05740              result,
05741              ffecom_2 (MULT_EXPR, ltype,
05742                  result,
05743                  ltmp)));
05744     expand_end_cond ();
05745     expand_exit_loop_if_false (NULL,
05746              ffecom_truth_value
05747              (ffecom_modify (rtype,
05748                  rtmp,
05749                  ffecom_2 (RSHIFT_EXPR,
05750                rtype,
05751                rtmp,
05752                integer_one_node))));
05753     expand_expr_stmt (ffecom_modify (void_type_node,
05754              ltmp,
05755              ffecom_2 (MULT_EXPR, ltype,
05756                  ltmp,
05757                  ltmp)));
05758     expand_end_loop ();
05759     expand_end_cond ();
05760     if (!integer_zerop (basetypeof_l_is_int))
05761       expand_end_cond ();
05762     expand_expr_stmt (result);
05763 
05764     t = ffecom_end_compstmt ();
05765 
05766     result = expand_end_stmt_expr (se);
05767 
05768     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
05769 
05770     if (TREE_CODE (t) == BLOCK)
05771       {
05772   /* Make a BIND_EXPR for the BLOCK already made.  */
05773   result = build (BIND_EXPR, TREE_TYPE (result),
05774       NULL_TREE, result, t);
05775   /* Remove the block from the tree at this point.
05776      It gets put back at the proper place
05777      when the BIND_EXPR is expanded.  */
05778   delete_block (t);
05779       }
05780     else
05781       result = t;
05782   }
05783 
05784   return result;
05785 }
05786 
05787 /* ffecom_expr_transform_ -- Transform symbols in expr
05788 
05789    ffebld expr;  // FFE expression.
05790    ffecom_expr_transform_ (expr);
05791 
05792    Recursive descent on expr while transforming any untransformed SYMTERs.  */
05793 
05794 static void
05795 ffecom_expr_transform_ (ffebld expr)
05796 {
05797   tree t;
05798   ffesymbol s;
05799 
05800  tail_recurse:
05801 
05802   if (expr == NULL)
05803     return;
05804 
05805   switch (ffebld_op (expr))
05806     {
05807     case FFEBLD_opSYMTER:
05808       s = ffebld_symter (expr);
05809       t = ffesymbol_hook (s).decl_tree;
05810       if ((t == NULL_TREE)
05811     && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
05812         || ((ffesymbol_where (s) != FFEINFO_whereNONE)
05813       && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
05814   {
05815     s = ffecom_sym_transform_ (s);
05816     t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
05817                DIMENSION expr? */
05818   }
05819       break;      /* Ok if (t == NULL) here. */
05820 
05821     case FFEBLD_opITEM:
05822       ffecom_expr_transform_ (ffebld_head (expr));
05823       expr = ffebld_trail (expr);
05824       goto tail_recurse;  /* :::::::::::::::::::: */
05825 
05826     default:
05827       break;
05828     }
05829 
05830   switch (ffebld_arity (expr))
05831     {
05832     case 2:
05833       ffecom_expr_transform_ (ffebld_left (expr));
05834       expr = ffebld_right (expr);
05835       goto tail_recurse;  /* :::::::::::::::::::: */
05836 
05837     case 1:
05838       expr = ffebld_left (expr);
05839       goto tail_recurse;  /* :::::::::::::::::::: */
05840 
05841     default:
05842       break;
05843     }
05844 
05845   return;
05846 }
05847 
05848 /* Make a type based on info in live f2c.h file.  */
05849 
05850 static void
05851 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
05852 {
05853   switch (tcode)
05854     {
05855     case FFECOM_f2ccodeCHAR:
05856       *type = make_signed_type (CHAR_TYPE_SIZE);
05857       break;
05858 
05859     case FFECOM_f2ccodeSHORT:
05860       *type = make_signed_type (SHORT_TYPE_SIZE);
05861       break;
05862 
05863     case FFECOM_f2ccodeINT:
05864       *type = make_signed_type (INT_TYPE_SIZE);
05865       break;
05866 
05867     case FFECOM_f2ccodeLONG:
05868       *type = make_signed_type (LONG_TYPE_SIZE);
05869       break;
05870 
05871     case FFECOM_f2ccodeLONGLONG:
05872       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
05873       break;
05874 
05875     case FFECOM_f2ccodeCHARPTR:
05876       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
05877           ? signed_char_type_node
05878           : unsigned_char_type_node);
05879       break;
05880 
05881     case FFECOM_f2ccodeFLOAT:
05882       *type = make_node (REAL_TYPE);
05883       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
05884       layout_type (*type);
05885       break;
05886 
05887     case FFECOM_f2ccodeDOUBLE:
05888       *type = make_node (REAL_TYPE);
05889       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
05890       layout_type (*type);
05891       break;
05892 
05893     case FFECOM_f2ccodeLONGDOUBLE:
05894       *type = make_node (REAL_TYPE);
05895       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
05896       layout_type (*type);
05897       break;
05898 
05899     case FFECOM_f2ccodeTWOREALS:
05900       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
05901       break;
05902 
05903     case FFECOM_f2ccodeTWODOUBLEREALS:
05904       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
05905       break;
05906 
05907     default:
05908       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
05909       *type = error_mark_node;
05910       return;
05911     }
05912 
05913   pushdecl (build_decl (TYPE_DECL,
05914       ffecom_get_invented_identifier ("__g77_f2c_%s", name),
05915       *type));
05916 }
05917 
05918 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
05919    given size.  */
05920 
05921 static void
05922 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
05923         int code)
05924 {
05925   int j;
05926   tree t;
05927 
05928   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
05929     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
05930   && compare_tree_int (TYPE_SIZE (t), size) == 0)
05931       {
05932   assert (code != -1);
05933   ffecom_f2c_typecode_[bt][j] = code;
05934   code = -1;
05935       }
05936 }
05937 
05938 /* Finish up globals after doing all program units in file
05939 
05940    Need to handle only uninitialized COMMON areas.  */
05941 
05942 static ffeglobal
05943 ffecom_finish_global_ (ffeglobal global)
05944 {
05945   tree cbtype;
05946   tree cbt;
05947   tree size;
05948 
05949   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
05950       return global;
05951 
05952   if (ffeglobal_common_init (global))
05953       return global;
05954 
05955   cbt = ffeglobal_hook (global);
05956   if ((cbt == NULL_TREE)
05957       || !ffeglobal_common_have_size (global))
05958     return global;    /* No need to make common, never ref'd. */
05959 
05960   DECL_EXTERNAL (cbt) = 0;
05961 
05962   /* Give the array a size now.  */
05963 
05964   size = build_int_2 ((ffeglobal_common_size (global)
05965           + ffeglobal_common_pad (global)) - 1,
05966           0);
05967 
05968   cbtype = TREE_TYPE (cbt);
05969   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
05970              integer_zero_node,
05971              size);
05972   if (!TREE_TYPE (size))
05973     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
05974   layout_type (cbtype);
05975 
05976   cbt = start_decl (cbt, FALSE);
05977   assert (cbt == ffeglobal_hook (global));
05978 
05979   finish_decl (cbt, NULL_TREE, FALSE);
05980 
05981   return global;
05982 }
05983 
05984 /* Finish up any untransformed symbols.  */
05985 
05986 static ffesymbol
05987 ffecom_finish_symbol_transform_ (ffesymbol s)
05988 {
05989   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
05990     return s;
05991 
05992   /* It's easy to know to transform an untransformed symbol, to make sure
05993      we put out debugging info for it.  But COMMON variables, unlike
05994      EQUIVALENCE ones, aren't given declarations in addition to the
05995      tree expressions that specify offsets, because COMMON variables
05996      can be referenced in the outer scope where only dummy arguments
05997      (PARM_DECLs) should really be seen.  To be safe, just don't do any
05998      VAR_DECLs for COMMON variables when we transform them for real
05999      use, and therefore we do all the VAR_DECL creating here.  */
06000 
06001   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
06002     {
06003       if (ffesymbol_kind (s) != FFEINFO_kindNONE
06004     || (ffesymbol_where (s) != FFEINFO_whereNONE
06005         && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
06006         && ffesymbol_where (s) != FFEINFO_whereDUMMY))
06007   /* Not transformed, and not CHARACTER*(*), and not a dummy
06008      argument, which can happen only if the entry point names
06009      it "rides in on" are all invalidated for other reasons.  */
06010   s = ffecom_sym_transform_ (s);
06011     }
06012 
06013   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
06014       && (ffesymbol_hook (s).decl_tree != error_mark_node))
06015     {
06016       /* This isn't working, at least for dbxout.  The .s file looks
06017    okay to me (burley), but in gdb 4.9 at least, the variables
06018    appear to reside somewhere outside of the common area, so
06019    it doesn't make sense to mislead anyone by generating the info
06020    on those variables until this is fixed.  NOTE: Same problem
06021    with EQUIVALENCE, sadly...see similar #if later.  */
06022       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
06023            ffesymbol_storage (s));
06024     }
06025 
06026   return s;
06027 }
06028 
06029 /* Append underscore(s) to name before calling get_identifier.  "us"
06030    is nonzero if the name already contains an underscore and thus
06031    needs two underscores appended.  */
06032 
06033 static tree
06034 ffecom_get_appended_identifier_ (char us, const char *name)
06035 {
06036   int i;
06037   char *newname;
06038   tree id;
06039 
06040   newname = xmalloc ((i = strlen (name)) + 1
06041          + ffe_is_underscoring ()
06042          + us);
06043   memcpy (newname, name, i);
06044   newname[i] = '_';
06045   newname[i + us] = '_';
06046   newname[i + 1 + us] = '\0';
06047   id = get_identifier (newname);
06048 
06049   free (newname);
06050 
06051   return id;
06052 }
06053 
06054 /* Decide whether to append underscore to name before calling
06055    get_identifier.  */
06056 
06057 static tree
06058 ffecom_get_external_identifier_ (ffesymbol s)
06059 {
06060   char us;
06061   const char *name = ffesymbol_text (s);
06062 
06063   /* If name is a built-in name, just return it as is.  */
06064 
06065   if (!ffe_is_underscoring ()
06066       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
06067 #if FFETARGET_isENFORCED_MAIN_NAME
06068       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
06069 #else
06070       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
06071 #endif
06072       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
06073     return get_identifier (name);
06074 
06075   us = ffe_is_second_underscore ()
06076     ? (strchr (name, '_') != NULL)
06077       : 0;
06078 
06079   return ffecom_get_appended_identifier_ (us, name);
06080 }
06081 
06082 /* Decide whether to append underscore to internal name before calling
06083    get_identifier.
06084 
06085    This is for non-external, top-function-context names only.  Transform
06086    identifier so it doesn't conflict with the transformed result
06087    of using a _different_ external name.  E.g. if "CALL FOO" is
06088    transformed into "FOO_();", then the variable in "FOO_ = 3"
06089    must be transformed into something that does not conflict, since
06090    these two things should be independent.
06091 
06092    The transformation is as follows.  If the name does not contain
06093    an underscore, there is no possible conflict, so just return.
06094    If the name does contain an underscore, then transform it just
06095    like we transform an external identifier.  */
06096 
06097 static tree
06098 ffecom_get_identifier_ (const char *name)
06099 {
06100   /* If name does not contain an underscore, just return it as is.  */
06101 
06102   if (!ffe_is_underscoring ()
06103       || (strchr (name, '_') == NULL))
06104     return get_identifier (name);
06105 
06106   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
06107             name);
06108 }
06109 
06110 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
06111 
06112    tree t;
06113    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
06114    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
06115    ffesymbol_kindtype(s));
06116 
06117    Call after setting up containing function and getting trees for all
06118    other symbols.  */
06119 
06120 static tree
06121 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
06122 {
06123   ffebld expr = ffesymbol_sfexpr (s);
06124   tree type;
06125   tree func;
06126   tree result;
06127   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
06128   static bool recurse = FALSE;
06129   int old_lineno = lineno;
06130   const char *old_input_filename = input_filename;
06131 
06132   ffecom_nested_entry_ = s;
06133 
06134   /* For now, we don't have a handy pointer to where the sfunc is actually
06135      defined, though that should be easy to add to an ffesymbol. (The
06136      token/where info available might well point to the place where the type
06137      of the sfunc is declared, especially if that precedes the place where
06138      the sfunc itself is defined, which is typically the case.)  We should
06139      put out a null pointer rather than point somewhere wrong, but I want to
06140      see how it works at this point.  */
06141 
06142   input_filename = ffesymbol_where_filename (s);
06143   lineno = ffesymbol_where_filelinenum (s);
06144 
06145   /* Pretransform the expression so any newly discovered things belong to the
06146      outer program unit, not to the statement function. */
06147 
06148   ffecom_expr_transform_ (expr);
06149 
06150   /* Make sure no recursive invocation of this fn (a specific case of failing
06151      to pretransform an sfunc's expression, i.e. where its expression
06152      references another untransformed sfunc) happens. */
06153 
06154   assert (!recurse);
06155   recurse = TRUE;
06156 
06157   push_f_function_context ();
06158 
06159   if (charfunc)
06160     type = void_type_node;
06161   else
06162     {
06163       type = ffecom_tree_type[bt][kt];
06164       if (type == NULL_TREE)
06165   type = integer_type_node; /* _sym_exec_transition reports
06166              error. */
06167     }
06168 
06169   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
06170       build_function_type (type, NULL_TREE),
06171       1,    /* nested/inline */
06172       0);   /* TREE_PUBLIC */
06173 
06174   /* We don't worry about COMPLEX return values here, because this is
06175      entirely internal to our code, and gcc has the ability to return COMPLEX
06176      directly as a value.  */
06177 
06178   if (charfunc)
06179     {       /* Prepend arg for where result goes. */
06180       tree type;
06181 
06182       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
06183 
06184       result = ffecom_get_invented_identifier ("__g77_%s", "result");
06185 
06186       ffecom_char_enhance_arg_ (&type, s);  /* Ignore returned length. */
06187 
06188       type = build_pointer_type (type);
06189       result = build_decl (PARM_DECL, result, type);
06190 
06191       push_parm_decl (result);
06192     }
06193   else
06194     result = NULL_TREE;   /* Not ref'd if !charfunc. */
06195 
06196   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
06197 
06198   store_parm_decls (0);
06199 
06200   ffecom_start_compstmt ();
06201 
06202   if (expr != NULL)
06203     {
06204       if (charfunc)
06205   {
06206     ffetargetCharacterSize sz = ffesymbol_size (s);
06207     tree result_length;
06208 
06209     result_length = build_int_2 (sz, 0);
06210     TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
06211 
06212     ffecom_prepare_let_char_ (sz, expr);
06213 
06214     ffecom_prepare_end ();
06215 
06216     ffecom_let_char_ (result, result_length, sz, expr);
06217     expand_null_return ();
06218   }
06219       else
06220   {
06221     ffecom_prepare_expr (expr);
06222 
06223     ffecom_prepare_end ();
06224 
06225     expand_return (ffecom_modify (NULL_TREE,
06226           DECL_RESULT (current_function_decl),
06227           ffecom_expr (expr)));
06228   }
06229     }
06230 
06231   ffecom_end_compstmt ();
06232 
06233   func = current_function_decl;
06234   finish_function (1);
06235 
06236   pop_f_function_context ();
06237 
06238   recurse = FALSE;
06239 
06240   lineno = old_lineno;
06241   input_filename = old_input_filename;
06242 
06243   ffecom_nested_entry_ = NULL;
06244 
06245   return func;
06246 }
06247 
06248 static const char *
06249 ffecom_gfrt_args_ (ffecomGfrt ix)
06250 {
06251   return ffecom_gfrt_argstring_[ix];
06252 }
06253 
06254 static tree
06255 ffecom_gfrt_tree_ (ffecomGfrt ix)
06256 {
06257   if (ffecom_gfrt_[ix] == NULL_TREE)
06258     ffecom_make_gfrt_ (ix);
06259 
06260   return ffecom_1 (ADDR_EXPR,
06261        build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
06262        ffecom_gfrt_[ix]);
06263 }
06264 
06265 /* Return initialize-to-zero expression for this VAR_DECL.  */
06266 
06267 /* A somewhat evil way to prevent the garbage collector
06268    from collecting 'tree' structures.  */
06269 #define NUM_TRACKED_CHUNK 63
06270 static struct tree_ggc_tracker
06271 {
06272   struct tree_ggc_tracker *next;
06273   tree trees[NUM_TRACKED_CHUNK];
06274 } *tracker_head = NULL;
06275 
06276 static void
06277 mark_tracker_head (void *arg)
06278 {
06279   struct tree_ggc_tracker *head;
06280   int i;
06281 
06282   for (head = * (struct tree_ggc_tracker **) arg;
06283        head != NULL;
06284        head = head->next)
06285   {
06286     ggc_mark (head);
06287     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
06288       ggc_mark_tree (head->trees[i]);
06289   }
06290 }
06291 
06292 void
06293 ffecom_save_tree_forever (tree t)
06294 {
06295   int i;
06296   if (tracker_head != NULL)
06297     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
06298       if (tracker_head->trees[i] == NULL)
06299   {
06300     tracker_head->trees[i] = t;
06301     return;
06302   }
06303 
06304   {
06305     /* Need to allocate a new block.  */
06306     struct tree_ggc_tracker *old_head = tracker_head;
06307 
06308     tracker_head = ggc_alloc (sizeof (*tracker_head));
06309     tracker_head->next = old_head;
06310     tracker_head->trees[0] = t;
06311     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
06312       tracker_head->trees[i] = NULL;
06313   }
06314 }
06315 
06316 static tree
06317 ffecom_init_zero_ (tree decl)
06318 {
06319   tree init;
06320   int incremental = TREE_STATIC (decl);
06321   tree type = TREE_TYPE (decl);
06322 
06323   if (incremental)
06324     {
06325       make_decl_rtl (decl, NULL);
06326       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
06327     }
06328 
06329   if ((TREE_CODE (type) != ARRAY_TYPE)
06330       && (TREE_CODE (type) != RECORD_TYPE)
06331       && (TREE_CODE (type) != UNION_TYPE)
06332       && !incremental)
06333     init = convert (type, integer_zero_node);
06334   else if (!incremental)
06335     {
06336       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
06337       TREE_CONSTANT (init) = 1;
06338       TREE_STATIC (init) = 1;
06339     }
06340   else
06341     {
06342       assemble_zeros (int_size_in_bytes (type));
06343       init = error_mark_node;
06344     }
06345 
06346   return init;
06347 }
06348 
06349 static tree
06350 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
06351        tree *maybe_tree)
06352 {
06353   tree expr_tree;
06354   tree length_tree;
06355 
06356   switch (ffebld_op (arg))
06357     {
06358     case FFEBLD_opCONTER: /* For F90, check 0-length. */
06359       if (ffetarget_length_character1
06360     (ffebld_constant_character1
06361      (ffebld_conter (arg))) == 0)
06362   {
06363     *maybe_tree = integer_zero_node;
06364     return convert (tree_type, integer_zero_node);
06365   }
06366 
06367       *maybe_tree = integer_one_node;
06368       expr_tree = build_int_2 (*ffetarget_text_character1
06369              (ffebld_constant_character1
06370         (ffebld_conter (arg))),
06371              0);
06372       TREE_TYPE (expr_tree) = tree_type;
06373       return expr_tree;
06374 
06375     case FFEBLD_opSYMTER:
06376     case FFEBLD_opARRAYREF:
06377     case FFEBLD_opFUNCREF:
06378     case FFEBLD_opSUBSTR:
06379       ffecom_char_args_ (&expr_tree, &length_tree, arg);
06380 
06381       if ((expr_tree == error_mark_node)
06382     || (length_tree == error_mark_node))
06383   {
06384     *maybe_tree = error_mark_node;
06385     return error_mark_node;
06386   }
06387 
06388       if (integer_zerop (length_tree))
06389   {
06390     *maybe_tree = integer_zero_node;
06391     return convert (tree_type, integer_zero_node);
06392   }
06393 
06394       expr_tree
06395   = ffecom_1 (INDIRECT_REF,
06396         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
06397         expr_tree);
06398       expr_tree
06399   = ffecom_2 (ARRAY_REF,
06400         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
06401         expr_tree,
06402         integer_one_node);
06403       expr_tree = convert (tree_type, expr_tree);
06404 
06405       if (TREE_CODE (length_tree) == INTEGER_CST)
06406   *maybe_tree = integer_one_node;
06407       else      /* Must check length at run time.  */
06408   *maybe_tree
06409     = ffecom_truth_value
06410       (ffecom_2 (GT_EXPR, integer_type_node,
06411            length_tree,
06412            ffecom_f2c_ftnlen_zero_node));
06413       return expr_tree;
06414 
06415     case FFEBLD_opPAREN:
06416     case FFEBLD_opCONVERT:
06417       if (ffeinfo_size (ffebld_info (arg)) == 0)
06418   {
06419     *maybe_tree = integer_zero_node;
06420     return convert (tree_type, integer_zero_node);
06421   }
06422       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
06423               maybe_tree);
06424 
06425     case FFEBLD_opCONCATENATE:
06426       {
06427   tree maybe_left;
06428   tree maybe_right;
06429   tree expr_left;
06430   tree expr_right;
06431 
06432   expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
06433                &maybe_left);
06434   expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
06435                 &maybe_right);
06436   *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
06437         maybe_left,
06438         maybe_right);
06439   expr_tree = ffecom_3 (COND_EXPR, tree_type,
06440             maybe_left,
06441             expr_left,
06442             expr_right);
06443   return expr_tree;
06444       }
06445 
06446     default:
06447       assert ("bad op in ICHAR" == NULL);
06448       return error_mark_node;
06449     }
06450 }
06451 
06452 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
06453 
06454    tree length_arg;
06455    ffebld expr;
06456    length_arg = ffecom_intrinsic_len_ (expr);
06457 
06458    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
06459    subexpressions by constructing the appropriate tree for the
06460    length-of-character-text argument in a calling sequence.  */
06461 
06462 static tree
06463 ffecom_intrinsic_len_ (ffebld expr)
06464 {
06465   ffetargetCharacter1 val;
06466   tree length;
06467 
06468   switch (ffebld_op (expr))
06469     {
06470     case FFEBLD_opCONTER:
06471       val = ffebld_constant_character1 (ffebld_conter (expr));
06472       length = build_int_2 (ffetarget_length_character1 (val), 0);
06473       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
06474       break;
06475 
06476     case FFEBLD_opSYMTER:
06477       {
06478   ffesymbol s = ffebld_symter (expr);
06479   tree item;
06480 
06481   item = ffesymbol_hook (s).decl_tree;
06482   if (item == NULL_TREE)
06483     {
06484       s = ffecom_sym_transform_ (s);
06485       item = ffesymbol_hook (s).decl_tree;
06486     }
06487   if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
06488     {
06489       if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
06490         length = ffesymbol_hook (s).length_tree;
06491       else
06492         {
06493     length = build_int_2 (ffesymbol_size (s), 0);
06494     TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
06495         }
06496     }
06497   else if (item == error_mark_node)
06498     length = error_mark_node;
06499   else      /* FFEINFO_kindFUNCTION: */
06500     length = NULL_TREE;
06501       }
06502       break;
06503 
06504     case FFEBLD_opARRAYREF:
06505       length = ffecom_intrinsic_len_ (ffebld_left (expr));
06506       break;
06507 
06508     case FFEBLD_opSUBSTR:
06509       {
06510   ffebld start;
06511   ffebld end;
06512   ffebld thing = ffebld_right (expr);
06513   tree start_tree;
06514   tree end_tree;
06515 
06516   assert (ffebld_op (thing) == FFEBLD_opITEM);
06517   start = ffebld_head (thing);
06518   thing = ffebld_trail (thing);
06519   assert (ffebld_trail (thing) == NULL);
06520   end = ffebld_head (thing);
06521 
06522   length = ffecom_intrinsic_len_ (ffebld_left (expr));
06523 
06524   if (length == error_mark_node)
06525     break;
06526 
06527   if (start == NULL)
06528     {
06529       if (end == NULL)
06530         ;
06531       else
06532         {
06533     length = convert (ffecom_f2c_ftnlen_type_node,
06534           ffecom_expr (end));
06535         }
06536     }
06537   else
06538     {
06539       start_tree = convert (ffecom_f2c_ftnlen_type_node,
06540           ffecom_expr (start));
06541 
06542       if (start_tree == error_mark_node)
06543         {
06544     length = error_mark_node;
06545     break;
06546         }
06547 
06548       if (end == NULL)
06549         {
06550     length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
06551            ffecom_f2c_ftnlen_one_node,
06552            ffecom_2 (MINUS_EXPR,
06553                ffecom_f2c_ftnlen_type_node,
06554                length,
06555                start_tree));
06556         }
06557       else
06558         {
06559     end_tree = convert (ffecom_f2c_ftnlen_type_node,
06560             ffecom_expr (end));
06561 
06562     if (end_tree == error_mark_node)
06563       {
06564         length = error_mark_node;
06565         break;
06566       }
06567 
06568     length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
06569            ffecom_f2c_ftnlen_one_node,
06570            ffecom_2 (MINUS_EXPR,
06571                ffecom_f2c_ftnlen_type_node,
06572                end_tree, start_tree));
06573         }
06574     }
06575       }
06576       break;
06577 
06578     case FFEBLD_opCONCATENATE:
06579       length
06580   = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
06581         ffecom_intrinsic_len_ (ffebld_left (expr)),
06582         ffecom_intrinsic_len_ (ffebld_right (expr)));
06583       break;
06584 
06585     case FFEBLD_opFUNCREF:
06586     case FFEBLD_opCONVERT:
06587       length = build_int_2 (ffebld_size (expr), 0);
06588       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
06589       break;
06590 
06591     default:
06592       assert ("bad op for single char arg expr" == NULL);
06593       length = ffecom_f2c_ftnlen_zero_node;
06594       break;
06595     }
06596 
06597   assert (length != NULL_TREE);
06598 
06599   return length;
06600 }
06601 
06602 /* Handle CHARACTER assignments.
06603 
06604    Generates code to do the assignment.  Used by ordinary assignment
06605    statement handler ffecom_let_stmt and by statement-function
06606    handler to generate code for a statement function.  */
06607 
06608 static void
06609 ffecom_let_char_ (tree dest_tree, tree dest_length,
06610       ffetargetCharacterSize dest_size, ffebld source)
06611 {
06612   ffecomConcatList_ catlist;
06613   tree source_length;
06614   tree source_tree;
06615   tree expr_tree;
06616 
06617   if ((dest_tree == error_mark_node)
06618       || (dest_length == error_mark_node))
06619     return;
06620 
06621   assert (dest_tree != NULL_TREE);
06622   assert (dest_length != NULL_TREE);
06623 
06624   /* Source might be an opCONVERT, which just means it is a different size
06625      than the destination.  Since the underlying implementation here handles
06626      that (directly or via the s_copy or s_cat run-time-library functions),
06627      we don't need the "convenience" of an opCONVERT that tells us to
06628      truncate or blank-pad, particularly since the resulting implementation
06629      would probably be slower than otherwise. */
06630 
06631   while (ffebld_op (source) == FFEBLD_opCONVERT)
06632     source = ffebld_left (source);
06633 
06634   catlist = ffecom_concat_list_new_ (source, dest_size);
06635   switch (ffecom_concat_list_count_ (catlist))
06636     {
06637     case 0:     /* Shouldn't happen, but in case it does... */
06638       ffecom_concat_list_kill_ (catlist);
06639       source_tree = null_pointer_node;
06640       source_length = ffecom_f2c_ftnlen_zero_node;
06641       expr_tree = build_tree_list (NULL_TREE, dest_tree);
06642       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
06643       TREE_CHAIN (TREE_CHAIN (expr_tree))
06644   = build_tree_list (NULL_TREE, dest_length);
06645       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
06646   = build_tree_list (NULL_TREE, source_length);
06647 
06648       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
06649       TREE_SIDE_EFFECTS (expr_tree) = 1;
06650 
06651       expand_expr_stmt (expr_tree);
06652 
06653       return;
06654 
06655     case 1:     /* The (fairly) easy case. */
06656       ffecom_char_args_ (&source_tree, &source_length,
06657        ffecom_concat_list_expr_ (catlist, 0));
06658       ffecom_concat_list_kill_ (catlist);
06659       assert (source_tree != NULL_TREE);
06660       assert (source_length != NULL_TREE);
06661 
06662       if ((source_tree == error_mark_node)
06663     || (source_length == error_mark_node))
06664   return;
06665 
06666       if (dest_size == 1)
06667   {
06668     dest_tree
06669       = ffecom_1 (INDIRECT_REF,
06670       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
06671                   (dest_tree))),
06672       dest_tree);
06673     dest_tree
06674       = ffecom_2 (ARRAY_REF,
06675       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
06676                   (dest_tree))),
06677       dest_tree,
06678       integer_one_node);
06679     source_tree
06680       = ffecom_1 (INDIRECT_REF,
06681       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
06682                   (source_tree))),
06683       source_tree);
06684     source_tree
06685       = ffecom_2 (ARRAY_REF,
06686       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
06687                   (source_tree))),
06688       source_tree,
06689       integer_one_node);
06690 
06691     expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
06692 
06693     expand_expr_stmt (expr_tree);
06694 
06695     return;
06696   }
06697 
06698       expr_tree = build_tree_list (NULL_TREE, dest_tree);
06699       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
06700       TREE_CHAIN (TREE_CHAIN (expr_tree))
06701   = build_tree_list (NULL_TREE, dest_length);
06702       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
06703   = build_tree_list (NULL_TREE, source_length);
06704 
06705       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
06706       TREE_SIDE_EFFECTS (expr_tree) = 1;
06707 
06708       expand_expr_stmt (expr_tree);
06709 
06710       return;
06711 
06712     default:      /* Must actually concatenate things. */
06713       break;
06714     }
06715 
06716   /* Heavy-duty concatenation. */
06717 
06718   {
06719     int count = ffecom_concat_list_count_ (catlist);
06720     int i;
06721     tree lengths;
06722     tree items;
06723     tree length_array;
06724     tree item_array;
06725     tree citem;
06726     tree clength;
06727 
06728 #ifdef HOHO
06729     length_array
06730       = lengths
06731       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
06732            FFETARGET_charactersizeNONE, count, TRUE);
06733     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
06734                 FFETARGET_charactersizeNONE,
06735                 count, TRUE);
06736 #else
06737     {
06738       tree hook;
06739 
06740       hook = ffebld_nonter_hook (source);
06741       assert (hook);
06742       assert (TREE_CODE (hook) == TREE_VEC);
06743       assert (TREE_VEC_LENGTH (hook) == 2);
06744       length_array = lengths = TREE_VEC_ELT (hook, 0);
06745       item_array = items = TREE_VEC_ELT (hook, 1);
06746     }
06747 #endif
06748 
06749     for (i = 0; i < count; ++i)
06750       {
06751   ffecom_char_args_ (&citem, &clength,
06752          ffecom_concat_list_expr_ (catlist, i));
06753   if ((citem == error_mark_node)
06754       || (clength == error_mark_node))
06755     {
06756       ffecom_concat_list_kill_ (catlist);
06757       return;
06758     }
06759 
06760   items
06761     = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
06762           ffecom_modify (void_type_node,
06763              ffecom_2 (ARRAY_REF,
06764          TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
06765                  item_array,
06766                  build_int_2 (i, 0)),
06767              citem),
06768           items);
06769   lengths
06770     = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
06771           ffecom_modify (void_type_node,
06772              ffecom_2 (ARRAY_REF,
06773        TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
06774                  length_array,
06775                  build_int_2 (i, 0)),
06776              clength),
06777           lengths);
06778       }
06779 
06780     expr_tree = build_tree_list (NULL_TREE, dest_tree);
06781     TREE_CHAIN (expr_tree)
06782       = build_tree_list (NULL_TREE,
06783        ffecom_1 (ADDR_EXPR,
06784            build_pointer_type (TREE_TYPE (items)),
06785            items));
06786     TREE_CHAIN (TREE_CHAIN (expr_tree))
06787       = build_tree_list (NULL_TREE,
06788        ffecom_1 (ADDR_EXPR,
06789            build_pointer_type (TREE_TYPE (lengths)),
06790            lengths));
06791     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
06792       = build_tree_list
06793   (NULL_TREE,
06794    ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
06795        convert (ffecom_f2c_ftnlen_type_node,
06796           build_int_2 (count, 0))));
06797     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
06798       = build_tree_list (NULL_TREE, dest_length);
06799 
06800     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
06801     TREE_SIDE_EFFECTS (expr_tree) = 1;
06802 
06803     expand_expr_stmt (expr_tree);
06804   }
06805 
06806   ffecom_concat_list_kill_ (catlist);
06807 }
06808 
06809 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
06810 
06811    ffecomGfrt ix;
06812    ffecom_make_gfrt_(ix);
06813 
06814    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
06815    for the indicated run-time routine (ix).  */
06816 
06817 static void
06818 ffecom_make_gfrt_ (ffecomGfrt ix)
06819 {
06820   tree t;
06821   tree ttype;
06822 
06823   switch (ffecom_gfrt_type_[ix])
06824     {
06825     case FFECOM_rttypeVOID_:
06826       ttype = void_type_node;
06827       break;
06828 
06829     case FFECOM_rttypeVOIDSTAR_:
06830       ttype = TREE_TYPE (null_pointer_node);  /* `void *'. */
06831       break;
06832 
06833     case FFECOM_rttypeFTNINT_:
06834       ttype = ffecom_f2c_ftnint_type_node;
06835       break;
06836 
06837     case FFECOM_rttypeINTEGER_:
06838       ttype = ffecom_f2c_integer_type_node;
06839       break;
06840 
06841     case FFECOM_rttypeLONGINT_:
06842       ttype = ffecom_f2c_longint_type_node;
06843       break;
06844 
06845     case FFECOM_rttypeLOGICAL_:
06846       ttype = ffecom_f2c_logical_type_node;
06847       break;
06848 
06849     case FFECOM_rttypeREAL_F2C_:
06850       ttype = double_type_node;
06851       break;
06852 
06853     case FFECOM_rttypeREAL_GNU_:
06854       ttype = float_type_node;
06855       break;
06856 
06857     case FFECOM_rttypeCOMPLEX_F2C_:
06858       ttype = void_type_node;
06859       break;
06860 
06861     case FFECOM_rttypeCOMPLEX_GNU_:
06862       ttype = ffecom_f2c_complex_type_node;
06863       break;
06864 
06865     case FFECOM_rttypeDOUBLE_:
06866       ttype = double_type_node;
06867       break;
06868 
06869     case FFECOM_rttypeDOUBLEREAL_:
06870       ttype = ffecom_f2c_doublereal_type_node;
06871       break;
06872 
06873     case FFECOM_rttypeDBLCMPLX_F2C_:
06874       ttype = void_type_node;
06875       break;
06876 
06877     case FFECOM_rttypeDBLCMPLX_GNU_:
06878       ttype = ffecom_f2c_doublecomplex_type_node;
06879       break;
06880 
06881     case FFECOM_rttypeCHARACTER_:
06882       ttype = void_type_node;
06883       break;
06884 
06885     default:
06886       ttype = NULL;
06887       assert ("bad rttype" == NULL);
06888       break;
06889     }
06890 
06891   ttype = build_function_type (ttype, NULL_TREE);
06892   t = build_decl (FUNCTION_DECL,
06893       get_identifier (ffecom_gfrt_name_[ix]),
06894       ttype);
06895   DECL_EXTERNAL (t) = 1;
06896   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
06897   TREE_PUBLIC (t) = 1;
06898   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
06899 
06900   /* Sanity check:  A function that's const cannot be volatile.  */
06901 
06902   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
06903 
06904   /* Sanity check: A function that's const cannot return complex.  */
06905 
06906   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
06907 
06908   t = start_decl (t, TRUE);
06909 
06910   finish_decl (t, NULL_TREE, TRUE);
06911 
06912   ffecom_gfrt_[ix] = t;
06913 }
06914 
06915 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
06916 
06917 static void
06918 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
06919 {
06920   ffesymbol s = ffestorag_symbol (st);
06921 
06922   if (ffesymbol_namelisted (s))
06923     ffecom_member_namelisted_ = TRUE;
06924 }
06925 
06926 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
06927    the member so debugger will see it.  Otherwise nobody should be
06928    referencing the member.  */
06929 
06930 static void
06931 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
06932 {
06933   ffesymbol s;
06934   tree t;
06935   tree mt;
06936   tree type;
06937 
06938   if ((mst == NULL)
06939       || ((mt = ffestorag_hook (mst)) == NULL)
06940       || (mt == error_mark_node))
06941     return;
06942 
06943   if ((st == NULL)
06944       || ((s = ffestorag_symbol (st)) == NULL))
06945     return;
06946 
06947   type = ffecom_type_localvar_ (s,
06948         ffesymbol_basictype (s),
06949         ffesymbol_kindtype (s));
06950   if (type == error_mark_node)
06951     return;
06952 
06953   t = build_decl (VAR_DECL,
06954       ffecom_get_identifier_ (ffesymbol_text (s)),
06955       type);
06956 
06957   TREE_STATIC (t) = TREE_STATIC (mt);
06958   DECL_INITIAL (t) = NULL_TREE;
06959   TREE_ASM_WRITTEN (t) = 1;
06960   TREE_USED (t) = 1;
06961 
06962   SET_DECL_RTL (t,
06963     gen_rtx (MEM, TYPE_MODE (type),
06964        plus_constant (XEXP (DECL_RTL (mt), 0),
06965           ffestorag_modulo (mst)
06966           + ffestorag_offset (st)
06967           - ffestorag_offset (mst))));
06968 
06969   t = start_decl (t, FALSE);
06970 
06971   finish_decl (t, NULL_TREE, FALSE);
06972 }
06973 
06974 /* Prepare source expression for assignment into a destination perhaps known
06975    to be of a specific size.  */
06976 
06977 static void
06978 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
06979 {
06980   ffecomConcatList_ catlist;
06981   int count;
06982   int i;
06983   tree ltmp;
06984   tree itmp;
06985   tree tempvar = NULL_TREE;
06986 
06987   while (ffebld_op (source) == FFEBLD_opCONVERT)
06988     source = ffebld_left (source);
06989 
06990   catlist = ffecom_concat_list_new_ (source, dest_size);
06991   count = ffecom_concat_list_count_ (catlist);
06992 
06993   if (count >= 2)
06994     {
06995       ltmp
06996   = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
06997              FFETARGET_charactersizeNONE, count);
06998       itmp
06999   = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
07000              FFETARGET_charactersizeNONE, count);
07001 
07002       tempvar = make_tree_vec (2);
07003       TREE_VEC_ELT (tempvar, 0) = ltmp;
07004       TREE_VEC_ELT (tempvar, 1) = itmp;
07005     }
07006 
07007   for (i = 0; i < count; ++i)
07008     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
07009 
07010   ffecom_concat_list_kill_ (catlist);
07011 
07012   if (tempvar)
07013     {
07014       ffebld_nonter_set_hook (source, tempvar);
07015       current_binding_level->prep_state = 1;
07016     }
07017 }
07018 
07019 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
07020 
07021    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
07022    (which generates their trees) and then their trees get push_parm_decl'd.
07023 
07024    The second arg is TRUE if the dummies are for a statement function, in
07025    which case lengths are not pushed for character arguments (since they are
07026    always known by both the caller and the callee, though the code allows
07027    for someday permitting CHAR*(*) stmtfunc dummies).  */
07028 
07029 static void
07030 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
07031 {
07032   ffebld dummy;
07033   ffebld dumlist;
07034   ffesymbol s;
07035   tree parm;
07036 
07037   ffecom_transform_only_dummies_ = TRUE;
07038 
07039   /* First push the parms corresponding to actual dummy "contents".  */
07040 
07041   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
07042     {
07043       dummy = ffebld_head (dumlist);
07044       switch (ffebld_op (dummy))
07045   {
07046   case FFEBLD_opSTAR:
07047   case FFEBLD_opANY:
07048     continue;   /* Forget alternate returns. */
07049 
07050   default:
07051     break;
07052   }
07053       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
07054       s = ffebld_symter (dummy);
07055       parm = ffesymbol_hook (s).decl_tree;
07056       if (parm == NULL_TREE)
07057   {
07058     s = ffecom_sym_transform_ (s);
07059     parm = ffesymbol_hook (s).decl_tree;
07060     assert (parm != NULL_TREE);
07061   }
07062       if (parm != error_mark_node)
07063   push_parm_decl (parm);
07064     }
07065 
07066   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
07067 
07068   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
07069     {
07070       dummy = ffebld_head (dumlist);
07071       switch (ffebld_op (dummy))
07072   {
07073   case FFEBLD_opSTAR:
07074   case FFEBLD_opANY:
07075     continue;   /* Forget alternate returns, they mean
07076            NOTHING! */
07077 
07078   default:
07079     break;
07080   }
07081       s = ffebld_symter (dummy);
07082       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
07083   continue;   /* Only looking for CHARACTER arguments. */
07084       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
07085   continue;   /* Stmtfunc arg with known size needs no
07086            length param. */
07087       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
07088   continue;   /* Only looking for variables and arrays. */
07089       parm = ffesymbol_hook (s).length_tree;
07090       assert (parm != NULL_TREE);
07091       if (parm != error_mark_node)
07092   push_parm_decl (parm);
07093     }
07094 
07095   ffecom_transform_only_dummies_ = FALSE;
07096 }
07097 
07098 /* ffecom_start_progunit_ -- Beginning of program unit
07099 
07100    Does GNU back end stuff necessary to teach it about the start of its
07101    equivalent of a Fortran program unit.  */
07102 
07103 static void
07104 ffecom_start_progunit_ ()
07105 {
07106   ffesymbol fn = ffecom_primary_entry_;
07107   ffebld arglist;
07108   tree id;      /* Identifier (name) of function. */
07109   tree type;      /* Type of function. */
07110   tree result;      /* Result of function. */
07111   ffeinfoBasictype bt;
07112   ffeinfoKindtype kt;
07113   ffeglobal g;
07114   ffeglobalType gt;
07115   ffeglobalType egt = FFEGLOBAL_type;
07116   bool charfunc;
07117   bool cmplxfunc;
07118   bool altentries = (ffecom_num_entrypoints_ != 0);
07119   bool multi
07120   = altentries
07121   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
07122   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
07123   bool main_program = FALSE;
07124   int old_lineno = lineno;
07125   const char *old_input_filename = input_filename;
07126 
07127   assert (fn != NULL);
07128   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
07129 
07130   input_filename = ffesymbol_where_filename (fn);
07131   lineno = ffesymbol_where_filelinenum (fn);
07132 
07133   switch (ffecom_primary_entry_kind_)
07134     {
07135     case FFEINFO_kindPROGRAM:
07136       main_program = TRUE;
07137       gt = FFEGLOBAL_typeMAIN;
07138       bt = FFEINFO_basictypeNONE;
07139       kt = FFEINFO_kindtypeNONE;
07140       type = ffecom_tree_fun_type_void;
07141       charfunc = FALSE;
07142       cmplxfunc = FALSE;
07143       break;
07144 
07145     case FFEINFO_kindBLOCKDATA:
07146       gt = FFEGLOBAL_typeBDATA;
07147       bt = FFEINFO_basictypeNONE;
07148       kt = FFEINFO_kindtypeNONE;
07149       type = ffecom_tree_fun_type_void;
07150       charfunc = FALSE;
07151       cmplxfunc = FALSE;
07152       break;
07153 
07154     case FFEINFO_kindFUNCTION:
07155       gt = FFEGLOBAL_typeFUNC;
07156       egt = FFEGLOBAL_typeEXT;
07157       bt = ffesymbol_basictype (fn);
07158       kt = ffesymbol_kindtype (fn);
07159       if (bt == FFEINFO_basictypeNONE)
07160   {
07161     ffeimplic_establish_symbol (fn);
07162     if (ffesymbol_funcresult (fn) != NULL)
07163       ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
07164     bt = ffesymbol_basictype (fn);
07165     kt = ffesymbol_kindtype (fn);
07166   }
07167 
07168       if (multi)
07169   charfunc = cmplxfunc = FALSE;
07170       else if (bt == FFEINFO_basictypeCHARACTER)
07171   charfunc = TRUE, cmplxfunc = FALSE;
07172       else if ((bt == FFEINFO_basictypeCOMPLEX)
07173          && ffesymbol_is_f2c (fn)
07174          && !altentries)
07175   charfunc = FALSE, cmplxfunc = TRUE;
07176       else
07177   charfunc = cmplxfunc = FALSE;
07178 
07179       if (multi || charfunc)
07180   type = ffecom_tree_fun_type_void;
07181       else if (ffesymbol_is_f2c (fn) && !altentries)
07182   type = ffecom_tree_fun_type[bt][kt];
07183       else
07184   type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
07185 
07186       if ((type == NULL_TREE)
07187     || (TREE_TYPE (type) == NULL_TREE))
07188   type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
07189       break;
07190 
07191     case FFEINFO_kindSUBROUTINE:
07192       gt = FFEGLOBAL_typeSUBR;
07193       egt = FFEGLOBAL_typeEXT;
07194       bt = FFEINFO_basictypeNONE;
07195       kt = FFEINFO_kindtypeNONE;
07196       if (ffecom_is_altreturning_)
07197   type = ffecom_tree_subr_type;
07198       else
07199   type = ffecom_tree_fun_type_void;
07200       charfunc = FALSE;
07201       cmplxfunc = FALSE;
07202       break;
07203 
07204     default:
07205       assert ("say what??" == NULL);
07206       /* Fall through. */
07207     case FFEINFO_kindANY:
07208       gt = FFEGLOBAL_typeANY;
07209       bt = FFEINFO_basictypeNONE;
07210       kt = FFEINFO_kindtypeNONE;
07211       type = error_mark_node;
07212       charfunc = FALSE;
07213       cmplxfunc = FALSE;
07214       break;
07215     }
07216 
07217   if (altentries)
07218     {
07219       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
07220              ffesymbol_text (fn));
07221     }
07222 #if FFETARGET_isENFORCED_MAIN
07223   else if (main_program)
07224     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
07225 #endif
07226   else
07227     id = ffecom_get_external_identifier_ (fn);
07228 
07229   start_function (id,
07230       type,
07231       0,    /* nested/inline */
07232       !altentries); /* TREE_PUBLIC */
07233 
07234   TREE_USED (current_function_decl) = 1;  /* Avoid spurious warning if altentries. */
07235 
07236   if (!altentries
07237       && ((g = ffesymbol_global (fn)) != NULL)
07238       && ((ffeglobal_type (g) == gt)
07239     || (ffeglobal_type (g) == egt)))
07240     {
07241       ffeglobal_set_hook (g, current_function_decl);
07242     }
07243 
07244   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
07245      exec-transitioning needs current_function_decl to be filled in.  So we
07246      do these things in two phases. */
07247 
07248   if (altentries)
07249     {       /* 1st arg identifies which entrypoint. */
07250       ffecom_which_entrypoint_decl_
07251   = build_decl (PARM_DECL,
07252           ffecom_get_invented_identifier ("__g77_%s",
07253                   "which_entrypoint"),
07254           integer_type_node);
07255       push_parm_decl (ffecom_which_entrypoint_decl_);
07256     }
07257 
07258   if (charfunc
07259       || cmplxfunc
07260       || multi)
07261     {       /* Arg for result (return value). */
07262       tree type;
07263       tree length;
07264 
07265       if (charfunc)
07266   type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
07267       else if (cmplxfunc)
07268   type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
07269       else
07270   type = ffecom_multi_type_node_;
07271 
07272       result = ffecom_get_invented_identifier ("__g77_%s", "result");
07273 
07274       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
07275 
07276       if (charfunc)
07277   length = ffecom_char_enhance_arg_ (&type, fn);
07278       else
07279   length = NULL_TREE; /* Not ref'd if !charfunc. */
07280 
07281       type = build_pointer_type (type);
07282       result = build_decl (PARM_DECL, result, type);
07283 
07284       push_parm_decl (result);
07285       if (multi)
07286   ffecom_multi_retval_ = result;
07287       else
07288   ffecom_func_result_ = result;
07289 
07290       if (charfunc)
07291   {
07292     push_parm_decl (length);
07293     ffecom_func_length_ = length;
07294   }
07295     }
07296 
07297   if (ffecom_primary_entry_is_proc_)
07298     {
07299       if (altentries)
07300   arglist = ffecom_master_arglist_;
07301       else
07302   arglist = ffesymbol_dummyargs (fn);
07303       ffecom_push_dummy_decls_ (arglist, FALSE);
07304     }
07305 
07306   if (TREE_CODE (current_function_decl) != ERROR_MARK)
07307     store_parm_decls (main_program ? 1 : 0);
07308 
07309   ffecom_start_compstmt ();
07310   /* Disallow temp vars at this level.  */
07311   current_binding_level->prep_state = 2;
07312 
07313   lineno = old_lineno;
07314   input_filename = old_input_filename;
07315 
07316   /* This handles any symbols still untransformed, in case -g specified.
07317      This used to be done in ffecom_finish_progunit, but it turns out to
07318      be necessary to do it here so that statement functions are
07319      expanded before code.  But don't bother for BLOCK DATA.  */
07320 
07321   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
07322     ffesymbol_drive (ffecom_finish_symbol_transform_);
07323 }
07324 
07325 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
07326 
07327    ffesymbol s;
07328    ffecom_sym_transform_(s);
07329 
07330    The ffesymbol_hook info for s is updated with appropriate backend info
07331    on the symbol.  */
07332 
07333 static ffesymbol
07334 ffecom_sym_transform_ (ffesymbol s)
07335 {
07336   tree t;     /* Transformed thingy. */
07337   tree tlen;      /* Length if CHAR*(*). */
07338   bool addr;      /* Is t the address of the thingy? */
07339   ffeinfoBasictype bt;
07340   ffeinfoKindtype kt;
07341   ffeglobal g;
07342   int old_lineno = lineno;
07343   const char *old_input_filename = input_filename;
07344 
07345   /* Must ensure special ASSIGN variables are declared at top of outermost
07346      block, else they'll end up in the innermost block when their first
07347      ASSIGN is seen, which leaves them out of scope when they're the
07348      subject of a GOTO or I/O statement.
07349 
07350      We make this variable even if -fugly-assign.  Just let it go unused,
07351      in case it turns out there are cases where we really want to use this
07352      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
07353 
07354   if (! ffecom_transform_only_dummies_
07355       && ffesymbol_assigned (s)
07356       && ! ffesymbol_hook (s).assign_tree)
07357     s = ffecom_sym_transform_assign_ (s);
07358 
07359   if (ffesymbol_sfdummyparent (s) == NULL)
07360     {
07361       input_filename = ffesymbol_where_filename (s);
07362       lineno = ffesymbol_where_filelinenum (s);
07363     }
07364   else
07365     {
07366       ffesymbol sf = ffesymbol_sfdummyparent (s);
07367 
07368       input_filename = ffesymbol_where_filename (sf);
07369       lineno = ffesymbol_where_filelinenum (sf);
07370     }
07371 
07372   bt = ffeinfo_basictype (ffebld_info (s));
07373   kt = ffeinfo_kindtype (ffebld_info (s));
07374 
07375   t = NULL_TREE;
07376   tlen = NULL_TREE;
07377   addr = FALSE;
07378 
07379   switch (ffesymbol_kind (s))
07380     {
07381     case FFEINFO_kindNONE:
07382       switch (ffesymbol_where (s))
07383   {
07384   case FFEINFO_whereDUMMY:  /* Subroutine or function. */
07385     assert (ffecom_transform_only_dummies_);
07386 
07387     /* Before 0.4, this could be ENTITY/DUMMY, but see
07388        ffestu_sym_end_transition -- no longer true (in particular, if
07389        it could be an ENTITY, it _will_ be made one, so that
07390        possibility won't come through here).  So we never make length
07391        arg for CHARACTER type.  */
07392 
07393     t = build_decl (PARM_DECL,
07394         ffecom_get_identifier_ (ffesymbol_text (s)),
07395         ffecom_tree_ptr_to_subr_type);
07396     DECL_ARTIFICIAL (t) = 1;
07397     addr = TRUE;
07398     break;
07399 
07400   case FFEINFO_whereGLOBAL: /* Subroutine or function. */
07401     assert (!ffecom_transform_only_dummies_);
07402 
07403     if (((g = ffesymbol_global (s)) != NULL)
07404         && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
07405       || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
07406       || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
07407         && (ffeglobal_hook (g) != NULL_TREE)
07408         && ffe_is_globals ())
07409       {
07410         t = ffeglobal_hook (g);
07411         break;
07412       }
07413 
07414     t = build_decl (FUNCTION_DECL,
07415         ffecom_get_external_identifier_ (s),
07416         ffecom_tree_subr_type); /* Assume subr. */
07417     DECL_EXTERNAL (t) = 1;
07418     TREE_PUBLIC (t) = 1;
07419 
07420     t = start_decl (t, FALSE);
07421     finish_decl (t, NULL_TREE, FALSE);
07422 
07423     if ((g != NULL)
07424         && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
07425       || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
07426       || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
07427       ffeglobal_set_hook (g, t);
07428 
07429     ffecom_save_tree_forever (t);
07430 
07431     break;
07432 
07433   default:
07434     assert ("NONE where unexpected" == NULL);
07435     /* Fall through. */
07436   case FFEINFO_whereANY:
07437     break;
07438   }
07439       break;
07440 
07441     case FFEINFO_kindENTITY:
07442       switch (ffeinfo_where (ffesymbol_info (s)))
07443   {
07444 
07445   case FFEINFO_whereCONSTANT:
07446     /* ~~Debugging info needed? */
07447     assert (!ffecom_transform_only_dummies_);
07448     t = error_mark_node;  /* Shouldn't ever see this in expr. */
07449     break;
07450 
07451   case FFEINFO_whereLOCAL:
07452     assert (!ffecom_transform_only_dummies_);
07453 
07454     {
07455       ffestorag st = ffesymbol_storage (s);
07456       tree type;
07457 
07458       if ((st != NULL)
07459     && (ffestorag_size (st) == 0))
07460         {
07461     t = error_mark_node;
07462     break;
07463         }
07464 
07465       type = ffecom_type_localvar_ (s, bt, kt);
07466 
07467       if (type == error_mark_node)
07468         {
07469     t = error_mark_node;
07470     break;
07471         }
07472 
07473       if ((st != NULL)
07474     && (ffestorag_parent (st) != NULL))
07475         {     /* Child of EQUIVALENCE parent. */
07476     ffestorag est;
07477     tree et;
07478     ffetargetOffset offset;
07479 
07480     est = ffestorag_parent (st);
07481     ffecom_transform_equiv_ (est);
07482 
07483     et = ffestorag_hook (est);
07484     assert (et != NULL_TREE);
07485 
07486     if (! TREE_STATIC (et))
07487       put_var_into_stack (et);
07488 
07489     offset = ffestorag_modulo (est)
07490       + ffestorag_offset (ffesymbol_storage (s))
07491       - ffestorag_offset (est);
07492 
07493     ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
07494 
07495     /* (t_type *) (((char *) &et) + offset) */
07496 
07497     t = convert (string_type_node,  /* (char *) */
07498            ffecom_1 (ADDR_EXPR,
07499                build_pointer_type (TREE_TYPE (et)),
07500                et));
07501     t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
07502             t,
07503             build_int_2 (offset, 0));
07504     t = convert (build_pointer_type (type),
07505            t);
07506     TREE_CONSTANT (t) = staticp (et);
07507 
07508     addr = TRUE;
07509         }
07510       else
07511         {
07512     tree initexpr;
07513     bool init = ffesymbol_is_init (s);
07514 
07515     t = build_decl (VAR_DECL,
07516         ffecom_get_identifier_ (ffesymbol_text (s)),
07517         type);
07518 
07519     if (init
07520         || ffesymbol_namelisted (s)
07521 #ifdef FFECOM_sizeMAXSTACKITEM
07522         || ((st != NULL)
07523       && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
07524 #endif
07525         || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
07526       && (ffecom_primary_entry_kind_
07527           != FFEINFO_kindBLOCKDATA)
07528       && (ffesymbol_is_save (s) || ffe_is_saveall ())))
07529       TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
07530     else
07531       TREE_STATIC (t) = 0;  /* No need to make static. */
07532 
07533     if (init || ffe_is_init_local_zero ())
07534       DECL_INITIAL (t) = error_mark_node;
07535 
07536     /* Keep -Wunused from complaining about var if it
07537        is used as sfunc arg or DATA implied-DO.  */
07538     if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
07539       DECL_IN_SYSTEM_HEADER (t) = 1;
07540 
07541     t = start_decl (t, FALSE);
07542 
07543     if (init)
07544       {
07545         if (ffesymbol_init (s) != NULL)
07546           initexpr = ffecom_expr (ffesymbol_init (s));
07547         else
07548           initexpr = ffecom_init_zero_ (t);
07549       }
07550     else if (ffe_is_init_local_zero ())
07551       initexpr = ffecom_init_zero_ (t);
07552     else
07553       initexpr = NULL_TREE; /* Not ref'd if !init. */
07554 
07555     finish_decl (t, initexpr, FALSE);
07556 
07557     if (st != NULL && DECL_SIZE (t) != error_mark_node)
07558       {
07559         assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
07560         assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
07561                ffestorag_size (st)));
07562       }
07563         }
07564     }
07565     break;
07566 
07567   case FFEINFO_whereRESULT:
07568     assert (!ffecom_transform_only_dummies_);
07569 
07570     if (bt == FFEINFO_basictypeCHARACTER)
07571       {     /* Result is already in list of dummies, use
07572            it (& length). */
07573         t = ffecom_func_result_;
07574         tlen = ffecom_func_length_;
07575         addr = TRUE;
07576         break;
07577       }
07578     if ((ffecom_num_entrypoints_ == 0)
07579         && (bt == FFEINFO_basictypeCOMPLEX)
07580         && (ffesymbol_is_f2c (ffecom_primary_entry_)))
07581       {     /* Result is already in list of dummies, use
07582            it. */
07583         t = ffecom_func_result_;
07584         addr = TRUE;
07585         break;
07586       }
07587     if (ffecom_func_result_ != NULL_TREE)
07588       {
07589         t = ffecom_func_result_;
07590         break;
07591       }
07592     if ((ffecom_num_entrypoints_ != 0)
07593         && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
07594       {
07595         assert (ffecom_multi_retval_ != NULL_TREE);
07596         t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
07597           ffecom_multi_retval_);
07598         t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
07599           t, ffecom_multi_fields_[bt][kt]);
07600 
07601         break;
07602       }
07603 
07604     t = build_decl (VAR_DECL,
07605         ffecom_get_identifier_ (ffesymbol_text (s)),
07606         ffecom_tree_type[bt][kt]);
07607     TREE_STATIC (t) = 0;  /* Put result on stack. */
07608     t = start_decl (t, FALSE);
07609     finish_decl (t, NULL_TREE, FALSE);
07610 
07611     ffecom_func_result_ = t;
07612 
07613     break;
07614 
07615   case FFEINFO_whereDUMMY:
07616     {
07617       tree type;
07618       ffebld dl;
07619       ffebld dim;
07620       tree low;
07621       tree high;
07622       tree old_sizes;
07623       bool adjustable = FALSE;  /* Conditionally adjustable? */
07624 
07625       type = ffecom_tree_type[bt][kt];
07626       if (ffesymbol_sfdummyparent (s) != NULL)
07627         {
07628     if (current_function_decl == ffecom_outer_function_decl_)
07629       {     /* Exec transition before sfunc
07630              context; get it later. */
07631         break;
07632       }
07633     t = ffecom_get_identifier_ (ffesymbol_text
07634               (ffesymbol_sfdummyparent (s)));
07635         }
07636       else
07637         t =