gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  85 #include "flags.h"
  86 #include "rtl.h"
  87 #include "toplev.h"
  88 #include "tree.h"
  89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  90 #include "convert.h"
  91 #include "ggc.h"
  92 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  93
  94 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  95
  96 /* VMS-specific definitions */
  97 #ifdef VMS
  98 #include <descrip.h>
  99 #define O_RDONLY        0       /* Open arg for Read/Only  */
 100 #define O_WRONLY        1       /* Open arg for Write/Only */
 101 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 102 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 103 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 104 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 107 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 108 static int VMS_fstat (), VMS_stat ();
 109 static char * VMS_strncat ();
 110 static int VMS_read ();
 111 static int VMS_write ();
 112 static int VMS_open ();
 113 static FILE * VMS_fopen ();
 114 static FILE * VMS_freopen ();
 115 static void hack_vms_include_specification ();
 116 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 117 #define ino_t vms_ino_t
 118 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 119 #endif /* VMS */
 120
 121 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 122 #include "com.h"
 123 #include "bad.h"
 124 #include "bld.h"
 125 #include "equiv.h"
 126 #include "expr.h"
 127 #include "implic.h"
 128 #include "info.h"
 129 #include "malloc.h"
 130 #include "src.h"
 131 #include "st.h"
 132 #include "storag.h"
 133 #include "symbol.h"
 134 #include "target.h"
 135 #include "top.h"
 136 #include "type.h"
 137
 138 /* Externals defined here.  */
 139
 140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 141
 142 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 143    reference it.  */
 144
 145 const char * const language_string = "GNU F77";
 146
 147 /* Stream for reading from the input file.  */
 148 FILE *finput;
 149
 150 /* These definitions parallel those in c-decl.c so that code from that
 151    module can be used pretty much as is.  Much of these defs aren't
 152    otherwise used, i.e. by g77 code per se, except some of them are used
 153    to build some of them that are.  The ones that are global (i.e. not
 154    "static") are those that ste.c and such might use (directly
 155    or by using com macros that reference them in their definitions).  */
 156
 157 tree string_type_node;
 158
 159 /* The rest of these are inventions for g77, though there might be
 160    similar things in the C front end.  As they are found, these
 161    inventions should be renamed to be canonical.  Note that only
 162    the ones currently required to be global are so.  */
 163
 164 static tree ffecom_tree_fun_type_void;
 165
 166 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 167 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 168 tree ffecom_integer_one_node;   /* " */
 169 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 170
 171 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 172    just use build_function_type and build_pointer_type on the
 173    appropriate _tree_type array element.  */
 174
 175 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 176 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 177 static tree ffecom_tree_subr_type;
 178 static tree ffecom_tree_ptr_to_subr_type;
 179 static tree ffecom_tree_blockdata_type;
 180
 181 static tree ffecom_tree_xargc_;
 182
 183 ffecomSymbol ffecom_symbol_null_
 184 =
 185 {
 186   NULL_TREE,
 187   NULL_TREE,
 188   NULL_TREE,
 189   NULL_TREE,
 190   false
 191 };
 192 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 193 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 194
 195 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 196 tree ffecom_f2c_integer_type_node;
 197 tree ffecom_f2c_ptr_to_integer_type_node;
 198 tree ffecom_f2c_address_type_node;
 199 tree ffecom_f2c_real_type_node;
 200 tree ffecom_f2c_ptr_to_real_type_node;
 201 tree ffecom_f2c_doublereal_type_node;
 202 tree ffecom_f2c_complex_type_node;
 203 tree ffecom_f2c_doublecomplex_type_node;
 204 tree ffecom_f2c_longint_type_node;
 205 tree ffecom_f2c_logical_type_node;
 206 tree ffecom_f2c_flag_type_node;
 207 tree ffecom_f2c_ftnlen_type_node;
 208 tree ffecom_f2c_ftnlen_zero_node;
 209 tree ffecom_f2c_ftnlen_one_node;
 210 tree ffecom_f2c_ftnlen_two_node;
 211 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 212 tree ffecom_f2c_ftnint_type_node;
 213 tree ffecom_f2c_ptr_to_ftnint_type_node;
 214 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 215
 216 /* Simple definitions and enumerations. */
 217
 218 #ifndef FFECOM_sizeMAXSTACKITEM
 219 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 220                                            larger than this # bytes
 221                                            off stack if possible. */
 222 #endif
 223
 224 /* For systems that have large enough stacks, they should define
 225    this to 0, and here, for ease of use later on, we just undefine
 226    it if it is 0.  */
 227
 228 #if FFECOM_sizeMAXSTACKITEM == 0
 229 #undef FFECOM_sizeMAXSTACKITEM
 230 #endif
 231
 232 typedef enum
 233   {
 234     FFECOM_rttypeVOID_,
 235     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 236     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 237     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 238     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 239     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 240     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 241     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 242     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 243     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 244     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 245     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 246     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 247     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 248     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 249     FFECOM_rttype_
 250   } ffecomRttype_;
 251
 252 /* Internal typedefs. */
 253
 254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 255 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 256 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 257
 258 /* Private include files. */
 259
 260
 261 /* Internal structure definitions. */
 262
 263 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 264 struct _ffecom_concat_list_
 265   {
 266     ffebld *exprs;
 267     int count;
 268     int max;
 269     ffetargetCharacterSize minlen;
 270     ffetargetCharacterSize maxlen;
 271   };
 272 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 273
 274 /* Static functions (internal). */
 275
 276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 277 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 278 static tree ffecom_widest_expr_type_ (ffebld list);
 279 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 280                              tree dest_size, tree source_tree,
 281                              ffebld source, bool scalar_arg);
 282 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 283                                       tree args, tree callee_commons,
 284                                       bool scalar_args);
 285 static tree ffecom_build_f2c_string_ (int i, const char *s);
 286 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 287                           bool is_f2c_complex, tree type,
 288                           tree args, tree dest_tree,
 289                           ffebld dest, bool *dest_used,
 290                           tree callee_commons, bool scalar_args, tree hook);
 291 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 292                                 bool is_f2c_complex, tree type,
 293                                 ffebld left, ffebld right,
 294                                 tree dest_tree, ffebld dest,
 295                                 bool *dest_used, tree callee_commons,
 296                                 bool scalar_args, bool ref, tree hook);
 297 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 298                                  ffebld expr, bool with_null);
 299 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 300 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 301 static ffecomConcatList_
 302   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 303                               ffebld expr,
 304                               ffetargetCharacterSize max);
 305 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 306 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 307                                                 ffetargetCharacterSize max);
 308 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 309                                   ffesymbol member, tree member_type,
 310                                   ffetargetOffset offset);
 311 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 312 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 313                           bool *dest_used, bool assignp, bool widenp);
 314 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 315                                     ffebld dest, bool *dest_used);
 316 static tree ffecom_expr_power_integer_ (ffebld expr);
 317 static void ffecom_expr_transform_ (ffebld expr);
 318 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 319 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 320                                       int code);
 321 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 322 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 323 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 324 static tree ffecom_get_external_identifier_ (ffesymbol s);
 325 static tree ffecom_get_identifier_ (const char *text);
 326 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 327                                   ffeinfoBasictype bt,
 328                                   ffeinfoKindtype kt);
 329 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 330 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 331 static tree ffecom_init_zero_ (tree decl);
 332 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 333                                      tree *maybe_tree);
 334 static tree ffecom_intrinsic_len_ (ffebld expr);
 335 static void ffecom_let_char_ (tree dest_tree,
 336                               tree dest_length,
 337                               ffetargetCharacterSize dest_size,
 338                               ffebld source);
 339 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 340 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 341 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 342 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 343                                       ffebld source);
 344 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 345                                       bool stmtfunc);
 346 static void ffecom_start_progunit_ (void);
 347 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 348 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 349 static void ffecom_transform_common_ (ffesymbol s);
 350 static void ffecom_transform_equiv_ (ffestorag st);
 351 static tree ffecom_transform_namelist_ (ffesymbol s);
 352 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 353                                        tree t);
 354 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 355                                        tree *size, tree tree);
 356 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 357                                  tree dest_tree, ffebld dest,
 358                                  bool *dest_used, tree hook);
 359 static tree ffecom_type_localvar_ (ffesymbol s,
 360                                    ffeinfoBasictype bt,
 361                                    ffeinfoKindtype kt);
 362 static tree ffecom_type_namelist_ (void);
 363 static tree ffecom_type_vardesc_ (void);
 364 static tree ffecom_vardesc_ (ffebld expr);
 365 static tree ffecom_vardesc_array_ (ffesymbol s);
 366 static tree ffecom_vardesc_dims_ (ffesymbol s);
 367 static tree ffecom_convert_narrow_ (tree type, tree expr);
 368 static tree ffecom_convert_widen_ (tree type, tree expr);
 369 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 370
 371 /* These are static functions that parallel those found in the C front
 372    end and thus have the same names.  */
 373
 374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 375 static tree bison_rule_compstmt_ (void);
 376 static void bison_rule_pushlevel_ (void);
 377 static void delete_block (tree block);
 378 static int duplicate_decls (tree newdecl, tree olddecl);
 379 static void finish_decl (tree decl, tree init, bool is_top_level);
 380 static void finish_function (int nested);
 381 static const char *lang_printable_name (tree decl, int v);
 382 static tree lookup_name_current_level (tree name);
 383 static struct binding_level *make_binding_level (void);
 384 static void pop_f_function_context (void);
 385 static void push_f_function_context (void);
 386 static void push_parm_decl (tree parm);
 387 static tree pushdecl_top_level (tree decl);
 388 static int kept_level_p (void);
 389 static tree storedecls (tree decls);
 390 static void store_parm_decls (int is_main_program);
 391 static tree start_decl (tree decl, bool is_top_level);
 392 static void start_function (tree name, tree type, int nested, int public);
 393 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 394 #if FFECOM_GCC_INCLUDE
 395 static void ffecom_file_ (const char *name);
 396 static void ffecom_initialize_char_syntax_ (void);
 397 static void ffecom_close_include_ (FILE *f);
 398 static int ffecom_decode_include_option_ (char *spec);
 399 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 400                                    ffewhereColumn c);
 401 #endif  /* FFECOM_GCC_INCLUDE */
 402
 403 /* Static objects accessed by functions in this module. */
 404
 405 static ffesymbol ffecom_primary_entry_ = NULL;
 406 static ffesymbol ffecom_nested_entry_ = NULL;
 407 static ffeinfoKind ffecom_primary_entry_kind_;
 408 static bool ffecom_primary_entry_is_proc_;
 409 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 410 static tree ffecom_outer_function_decl_;
 411 static tree ffecom_previous_function_decl_;
 412 static tree ffecom_which_entrypoint_decl_;
 413 static tree ffecom_float_zero_ = NULL_TREE;
 414 static tree ffecom_float_half_ = NULL_TREE;
 415 static tree ffecom_double_zero_ = NULL_TREE;
 416 static tree ffecom_double_half_ = NULL_TREE;
 417 static tree ffecom_func_result_;/* For functions. */
 418 static tree ffecom_func_length_;/* For CHARACTER fns. */
 419 static ffebld ffecom_list_blockdata_;
 420 static ffebld ffecom_list_common_;
 421 static ffebld ffecom_master_arglist_;
 422 static ffeinfoBasictype ffecom_master_bt_;
 423 static ffeinfoKindtype ffecom_master_kt_;
 424 static ffetargetCharacterSize ffecom_master_size_;
 425 static int ffecom_num_fns_ = 0;
 426 static int ffecom_num_entrypoints_ = 0;
 427 static bool ffecom_is_altreturning_ = FALSE;
 428 static tree ffecom_multi_type_node_;
 429 static tree ffecom_multi_retval_;
 430 static tree
 431   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 432 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 433 static bool ffecom_doing_entry_ = FALSE;
 434 static bool ffecom_transform_only_dummies_ = FALSE;
 435 static int ffecom_typesize_pointer_;
 436 static int ffecom_typesize_integer1_;
 437
 438 /* Holds pointer-to-function expressions.  */
 439
 440 static tree ffecom_gfrt_[FFECOM_gfrt]
 441 =
 442 {
 443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 444 #include "com-rt.def"
 445 #undef DEFGFRT
 446 };
 447
 448 /* Holds the external names of the functions.  */
 449
 450 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 451 =
 452 {
 453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 454 #include "com-rt.def"
 455 #undef DEFGFRT
 456 };
 457
 458 /* Whether the function returns.  */
 459
 460 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 461 =
 462 {
 463 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 464 #include "com-rt.def"
 465 #undef DEFGFRT
 466 };
 467
 468 /* Whether the function returns type complex.  */
 469
 470 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 471 =
 472 {
 473 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 474 #include "com-rt.def"
 475 #undef DEFGFRT
 476 };
 477
 478 /* Whether the function is const
 479    (i.e., has no side effects and only depends on its arguments).  */
 480
 481 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 482 =
 483 {
 484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 485 #include "com-rt.def"
 486 #undef DEFGFRT
 487 };
 488
 489 /* Type code for the function return value.  */
 490
 491 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 492 =
 493 {
 494 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 495 #include "com-rt.def"
 496 #undef DEFGFRT
 497 };
 498
 499 /* String of codes for the function's arguments.  */
 500
 501 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 502 =
 503 {
 504 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 505 #include "com-rt.def"
 506 #undef DEFGFRT
 507 };
 508 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 509
 510 /* Internal macros. */
 511
 512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 513
 514 /* We let tm.h override the types used here, to handle trivial differences
 515    such as the choice of unsigned int or long unsigned int for size_t.
 516    When machines start needing nontrivial differences in the size type,
 517    it would be best to do something here to figure out automatically
 518    from other information what type to use.  */
 519
 520 #ifndef SIZE_TYPE
 521 #define SIZE_TYPE "long unsigned int"
 522 #endif
 523
 524 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 525 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 526 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 527 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 528
 529 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 530 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 531
 532 /* For each binding contour we allocate a binding_level structure
 533  * which records the names defined in that contour.
 534  * Contours include:
 535  *  0) the global one
 536  *  1) one for each function definition,
 537  *     where internal declarations of the parameters appear.
 538  *
 539  * The current meaning of a name can be found by searching the levels from
 540  * the current one out to the global one.
 541  */
 542
 543 /* Note that the information in the `names' component of the global contour
 544    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 545
 546 struct binding_level
 547   {
 548     /* A chain of _DECL nodes for all variables, constants, functions,
 549        and typedef types.  These are in the reverse of the order supplied.
 550      */
 551     tree names;
 552
 553     /* For each level (except not the global one),
 554        a chain of BLOCK nodes for all the levels
 555        that were entered and exited one level down.  */
 556     tree blocks;
 557
 558     /* The BLOCK node for this level, if one has been preallocated.
 559        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 560     tree this_block;
 561
 562     /* The binding level which this one is contained in (inherits from).  */
 563     struct binding_level *level_chain;
 564
 565     /* 0: no ffecom_prepare_* functions called at this level yet;
 566        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 567        2: ffecom_prepare_end called.  */
 568     int prep_state;
 569   };
 570
 571 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 572
 573 /* The binding level currently in effect.  */
 574
 575 static struct binding_level *current_binding_level;
 576
 577 /* A chain of binding_level structures awaiting reuse.  */
 578
 579 static struct binding_level *free_binding_level;
 580
 581 /* The outermost binding level, for names of file scope.
 582    This is created when the compiler is started and exists
 583    through the entire run.  */
 584
 585 static struct binding_level *global_binding_level;
 586
 587 /* Binding level structures are initialized by copying this one.  */
 588
 589 static struct binding_level clear_binding_level
 590 =
 591 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 592
 593 /* Language-dependent contents of an identifier.  */
 594
 595 struct lang_identifier
 596   {
 597     struct tree_identifier ignore;
 598     tree global_value, local_value, label_value;
 599     bool invented;
 600   };
 601
 602 /* Macros for access to language-specific slots in an identifier.  */
 603 /* Each of these slots contains a DECL node or null.  */
 604
 605 /* This represents the value which the identifier has in the
 606    file-scope namespace.  */
 607 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 608   (((struct lang_identifier *)(NODE))->global_value)
 609 /* This represents the value which the identifier has in the current
 610    scope.  */
 611 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 612   (((struct lang_identifier *)(NODE))->local_value)
 613 /* This represents the value which the identifier has as a label in
 614    the current label scope.  */
 615 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 616   (((struct lang_identifier *)(NODE))->label_value)
 617 /* This is nonzero if the identifier was "made up" by g77 code.  */
 618 #define IDENTIFIER_INVENTED(NODE)       \
 619   (((struct lang_identifier *)(NODE))->invented)
 620
 621 /* In identifiers, C uses the following fields in a special way:
 622    TREE_PUBLIC        to record that there was a previous local extern decl.
 623    TREE_USED          to record that such a decl was used.
 624    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 625
 626 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 627    that have names.  Here so we can clear out their names' definitions
 628    at the end of the function.  */
 629
 630 static tree named_labels;
 631
 632 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 633
 634 static tree shadowed_labels;
 635
 636 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 637 \f
 638 /* Return the subscript expression, modified to do range-checking.
 639
 640    `array' is the array to be checked against.
 641    `element' is the subscript expression to check.
 642    `dim' is the dimension number (starting at 0).
 643    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 644 */
 645
 646 static tree
 647 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 648                          const char *array_name)
 649 {
 650   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 651   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 652   tree cond;
 653   tree die;
 654   tree args;
 655
 656   if (element == error_mark_node)
 657     return element;
 658
 659   if (TREE_TYPE (low) != TREE_TYPE (element))
 660     {
 661       if (TYPE_PRECISION (TREE_TYPE (low))
 662           > TYPE_PRECISION (TREE_TYPE (element)))
 663         element = convert (TREE_TYPE (low), element);
 664       else
 665         {
 666           low = convert (TREE_TYPE (element), low);
 667           if (high)
 668             high = convert (TREE_TYPE (element), high);
 669         }
 670     }
 671
 672   element = ffecom_save_tree (element);
 673   cond = ffecom_2 (LE_EXPR, integer_type_node,
 674                    low,
 675                    element);
 676   if (high)
 677     {
 678       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 679                        cond,
 680                        ffecom_2 (LE_EXPR, integer_type_node,
 681                                  element,
 682                                  high));
 683     }
 684
 685   {
 686     int len;
 687     char *proc;
 688     char *var;
 689     tree arg3;
 690     tree arg2;
 691     tree arg1;
 692     tree arg4;
 693
 694     switch (total_dims)
 695       {
 696       case 0:
 697         var = concat (array_name, "[", (dim ? "end" : "start"),
 698                       "-substring]", NULL);
 699         len = strlen (var) + 1;
 700         arg1 = build_string (len, var);
 701         free (var);
 702         break;
 703
 704       case 1:
 705         len = strlen (array_name) + 1;
 706         arg1 = build_string (len, array_name);
 707         break;
 708
 709       default:
 710         var = xmalloc (strlen (array_name) + 40);
 711         sprintf (var, "%s[subscript-%d-of-%d]",
 712                  array_name,
 713                  dim + 1, total_dims);
 714         len = strlen (var) + 1;
 715         arg1 = build_string (len, var);
 716         free (var);
 717         break;
 718       }
 719
 720     TREE_TYPE (arg1)
 721       = build_type_variant (build_array_type (char_type_node,
 722                                               build_range_type
 723                                               (integer_type_node,
 724                                                integer_one_node,
 725                                                build_int_2 (len, 0))),
 726                             1, 0);
 727     TREE_CONSTANT (arg1) = 1;
 728     TREE_STATIC (arg1) = 1;
 729     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 730                      arg1);
 731
 732     /* s_rnge adds one to the element to print it, so bias against
 733        that -- want to print a faithful *subscript* value.  */
 734     arg2 = convert (ffecom_f2c_ftnint_type_node,
 735                     ffecom_2 (MINUS_EXPR,
 736                               TREE_TYPE (element),
 737                               element,
 738                               convert (TREE_TYPE (element),
 739                                        integer_one_node)));
 740
 741     proc = concat (input_filename, "/",
 742                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 743                    NULL);
 744     len = strlen (proc) + 1;
 745     arg3 = build_string (len, proc);
 746
 747     free (proc);
 748
 749     TREE_TYPE (arg3)
 750       = build_type_variant (build_array_type (char_type_node,
 751                                               build_range_type
 752                                               (integer_type_node,
 753                                                integer_one_node,
 754                                                build_int_2 (len, 0))),
 755                             1, 0);
 756     TREE_CONSTANT (arg3) = 1;
 757     TREE_STATIC (arg3) = 1;
 758     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 759                      arg3);
 760
 761     arg4 = convert (ffecom_f2c_ftnint_type_node,
 762                     build_int_2 (lineno, 0));
 763
 764     arg1 = build_tree_list (NULL_TREE, arg1);
 765     arg2 = build_tree_list (NULL_TREE, arg2);
 766     arg3 = build_tree_list (NULL_TREE, arg3);
 767     arg4 = build_tree_list (NULL_TREE, arg4);
 768     TREE_CHAIN (arg3) = arg4;
 769     TREE_CHAIN (arg2) = arg3;
 770     TREE_CHAIN (arg1) = arg2;
 771
 772     args = arg1;
 773   }
 774   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 775                           args, NULL_TREE);
 776   TREE_SIDE_EFFECTS (die) = 1;
 777
 778   element = ffecom_3 (COND_EXPR,
 779                       TREE_TYPE (element),
 780                       cond,
 781                       element,
 782                       die);
 783
 784   return element;
 785 }
 786
 787 /* Return the computed element of an array reference.
 788
 789    `item' is NULL_TREE, or the transformed pointer to the array.
 790    `expr' is the original opARRAYREF expression, which is transformed
 791      if `item' is NULL_TREE.
 792    `want_ptr' is non-zero if a pointer to the element, instead of
 793      the element itself, is to be returned.  */
 794
 795 static tree
 796 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 797 {
 798   ffebld dims[FFECOM_dimensionsMAX];
 799   int i;
 800   int total_dims;
 801   int flatten = ffe_is_flatten_arrays ();
 802   int need_ptr;
 803   tree array;
 804   tree element;
 805   tree tree_type;
 806   tree tree_type_x;
 807   const char *array_name;
 808   ffetype type;
 809   ffebld list;
 810
 811   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 812     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 813   else
 814     array_name = "[expr?]";
 815
 816   /* Build up ARRAY_REFs in reverse order (since we're column major
 817      here in Fortran land). */
 818
 819   for (i = 0, list = ffebld_right (expr);
 820        list != NULL;
 821        ++i, list = ffebld_trail (list))
 822     {
 823       dims[i] = ffebld_head (list);
 824       type = ffeinfo_type (ffebld_basictype (dims[i]),
 825                            ffebld_kindtype (dims[i]));
 826       if (! flatten
 827           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 828           && ffetype_size (type) > ffecom_typesize_integer1_)
 829         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 830            pointers and 32-bit integers.  Do the full 64-bit pointer
 831            arithmetic, for codes using arrays for nonstandard heap-like
 832            work.  */
 833         flatten = 1;
 834     }
 835
 836   total_dims = i;
 837
 838   need_ptr = want_ptr || flatten;
 839
 840   if (! item)
 841     {
 842       if (need_ptr)
 843         item = ffecom_ptr_to_expr (ffebld_left (expr));
 844       else
 845         item = ffecom_expr (ffebld_left (expr));
 846
 847       if (item == error_mark_node)
 848         return item;
 849
 850       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 851           && ! mark_addressable (item))
 852         return error_mark_node;
 853     }
 854
 855   if (item == error_mark_node)
 856     return item;
 857
 858   if (need_ptr)
 859     {
 860       tree min;
 861
 862       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 863            i >= 0;
 864            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 865         {
 866           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 867           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 868           if (flag_bounds_check)
 869             element = ffecom_subscript_check_ (array, element, i, total_dims,
 870                                                array_name);
 871           if (element == error_mark_node)
 872             return element;
 873
 874           /* Widen integral arithmetic as desired while preserving
 875              signedness.  */
 876           tree_type = TREE_TYPE (element);
 877           tree_type_x = tree_type;
 878           if (tree_type
 879               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 880               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 881             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 882
 883           if (TREE_TYPE (min) != tree_type_x)
 884             min = convert (tree_type_x, min);
 885           if (TREE_TYPE (element) != tree_type_x)
 886             element = convert (tree_type_x, element);
 887
 888           item = ffecom_2 (PLUS_EXPR,
 889                            build_pointer_type (TREE_TYPE (array)),
 890                            item,
 891                            size_binop (MULT_EXPR,
 892                                        size_in_bytes (TREE_TYPE (array)),
 893                                        convert (sizetype,
 894                                                 fold (build (MINUS_EXPR,
 895                                                              tree_type_x,
 896                                                              element, min)))));
 897         }
 898       if (! want_ptr)
 899         {
 900           item = ffecom_1 (INDIRECT_REF,
 901                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 902                            item);
 903         }
 904     }
 905   else
 906     {
 907       for (--i;
 908            i >= 0;
 909            --i)
 910         {
 911           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 912
 913           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 914           if (flag_bounds_check)
 915             element = ffecom_subscript_check_ (array, element, i, total_dims,
 916                                                array_name);
 917           if (element == error_mark_node)
 918             return element;
 919
 920           /* Widen integral arithmetic as desired while preserving
 921              signedness.  */
 922           tree_type = TREE_TYPE (element);
 923           tree_type_x = tree_type;
 924           if (tree_type
 925               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 926               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 927             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 928
 929           element = convert (tree_type_x, element);
 930
 931           item = ffecom_2 (ARRAY_REF,
 932                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 933                            item,
 934                            element);
 935         }
 936     }
 937
 938   return item;
 939 }
 940
 941 /* This is like gcc's stabilize_reference -- in fact, most of the code
 942    comes from that -- but it handles the situation where the reference
 943    is going to have its subparts picked at, and it shouldn't change
 944    (or trigger extra invocations of functions in the subtrees) due to
 945    this.  save_expr is a bit overzealous, because we don't need the
 946    entire thing calculated and saved like a temp.  So, for DECLs, no
 947    change is needed, because these are stable aggregates, and ARRAY_REF
 948    and such might well be stable too, but for things like calculations,
 949    we do need to calculate a snapshot of a value before picking at it.  */
 950
 951 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 952 static tree
 953 ffecom_stabilize_aggregate_ (tree ref)
 954 {
 955   tree result;
 956   enum tree_code code = TREE_CODE (ref);
 957
 958   switch (code)
 959     {
 960     case VAR_DECL:
 961     case PARM_DECL:
 962     case RESULT_DECL:
 963       /* No action is needed in this case.  */
 964       return ref;
 965
 966     case NOP_EXPR:
 967     case CONVERT_EXPR:
 968     case FLOAT_EXPR:
 969     case FIX_TRUNC_EXPR:
 970     case FIX_FLOOR_EXPR:
 971     case FIX_ROUND_EXPR:
 972     case FIX_CEIL_EXPR:
 973       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 974       break;
 975
 976     case INDIRECT_REF:
 977       result = build_nt (INDIRECT_REF,
 978                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 979       break;
 980
 981     case COMPONENT_REF:
 982       result = build_nt (COMPONENT_REF,
 983                          stabilize_reference (TREE_OPERAND (ref, 0)),
 984                          TREE_OPERAND (ref, 1));
 985       break;
 986
 987     case BIT_FIELD_REF:
 988       result = build_nt (BIT_FIELD_REF,
 989                          stabilize_reference (TREE_OPERAND (ref, 0)),
 990                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 991                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 992       break;
 993
 994     case ARRAY_REF:
 995       result = build_nt (ARRAY_REF,
 996                          stabilize_reference (TREE_OPERAND (ref, 0)),
 997                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
 998       break;
 999
1000     case COMPOUND_EXPR:
1001       result = build_nt (COMPOUND_EXPR,
1002                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1003                          stabilize_reference (TREE_OPERAND (ref, 1)));
1004       break;
1005
1006     case RTL_EXPR:
1007       abort ();
1008
1009
1010     default:
1011       return save_expr (ref);
1012
1013     case ERROR_MARK:
1014       return error_mark_node;
1015     }
1016
1017   TREE_TYPE (result) = TREE_TYPE (ref);
1018   TREE_READONLY (result) = TREE_READONLY (ref);
1019   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1020   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1021
1022   return result;
1023 }
1024 #endif
1025
1026 /* A rip-off of gcc's convert.c convert_to_complex function,
1027    reworked to handle complex implemented as C structures
1028    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1029
1030 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1031 static tree
1032 ffecom_convert_to_complex_ (tree type, tree expr)
1033 {
1034   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1035   tree subtype;
1036
1037   assert (TREE_CODE (type) == RECORD_TYPE);
1038
1039   subtype = TREE_TYPE (TYPE_FIELDS (type));
1040
1041   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1042     {
1043       expr = convert (subtype, expr);
1044       return ffecom_2 (COMPLEX_EXPR, type, expr,
1045                        convert (subtype, integer_zero_node));
1046     }
1047
1048   if (form == RECORD_TYPE)
1049     {
1050       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1051       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1052         return expr;
1053       else
1054         {
1055           expr = save_expr (expr);
1056           return ffecom_2 (COMPLEX_EXPR,
1057                            type,
1058                            convert (subtype,
1059                                     ffecom_1 (REALPART_EXPR,
1060                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1061                                               expr)),
1062                            convert (subtype,
1063                                     ffecom_1 (IMAGPART_EXPR,
1064                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1065                                               expr)));
1066         }
1067     }
1068
1069   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1070     error ("pointer value used where a complex was expected");
1071   else
1072     error ("aggregate value used where a complex was expected");
1073
1074   return ffecom_2 (COMPLEX_EXPR, type,
1075                    convert (subtype, integer_zero_node),
1076                    convert (subtype, integer_zero_node));
1077 }
1078 #endif
1079
1080 /* Like gcc's convert(), but crashes if widening might happen.  */
1081
1082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1083 static tree
1084 ffecom_convert_narrow_ (type, expr)
1085      tree type, expr;
1086 {
1087   register tree e = expr;
1088   register enum tree_code code = TREE_CODE (type);
1089
1090   if (type == TREE_TYPE (e)
1091       || TREE_CODE (e) == ERROR_MARK)
1092     return e;
1093   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1094     return fold (build1 (NOP_EXPR, type, e));
1095   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1096       || code == ERROR_MARK)
1097     return error_mark_node;
1098   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1099     {
1100       assert ("void value not ignored as it ought to be" == NULL);
1101       return error_mark_node;
1102     }
1103   assert (code != VOID_TYPE);
1104   if ((code != RECORD_TYPE)
1105       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1106     assert ("converting COMPLEX to REAL" == NULL);
1107   assert (code != ENUMERAL_TYPE);
1108   if (code == INTEGER_TYPE)
1109     {
1110       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1111                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1112               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1113                   && (TYPE_PRECISION (type)
1114                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1115       return fold (convert_to_integer (type, e));
1116     }
1117   if (code == POINTER_TYPE)
1118     {
1119       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1120       return fold (convert_to_pointer (type, e));
1121     }
1122   if (code == REAL_TYPE)
1123     {
1124       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1125       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1126       return fold (convert_to_real (type, e));
1127     }
1128   if (code == COMPLEX_TYPE)
1129     {
1130       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1131       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1132       return fold (convert_to_complex (type, e));
1133     }
1134   if (code == RECORD_TYPE)
1135     {
1136       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1137       /* Check that at least the first field name agrees.  */
1138       assert (DECL_NAME (TYPE_FIELDS (type))
1139               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1140       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1141               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1142       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1143           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1144         return e;
1145       return fold (ffecom_convert_to_complex_ (type, e));
1146     }
1147
1148   assert ("conversion to non-scalar type requested" == NULL);
1149   return error_mark_node;
1150 }
1151 #endif
1152
1153 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1154
1155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1156 static tree
1157 ffecom_convert_widen_ (type, expr)
1158      tree type, expr;
1159 {
1160   register tree e = expr;
1161   register enum tree_code code = TREE_CODE (type);
1162
1163   if (type == TREE_TYPE (e)
1164       || TREE_CODE (e) == ERROR_MARK)
1165     return e;
1166   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1167     return fold (build1 (NOP_EXPR, type, e));
1168   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1169       || code == ERROR_MARK)
1170     return error_mark_node;
1171   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1172     {
1173       assert ("void value not ignored as it ought to be" == NULL);
1174       return error_mark_node;
1175     }
1176   assert (code != VOID_TYPE);
1177   if ((code != RECORD_TYPE)
1178       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1179     assert ("narrowing COMPLEX to REAL" == NULL);
1180   assert (code != ENUMERAL_TYPE);
1181   if (code == INTEGER_TYPE)
1182     {
1183       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1184                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1185               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1186                   && (TYPE_PRECISION (type)
1187                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1188       return fold (convert_to_integer (type, e));
1189     }
1190   if (code == POINTER_TYPE)
1191     {
1192       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1193       return fold (convert_to_pointer (type, e));
1194     }
1195   if (code == REAL_TYPE)
1196     {
1197       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1198       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1199       return fold (convert_to_real (type, e));
1200     }
1201   if (code == COMPLEX_TYPE)
1202     {
1203       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1204       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1205       return fold (convert_to_complex (type, e));
1206     }
1207   if (code == RECORD_TYPE)
1208     {
1209       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1210       /* Check that at least the first field name agrees.  */
1211       assert (DECL_NAME (TYPE_FIELDS (type))
1212               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1213       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1214               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1215       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1216           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1217         return e;
1218       return fold (ffecom_convert_to_complex_ (type, e));
1219     }
1220
1221   assert ("conversion to non-scalar type requested" == NULL);
1222   return error_mark_node;
1223 }
1224 #endif
1225
1226 /* Handles making a COMPLEX type, either the standard
1227    (but buggy?) gbe way, or the safer (but less elegant?)
1228    f2c way.  */
1229
1230 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1231 static tree
1232 ffecom_make_complex_type_ (tree subtype)
1233 {
1234   tree type;
1235   tree realfield;
1236   tree imagfield;
1237
1238   if (ffe_is_emulate_complex ())
1239     {
1240       type = make_node (RECORD_TYPE);
1241       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1242       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1243       TYPE_FIELDS (type) = realfield;
1244       layout_type (type);
1245     }
1246   else
1247     {
1248       type = make_node (COMPLEX_TYPE);
1249       TREE_TYPE (type) = subtype;
1250       layout_type (type);
1251     }
1252
1253   return type;
1254 }
1255 #endif
1256
1257 /* Chooses either the gbe or the f2c way to build a
1258    complex constant.  */
1259
1260 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1261 static tree
1262 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1263 {
1264   tree bothparts;
1265
1266   if (ffe_is_emulate_complex ())
1267     {
1268       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1269       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1270       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1271     }
1272   else
1273     {
1274       bothparts = build_complex (type, realpart, imagpart);
1275     }
1276
1277   return bothparts;
1278 }
1279 #endif
1280
1281 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1282 static tree
1283 ffecom_arglist_expr_ (const char *c, ffebld expr)
1284 {
1285   tree list;
1286   tree *plist = &list;
1287   tree trail = NULL_TREE;       /* Append char length args here. */
1288   tree *ptrail = &trail;
1289   tree length;
1290   ffebld exprh;
1291   tree item;
1292   bool ptr = FALSE;
1293   tree wanted = NULL_TREE;
1294   static char zed[] = "0";
1295
1296   if (c == NULL)
1297     c = &zed[0];
1298
1299   while (expr != NULL)
1300     {
1301       if (*c != '\0')
1302         {
1303           ptr = FALSE;
1304           if (*c == '&')
1305             {
1306               ptr = TRUE;
1307               ++c;
1308             }
1309           switch (*(c++))
1310             {
1311             case '\0':
1312               ptr = TRUE;
1313               wanted = NULL_TREE;
1314               break;
1315
1316             case 'a':
1317               assert (ptr);
1318               wanted = NULL_TREE;
1319               break;
1320
1321             case 'c':
1322               wanted = ffecom_f2c_complex_type_node;
1323               break;
1324
1325             case 'd':
1326               wanted = ffecom_f2c_doublereal_type_node;
1327               break;
1328
1329             case 'e':
1330               wanted = ffecom_f2c_doublecomplex_type_node;
1331               break;
1332
1333             case 'f':
1334               wanted = ffecom_f2c_real_type_node;
1335               break;
1336
1337             case 'i':
1338               wanted = ffecom_f2c_integer_type_node;
1339               break;
1340
1341             case 'j':
1342               wanted = ffecom_f2c_longint_type_node;
1343               break;
1344
1345             default:
1346               assert ("bad argstring code" == NULL);
1347               wanted = NULL_TREE;
1348               break;
1349             }
1350         }
1351
1352       exprh = ffebld_head (expr);
1353       if (exprh == NULL)
1354         wanted = NULL_TREE;
1355
1356       if ((wanted == NULL_TREE)
1357           || (ptr
1358               && (TYPE_MODE
1359                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1360                    [ffeinfo_kindtype (ffebld_info (exprh))])
1361                    == TYPE_MODE (wanted))))
1362         *plist
1363           = build_tree_list (NULL_TREE,
1364                              ffecom_arg_ptr_to_expr (exprh,
1365                                                      &length));
1366       else
1367         {
1368           item = ffecom_arg_expr (exprh, &length);
1369           item = ffecom_convert_widen_ (wanted, item);
1370           if (ptr)
1371             {
1372               item = ffecom_1 (ADDR_EXPR,
1373                                build_pointer_type (TREE_TYPE (item)),
1374                                item);
1375             }
1376           *plist
1377             = build_tree_list (NULL_TREE,
1378                                item);
1379         }
1380
1381       plist = &TREE_CHAIN (*plist);
1382       expr = ffebld_trail (expr);
1383       if (length != NULL_TREE)
1384         {
1385           *ptrail = build_tree_list (NULL_TREE, length);
1386           ptrail = &TREE_CHAIN (*ptrail);
1387         }
1388     }
1389
1390   /* We've run out of args in the call; if the implementation expects
1391      more, supply null pointers for them, which the implementation can
1392      check to see if an arg was omitted. */
1393
1394   while (*c != '\0' && *c != '0')
1395     {
1396       if (*c == '&')
1397         ++c;
1398       else
1399         assert ("missing arg to run-time routine!" == NULL);
1400
1401       switch (*(c++))
1402         {
1403         case '\0':
1404         case 'a':
1405         case 'c':
1406         case 'd':
1407         case 'e':
1408         case 'f':
1409         case 'i':
1410         case 'j':
1411           break;
1412
1413         default:
1414           assert ("bad arg string code" == NULL);
1415           break;
1416         }
1417       *plist
1418         = build_tree_list (NULL_TREE,
1419                            null_pointer_node);
1420       plist = &TREE_CHAIN (*plist);
1421     }
1422
1423   *plist = trail;
1424
1425   return list;
1426 }
1427 #endif
1428
1429 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1430 static tree
1431 ffecom_widest_expr_type_ (ffebld list)
1432 {
1433   ffebld item;
1434   ffebld widest = NULL;
1435   ffetype type;
1436   ffetype widest_type = NULL;
1437   tree t;
1438
1439   for (; list != NULL; list = ffebld_trail (list))
1440     {
1441       item = ffebld_head (list);
1442       if (item == NULL)
1443         continue;
1444       if ((widest != NULL)
1445           && (ffeinfo_basictype (ffebld_info (item))
1446               != ffeinfo_basictype (ffebld_info (widest))))
1447         continue;
1448       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1449                            ffeinfo_kindtype (ffebld_info (item)));
1450       if ((widest == FFEINFO_kindtypeNONE)
1451           || (ffetype_size (type)
1452               > ffetype_size (widest_type)))
1453         {
1454           widest = item;
1455           widest_type = type;
1456         }
1457     }
1458
1459   assert (widest != NULL);
1460   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1461     [ffeinfo_kindtype (ffebld_info (widest))];
1462   assert (t != NULL_TREE);
1463   return t;
1464 }
1465 #endif
1466
1467 /* Check whether a partial overlap between two expressions is possible.
1468
1469    Can *starting* to write a portion of expr1 change the value
1470    computed (perhaps already, *partially*) by expr2?
1471
1472    Currently, this is a concern only for a COMPLEX expr1.  But if it
1473    isn't in COMMON or local EQUIVALENCE, since we don't support
1474    aliasing of arguments, it isn't a concern.  */
1475
1476 static bool
1477 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1478 {
1479   ffesymbol sym;
1480   ffestorag st;
1481
1482   switch (ffebld_op (expr1))
1483     {
1484     case FFEBLD_opSYMTER:
1485       sym = ffebld_symter (expr1);
1486       break;
1487
1488     case FFEBLD_opARRAYREF:
1489       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1490         return FALSE;
1491       sym = ffebld_symter (ffebld_left (expr1));
1492       break;
1493
1494     default:
1495       return FALSE;
1496     }
1497
1498   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1499       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1500           || ! (st = ffesymbol_storage (sym))
1501           || ! ffestorag_parent (st)))
1502     return FALSE;
1503
1504   /* It's in COMMON or local EQUIVALENCE.  */
1505
1506   return TRUE;
1507 }
1508
1509 /* Check whether dest and source might overlap.  ffebld versions of these
1510    might or might not be passed, will be NULL if not.
1511
1512    The test is really whether source_tree is modifiable and, if modified,
1513    might overlap destination such that the value(s) in the destination might
1514    change before it is finally modified.  dest_* are the canonized
1515    destination itself.  */
1516
1517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1518 static bool
1519 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1520                  tree source_tree, ffebld source UNUSED,
1521                  bool scalar_arg)
1522 {
1523   tree source_decl;
1524   tree source_offset;
1525   tree source_size;
1526   tree t;
1527
1528   if (source_tree == NULL_TREE)
1529     return FALSE;
1530
1531   switch (TREE_CODE (source_tree))
1532     {
1533     case ERROR_MARK:
1534     case IDENTIFIER_NODE:
1535     case INTEGER_CST:
1536     case REAL_CST:
1537     case COMPLEX_CST:
1538     case STRING_CST:
1539     case CONST_DECL:
1540     case VAR_DECL:
1541     case RESULT_DECL:
1542     case FIELD_DECL:
1543     case MINUS_EXPR:
1544     case MULT_EXPR:
1545     case TRUNC_DIV_EXPR:
1546     case CEIL_DIV_EXPR:
1547     case FLOOR_DIV_EXPR:
1548     case ROUND_DIV_EXPR:
1549     case TRUNC_MOD_EXPR:
1550     case CEIL_MOD_EXPR:
1551     case FLOOR_MOD_EXPR:
1552     case ROUND_MOD_EXPR:
1553     case RDIV_EXPR:
1554     case EXACT_DIV_EXPR:
1555     case FIX_TRUNC_EXPR:
1556     case FIX_CEIL_EXPR:
1557     case FIX_FLOOR_EXPR:
1558     case FIX_ROUND_EXPR:
1559     case FLOAT_EXPR:
1560     case EXPON_EXPR:
1561     case NEGATE_EXPR:
1562     case MIN_EXPR:
1563     case MAX_EXPR:
1564     case ABS_EXPR:
1565     case FFS_EXPR:
1566     case LSHIFT_EXPR:
1567     case RSHIFT_EXPR:
1568     case LROTATE_EXPR:
1569     case RROTATE_EXPR:
1570     case BIT_IOR_EXPR:
1571     case BIT_XOR_EXPR:
1572     case BIT_AND_EXPR:
1573     case BIT_ANDTC_EXPR:
1574     case BIT_NOT_EXPR:
1575     case TRUTH_ANDIF_EXPR:
1576     case TRUTH_ORIF_EXPR:
1577     case TRUTH_AND_EXPR:
1578     case TRUTH_OR_EXPR:
1579     case TRUTH_XOR_EXPR:
1580     case TRUTH_NOT_EXPR:
1581     case LT_EXPR:
1582     case LE_EXPR:
1583     case GT_EXPR:
1584     case GE_EXPR:
1585     case EQ_EXPR:
1586     case NE_EXPR:
1587     case COMPLEX_EXPR:
1588     case CONJ_EXPR:
1589     case REALPART_EXPR:
1590     case IMAGPART_EXPR:
1591     case LABEL_EXPR:
1592     case COMPONENT_REF:
1593       return FALSE;
1594
1595     case COMPOUND_EXPR:
1596       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1597                               TREE_OPERAND (source_tree, 1), NULL,
1598                               scalar_arg);
1599
1600     case MODIFY_EXPR:
1601       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1602                               TREE_OPERAND (source_tree, 0), NULL,
1603                               scalar_arg);
1604
1605     case CONVERT_EXPR:
1606     case NOP_EXPR:
1607     case NON_LVALUE_EXPR:
1608     case PLUS_EXPR:
1609       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1610         return TRUE;
1611
1612       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1613                                  source_tree);
1614       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1615       break;
1616
1617     case COND_EXPR:
1618       return
1619         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1620                          TREE_OPERAND (source_tree, 1), NULL,
1621                          scalar_arg)
1622           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1623                               TREE_OPERAND (source_tree, 2), NULL,
1624                               scalar_arg);
1625
1626
1627     case ADDR_EXPR:
1628       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1629                                  &source_size,
1630                                  TREE_OPERAND (source_tree, 0));
1631       break;
1632
1633     case PARM_DECL:
1634       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1635         return TRUE;
1636
1637       source_decl = source_tree;
1638       source_offset = bitsize_zero_node;
1639       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1640       break;
1641
1642     case SAVE_EXPR:
1643     case REFERENCE_EXPR:
1644     case PREDECREMENT_EXPR:
1645     case PREINCREMENT_EXPR:
1646     case POSTDECREMENT_EXPR:
1647     case POSTINCREMENT_EXPR:
1648     case INDIRECT_REF:
1649     case ARRAY_REF:
1650     case CALL_EXPR:
1651     default:
1652       return TRUE;
1653     }
1654
1655   /* Come here when source_decl, source_offset, and source_size filled
1656      in appropriately.  */
1657
1658   if (source_decl == NULL_TREE)
1659     return FALSE;               /* No decl involved, so no overlap. */
1660
1661   if (source_decl != dest_decl)
1662     return FALSE;               /* Different decl, no overlap. */
1663
1664   if (TREE_CODE (dest_size) == ERROR_MARK)
1665     return TRUE;                /* Assignment into entire assumed-size
1666                                    array?  Shouldn't happen.... */
1667
1668   t = ffecom_2 (LE_EXPR, integer_type_node,
1669                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1670                           dest_offset,
1671                           convert (TREE_TYPE (dest_offset),
1672                                    dest_size)),
1673                 convert (TREE_TYPE (dest_offset),
1674                          source_offset));
1675
1676   if (integer_onep (t))
1677     return FALSE;               /* Destination precedes source. */
1678
1679   if (!scalar_arg
1680       || (source_size == NULL_TREE)
1681       || (TREE_CODE (source_size) == ERROR_MARK)
1682       || integer_zerop (source_size))
1683     return TRUE;                /* No way to tell if dest follows source. */
1684
1685   t = ffecom_2 (LE_EXPR, integer_type_node,
1686                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1687                           source_offset,
1688                           convert (TREE_TYPE (source_offset),
1689                                    source_size)),
1690                 convert (TREE_TYPE (source_offset),
1691                          dest_offset));
1692
1693   if (integer_onep (t))
1694     return FALSE;               /* Destination follows source. */
1695
1696   return TRUE;          /* Destination and source overlap. */
1697 }
1698 #endif
1699
1700 /* Check whether dest might overlap any of a list of arguments or is
1701    in a COMMON area the callee might know about (and thus modify).  */
1702
1703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1704 static bool
1705 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1706                           tree args, tree callee_commons,
1707                           bool scalar_args)
1708 {
1709   tree arg;
1710   tree dest_decl;
1711   tree dest_offset;
1712   tree dest_size;
1713
1714   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1715                              dest_tree);
1716
1717   if (dest_decl == NULL_TREE)
1718     return FALSE;               /* Seems unlikely! */
1719
1720   /* If the decl cannot be determined reliably, or if its in COMMON
1721      and the callee isn't known to not futz with COMMON via other
1722      means, overlap might happen.  */
1723
1724   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1725       || ((callee_commons != NULL_TREE)
1726           && TREE_PUBLIC (dest_decl)))
1727     return TRUE;
1728
1729   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1730     {
1731       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1732           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1733                               arg, NULL, scalar_args))
1734         return TRUE;
1735     }
1736
1737   return FALSE;
1738 }
1739 #endif
1740
1741 /* Build a string for a variable name as used by NAMELIST.  This means that
1742    if we're using the f2c library, we build an uppercase string, since
1743    f2c does this.  */
1744
1745 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1746 static tree
1747 ffecom_build_f2c_string_ (int i, const char *s)
1748 {
1749   if (!ffe_is_f2c_library ())
1750     return build_string (i, s);
1751
1752   {
1753     char *tmp;
1754     const char *p;
1755     char *q;
1756     char space[34];
1757     tree t;
1758
1759     if (((size_t) i) > ARRAY_SIZE (space))
1760       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1761     else
1762       tmp = &space[0];
1763
1764     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1765       *q = TOUPPER (*p);
1766     *q = '\0';
1767
1768     t = build_string (i, tmp);
1769
1770     if (((size_t) i) > ARRAY_SIZE (space))
1771       malloc_kill_ks (malloc_pool_image (), tmp, i);
1772
1773     return t;
1774   }
1775 }
1776
1777 #endif
1778 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1779    type to just get whatever the function returns), handling the
1780    f2c value-returning convention, if required, by prepending
1781    to the arglist a pointer to a temporary to receive the return value.  */
1782
1783 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1784 static tree
1785 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1786               tree type, tree args, tree dest_tree,
1787               ffebld dest, bool *dest_used, tree callee_commons,
1788               bool scalar_args, tree hook)
1789 {
1790   tree item;
1791   tree tempvar;
1792
1793   if (dest_used != NULL)
1794     *dest_used = FALSE;
1795
1796   if (is_f2c_complex)
1797     {
1798       if ((dest_used == NULL)
1799           || (dest == NULL)
1800           || (ffeinfo_basictype (ffebld_info (dest))
1801               != FFEINFO_basictypeCOMPLEX)
1802           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1803           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1804           || ffecom_args_overlapping_ (dest_tree, dest, args,
1805                                        callee_commons,
1806                                        scalar_args))
1807         {
1808 #ifdef HOHO
1809           tempvar = ffecom_make_tempvar (ffecom_tree_type
1810                                          [FFEINFO_basictypeCOMPLEX][kt],
1811                                          FFETARGET_charactersizeNONE,
1812                                          -1);
1813 #else
1814           tempvar = hook;
1815           assert (tempvar);
1816 #endif
1817         }
1818       else
1819         {
1820           *dest_used = TRUE;
1821           tempvar = dest_tree;
1822           type = NULL_TREE;
1823         }
1824
1825       item
1826         = build_tree_list (NULL_TREE,
1827                            ffecom_1 (ADDR_EXPR,
1828                                      build_pointer_type (TREE_TYPE (tempvar)),
1829                                      tempvar));
1830       TREE_CHAIN (item) = args;
1831
1832       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1833                         item, NULL_TREE);
1834
1835       if (tempvar != dest_tree)
1836         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1837     }
1838   else
1839     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1840                       args, NULL_TREE);
1841
1842   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1843     item = ffecom_convert_narrow_ (type, item);
1844
1845   return item;
1846 }
1847 #endif
1848
1849 /* Given two arguments, transform them and make a call to the given
1850    function via ffecom_call_.  */
1851
1852 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1853 static tree
1854 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1855                     tree type, ffebld left, ffebld right,
1856                     tree dest_tree, ffebld dest, bool *dest_used,
1857                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1858 {
1859   tree left_tree;
1860   tree right_tree;
1861   tree left_length;
1862   tree right_length;
1863
1864   if (ref)
1865     {
1866       /* Pass arguments by reference.  */
1867       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1868       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1869     }
1870   else
1871     {
1872       /* Pass arguments by value.  */
1873       left_tree = ffecom_arg_expr (left, &left_length);
1874       right_tree = ffecom_arg_expr (right, &right_length);
1875     }
1876
1877
1878   left_tree = build_tree_list (NULL_TREE, left_tree);
1879   right_tree = build_tree_list (NULL_TREE, right_tree);
1880   TREE_CHAIN (left_tree) = right_tree;
1881
1882   if (left_length != NULL_TREE)
1883     {
1884       left_length = build_tree_list (NULL_TREE, left_length);
1885       TREE_CHAIN (right_tree) = left_length;
1886     }
1887
1888   if (right_length != NULL_TREE)
1889     {
1890       right_length = build_tree_list (NULL_TREE, right_length);
1891       if (left_length != NULL_TREE)
1892         TREE_CHAIN (left_length) = right_length;
1893       else
1894         TREE_CHAIN (right_tree) = right_length;
1895     }
1896
1897   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1898                        dest_tree, dest, dest_used, callee_commons,
1899                        scalar_args, hook);
1900 }
1901 #endif
1902
1903 /* Return ptr/length args for char subexpression
1904
1905    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1906    subexpressions by constructing the appropriate trees for the ptr-to-
1907    character-text and length-of-character-text arguments in a calling
1908    sequence.
1909
1910    Note that if with_null is TRUE, and the expression is an opCONTER,
1911    a null byte is appended to the string.  */
1912
1913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1914 static void
1915 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1916 {
1917   tree item;
1918   tree high;
1919   ffetargetCharacter1 val;
1920   ffetargetCharacterSize newlen;
1921
1922   switch (ffebld_op (expr))
1923     {
1924     case FFEBLD_opCONTER:
1925       val = ffebld_constant_character1 (ffebld_conter (expr));
1926       newlen = ffetarget_length_character1 (val);
1927       if (with_null)
1928         {
1929           /* Begin FFETARGET-NULL-KLUDGE.  */
1930           if (newlen != 0)
1931             ++newlen;
1932         }
1933       *length = build_int_2 (newlen, 0);
1934       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1935       high = build_int_2 (newlen, 0);
1936       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1937       item = build_string (newlen,
1938                            ffetarget_text_character1 (val));
1939       /* End FFETARGET-NULL-KLUDGE.  */
1940       TREE_TYPE (item)
1941         = build_type_variant
1942           (build_array_type
1943            (char_type_node,
1944             build_range_type
1945             (ffecom_f2c_ftnlen_type_node,
1946              ffecom_f2c_ftnlen_one_node,
1947              high)),
1948            1, 0);
1949       TREE_CONSTANT (item) = 1;
1950       TREE_STATIC (item) = 1;
1951       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1952                        item);
1953       break;
1954
1955     case FFEBLD_opSYMTER:
1956       {
1957         ffesymbol s = ffebld_symter (expr);
1958
1959         item = ffesymbol_hook (s).decl_tree;
1960         if (item == NULL_TREE)
1961           {
1962             s = ffecom_sym_transform_ (s);
1963             item = ffesymbol_hook (s).decl_tree;
1964           }
1965         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1966           {
1967             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1968               *length = ffesymbol_hook (s).length_tree;
1969             else
1970               {
1971                 *length = build_int_2 (ffesymbol_size (s), 0);
1972                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1973               }
1974           }
1975         else if (item == error_mark_node)
1976           *length = error_mark_node;
1977         else
1978           /* FFEINFO_kindFUNCTION.  */
1979           *length = NULL_TREE;
1980         if (!ffesymbol_hook (s).addr
1981             && (item != error_mark_node))
1982           item = ffecom_1 (ADDR_EXPR,
1983                            build_pointer_type (TREE_TYPE (item)),
1984                            item);
1985       }
1986       break;
1987
1988     case FFEBLD_opARRAYREF:
1989       {
1990         ffecom_char_args_ (&item, length, ffebld_left (expr));
1991
1992         if (item == error_mark_node || *length == error_mark_node)
1993           {
1994             item = *length = error_mark_node;
1995             break;
1996           }
1997
1998         item = ffecom_arrayref_ (item, expr, 1);
1999       }
2000       break;
2001
2002     case FFEBLD_opSUBSTR:
2003       {
2004         ffebld start;
2005         ffebld end;
2006         ffebld thing = ffebld_right (expr);
2007         tree start_tree;
2008         tree end_tree;
2009         const char *char_name;
2010         ffebld left_symter;
2011         tree array;
2012
2013         assert (ffebld_op (thing) == FFEBLD_opITEM);
2014         start = ffebld_head (thing);
2015         thing = ffebld_trail (thing);
2016         assert (ffebld_trail (thing) == NULL);
2017         end = ffebld_head (thing);
2018
2019         /* Determine name for pretty-printing range-check errors.  */
2020         for (left_symter = ffebld_left (expr);
2021              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2022              left_symter = ffebld_left (left_symter))
2023           ;
2024         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2025           char_name = ffesymbol_text (ffebld_symter (left_symter));
2026         else
2027           char_name = "[expr?]";
2028
2029         ffecom_char_args_ (&item, length, ffebld_left (expr));
2030
2031         if (item == error_mark_node || *length == error_mark_node)
2032           {
2033             item = *length = error_mark_node;
2034             break;
2035           }
2036
2037         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2038
2039         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2040
2041         if (start == NULL)
2042           {
2043             if (end == NULL)
2044               ;
2045             else
2046               {
2047                 end_tree = ffecom_expr (end);
2048                 if (flag_bounds_check)
2049                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2050                                                       char_name);
2051                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2052                                     end_tree);
2053
2054                 if (end_tree == error_mark_node)
2055                   {
2056                     item = *length = error_mark_node;
2057                     break;
2058                   }
2059
2060                 *length = end_tree;
2061               }
2062           }
2063         else
2064           {
2065             start_tree = ffecom_expr (start);
2066             if (flag_bounds_check)
2067               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2068                                                     char_name);
2069             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2070                                   start_tree);
2071
2072             if (start_tree == error_mark_node)
2073               {
2074                 item = *length = error_mark_node;
2075                 break;
2076               }
2077
2078             start_tree = ffecom_save_tree (start_tree);
2079
2080             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2081                              item,
2082                              ffecom_2 (MINUS_EXPR,
2083                                        TREE_TYPE (start_tree),
2084                                        start_tree,
2085                                        ffecom_f2c_ftnlen_one_node));
2086
2087             if (end == NULL)
2088               {
2089                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090                                     ffecom_f2c_ftnlen_one_node,
2091                                     ffecom_2 (MINUS_EXPR,
2092                                               ffecom_f2c_ftnlen_type_node,
2093                                               *length,
2094                                               start_tree));
2095               }
2096             else
2097               {
2098                 end_tree = ffecom_expr (end);
2099                 if (flag_bounds_check)
2100                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2101                                                       char_name);
2102                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2103                                     end_tree);
2104
2105                 if (end_tree == error_mark_node)
2106                   {
2107                     item = *length = error_mark_node;
2108                     break;
2109                   }
2110
2111                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2112                                     ffecom_f2c_ftnlen_one_node,
2113                                     ffecom_2 (MINUS_EXPR,
2114                                               ffecom_f2c_ftnlen_type_node,
2115                                               end_tree, start_tree));
2116               }
2117           }
2118       }
2119       break;
2120
2121     case FFEBLD_opFUNCREF:
2122       {
2123         ffesymbol s = ffebld_symter (ffebld_left (expr));
2124         tree tempvar;
2125         tree args;
2126         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2127         ffecomGfrt ix;
2128
2129         if (size == FFETARGET_charactersizeNONE)
2130           /* ~~Kludge alert!  This should someday be fixed. */
2131           size = 24;
2132
2133         *length = build_int_2 (size, 0);
2134         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2135
2136         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2137             == FFEINFO_whereINTRINSIC)
2138           {
2139             if (size == 1)
2140               {
2141                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2142                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2143                                                NULL, NULL);
2144                 break;
2145               }
2146             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2147             assert (ix != FFECOM_gfrt);
2148             item = ffecom_gfrt_tree_ (ix);
2149           }
2150         else
2151           {
2152             ix = FFECOM_gfrt;
2153             item = ffesymbol_hook (s).decl_tree;
2154             if (item == NULL_TREE)
2155               {
2156                 s = ffecom_sym_transform_ (s);
2157                 item = ffesymbol_hook (s).decl_tree;
2158               }
2159             if (item == error_mark_node)
2160               {
2161                 item = *length = error_mark_node;
2162                 break;
2163               }
2164
2165             if (!ffesymbol_hook (s).addr)
2166               item = ffecom_1_fn (item);
2167           }
2168
2169 #ifdef HOHO
2170         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2171 #else
2172         tempvar = ffebld_nonter_hook (expr);
2173         assert (tempvar);
2174 #endif
2175         tempvar = ffecom_1 (ADDR_EXPR,
2176                             build_pointer_type (TREE_TYPE (tempvar)),
2177                             tempvar);
2178
2179         args = build_tree_list (NULL_TREE, tempvar);
2180
2181         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2182           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2183         else
2184           {
2185             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2186             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2187               {
2188                 TREE_CHAIN (TREE_CHAIN (args))
2189                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2190                                           ffebld_right (expr));
2191               }
2192             else
2193               {
2194                 TREE_CHAIN (TREE_CHAIN (args))
2195                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2196               }
2197           }
2198
2199         item = ffecom_3s (CALL_EXPR,
2200                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2201                           item, args, NULL_TREE);
2202         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2203                          tempvar);
2204       }
2205       break;
2206
2207     case FFEBLD_opCONVERT:
2208
2209       ffecom_char_args_ (&item, length, ffebld_left (expr));
2210
2211       if (item == error_mark_node || *length == error_mark_node)
2212         {
2213           item = *length = error_mark_node;
2214           break;
2215         }
2216
2217       if ((ffebld_size_known (ffebld_left (expr))
2218            == FFETARGET_charactersizeNONE)
2219           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2220         {                       /* Possible blank-padding needed, copy into
2221                                    temporary. */
2222           tree tempvar;
2223           tree args;
2224           tree newlen;
2225
2226 #ifdef HOHO
2227           tempvar = ffecom_make_tempvar (char_type_node,
2228                                          ffebld_size (expr), -1);
2229 #else
2230           tempvar = ffebld_nonter_hook (expr);
2231           assert (tempvar);
2232 #endif
2233           tempvar = ffecom_1 (ADDR_EXPR,
2234                               build_pointer_type (TREE_TYPE (tempvar)),
2235                               tempvar);
2236
2237           newlen = build_int_2 (ffebld_size (expr), 0);
2238           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2239
2240           args = build_tree_list (NULL_TREE, tempvar);
2241           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2242           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2243           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2244             = build_tree_list (NULL_TREE, *length);
2245
2246           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2247           TREE_SIDE_EFFECTS (item) = 1;
2248           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2249                            tempvar);
2250           *length = newlen;
2251         }
2252       else
2253         {                       /* Just truncate the length. */
2254           *length = build_int_2 (ffebld_size (expr), 0);
2255           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2256         }
2257       break;
2258
2259     default:
2260       assert ("bad op for single char arg expr" == NULL);
2261       item = NULL_TREE;
2262       break;
2263     }
2264
2265   *xitem = item;
2266 }
2267 #endif
2268
2269 /* Check the size of the type to be sure it doesn't overflow the
2270    "portable" capacities of the compiler back end.  `dummy' types
2271    can generally overflow the normal sizes as long as the computations
2272    themselves don't overflow.  A particular target of the back end
2273    must still enforce its size requirements, though, and the back
2274    end takes care of this in stor-layout.c.  */
2275
2276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2277 static tree
2278 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2279 {
2280   if (TREE_CODE (type) == ERROR_MARK)
2281     return type;
2282
2283   if (TYPE_SIZE (type) == NULL_TREE)
2284     return type;
2285
2286   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2287     return type;
2288
2289   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2290       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2291                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2292     {
2293       ffebad_start (FFEBAD_ARRAY_LARGE);
2294       ffebad_string (ffesymbol_text (s));
2295       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2296       ffebad_finish ();
2297
2298       return error_mark_node;
2299     }
2300
2301   return type;
2302 }
2303 #endif
2304
2305 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2306    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2307    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2308
2309 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2310 static tree
2311 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2312 {
2313   ffetargetCharacterSize sz = ffesymbol_size (s);
2314   tree highval;
2315   tree tlen;
2316   tree type = *xtype;
2317
2318   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2319     tlen = NULL_TREE;           /* A statement function, no length passed. */
2320   else
2321     {
2322       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2323         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2324                                                ffesymbol_text (s));
2325       else
2326         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2327       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2328 #if BUILT_FOR_270
2329       DECL_ARTIFICIAL (tlen) = 1;
2330 #endif
2331     }
2332
2333   if (sz == FFETARGET_charactersizeNONE)
2334     {
2335       assert (tlen != NULL_TREE);
2336       highval = variable_size (tlen);
2337     }
2338   else
2339     {
2340       highval = build_int_2 (sz, 0);
2341       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2342     }
2343
2344   type = build_array_type (type,
2345                            build_range_type (ffecom_f2c_ftnlen_type_node,
2346                                              ffecom_f2c_ftnlen_one_node,
2347                                              highval));
2348
2349   *xtype = type;
2350   return tlen;
2351 }
2352
2353 #endif
2354 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2355
2356    ffecomConcatList_ catlist;
2357    ffebld expr;  // expr of CHARACTER basictype.
2358    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2359    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2360
2361    Scans expr for character subexpressions, updates and returns catlist
2362    accordingly.  */
2363
2364 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2365 static ffecomConcatList_
2366 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2367                             ffetargetCharacterSize max)
2368 {
2369   ffetargetCharacterSize sz;
2370
2371 recurse:                        /* :::::::::::::::::::: */
2372
2373   if (expr == NULL)
2374     return catlist;
2375
2376   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2377     return catlist;             /* Don't append any more items. */
2378
2379   switch (ffebld_op (expr))
2380     {
2381     case FFEBLD_opCONTER:
2382     case FFEBLD_opSYMTER:
2383     case FFEBLD_opARRAYREF:
2384     case FFEBLD_opFUNCREF:
2385     case FFEBLD_opSUBSTR:
2386     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2387                                    if they don't need to preserve it. */
2388       if (catlist.count == catlist.max)
2389         {                       /* Make a (larger) list. */
2390           ffebld *newx;
2391           int newmax;
2392
2393           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2394           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2395                                 newmax * sizeof (newx[0]));
2396           if (catlist.max != 0)
2397             {
2398               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2399               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2400                               catlist.max * sizeof (newx[0]));
2401             }
2402           catlist.max = newmax;
2403           catlist.exprs = newx;
2404         }
2405       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2406         catlist.minlen += sz;
2407       else
2408         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2409       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2410         catlist.maxlen = sz;
2411       else
2412         catlist.maxlen += sz;
2413       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2414         {                       /* This item overlaps (or is beyond) the end
2415                                    of the destination. */
2416           switch (ffebld_op (expr))
2417             {
2418             case FFEBLD_opCONTER:
2419             case FFEBLD_opSYMTER:
2420             case FFEBLD_opARRAYREF:
2421             case FFEBLD_opFUNCREF:
2422             case FFEBLD_opSUBSTR:
2423               /* ~~Do useful truncations here. */
2424               break;
2425
2426             default:
2427               assert ("op changed or inconsistent switches!" == NULL);
2428               break;
2429             }
2430         }
2431       catlist.exprs[catlist.count++] = expr;
2432       return catlist;
2433
2434     case FFEBLD_opPAREN:
2435       expr = ffebld_left (expr);
2436       goto recurse;             /* :::::::::::::::::::: */
2437
2438     case FFEBLD_opCONCATENATE:
2439       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2440       expr = ffebld_right (expr);
2441       goto recurse;             /* :::::::::::::::::::: */
2442
2443 #if 0                           /* Breaks passing small actual arg to larger
2444                                    dummy arg of sfunc */
2445     case FFEBLD_opCONVERT:
2446       expr = ffebld_left (expr);
2447       {
2448         ffetargetCharacterSize cmax;
2449
2450         cmax = catlist.len + ffebld_size_known (expr);
2451
2452         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2453           max = cmax;
2454       }
2455       goto recurse;             /* :::::::::::::::::::: */
2456 #endif
2457
2458     case FFEBLD_opANY:
2459       return catlist;
2460
2461     default:
2462       assert ("bad op in _gather_" == NULL);
2463       return catlist;
2464     }
2465 }
2466
2467 #endif
2468 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2469
2470    ffecomConcatList_ catlist;
2471    ffecom_concat_list_kill_(catlist);
2472
2473    Anything allocated within the list info is deallocated.  */
2474
2475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2476 static void
2477 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2478 {
2479   if (catlist.max != 0)
2480     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2481                     catlist.max * sizeof (catlist.exprs[0]));
2482 }
2483
2484 #endif
2485 /* Make list of concatenated string exprs.
2486
2487    Returns a flattened list of concatenated subexpressions given a
2488    tree of such expressions.  */
2489
2490 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2491 static ffecomConcatList_
2492 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2493 {
2494   ffecomConcatList_ catlist;
2495
2496   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2497   return ffecom_concat_list_gather_ (catlist, expr, max);
2498 }
2499
2500 #endif
2501
2502 /* Provide some kind of useful info on member of aggregate area,
2503    since current g77/gcc technology does not provide debug info
2504    on these members.  */
2505
2506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2507 static void
2508 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2509                       tree member_type UNUSED, ffetargetOffset offset)
2510 {
2511   tree value;
2512   tree decl;
2513   int len;
2514   char *buff;
2515   char space[120];
2516 #if 0
2517   tree type_id;
2518
2519   for (type_id = member_type;
2520        TREE_CODE (type_id) != IDENTIFIER_NODE;
2521        )
2522     {
2523       switch (TREE_CODE (type_id))
2524         {
2525         case INTEGER_TYPE:
2526         case REAL_TYPE:
2527           type_id = TYPE_NAME (type_id);
2528           break;
2529
2530         case ARRAY_TYPE:
2531         case COMPLEX_TYPE:
2532           type_id = TREE_TYPE (type_id);
2533           break;
2534
2535         default:
2536           assert ("no IDENTIFIER_NODE for type!" == NULL);
2537           type_id = error_mark_node;
2538           break;
2539         }
2540     }
2541 #endif
2542
2543   if (ffecom_transform_only_dummies_
2544       || !ffe_is_debug_kludge ())
2545     return;     /* Can't do this yet, maybe later. */
2546
2547   len = 60
2548     + strlen (aggr_type)
2549     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2550 #if 0
2551     + IDENTIFIER_LENGTH (type_id);
2552 #endif
2553
2554   if (((size_t) len) >= ARRAY_SIZE (space))
2555     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2556   else
2557     buff = &space[0];
2558
2559   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2560            aggr_type,
2561            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2562            (long int) offset);
2563
2564   value = build_string (len, buff);
2565   TREE_TYPE (value)
2566     = build_type_variant (build_array_type (char_type_node,
2567                                             build_range_type
2568                                             (integer_type_node,
2569                                              integer_one_node,
2570                                              build_int_2 (strlen (buff), 0))),
2571                           1, 0);
2572   decl = build_decl (VAR_DECL,
2573                      ffecom_get_identifier_ (ffesymbol_text (member)),
2574                      TREE_TYPE (value));
2575   TREE_CONSTANT (decl) = 1;
2576   TREE_STATIC (decl) = 1;
2577   DECL_INITIAL (decl) = error_mark_node;
2578   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2579   decl = start_decl (decl, FALSE);
2580   finish_decl (decl, value, FALSE);
2581
2582   if (buff != &space[0])
2583     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2584 }
2585 #endif
2586
2587 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2588
2589    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2590    int i;  // entry# for this entrypoint (used by master fn)
2591    ffecom_do_entrypoint_(s,i);
2592
2593    Makes a public entry point that calls our private master fn (already
2594    compiled).  */
2595
2596 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2597 static void
2598 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2599 {
2600   ffebld item;
2601   tree type;                    /* Type of function. */
2602   tree multi_retval;            /* Var holding return value (union). */
2603   tree result;                  /* Var holding result. */
2604   ffeinfoBasictype bt;
2605   ffeinfoKindtype kt;
2606   ffeglobal g;
2607   ffeglobalType gt;
2608   bool charfunc;                /* All entry points return same type
2609                                    CHARACTER. */
2610   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2611   bool multi;                   /* Master fn has multiple return types. */
2612   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2613   int old_lineno = lineno;
2614   const char *old_input_filename = input_filename;
2615
2616   input_filename = ffesymbol_where_filename (fn);
2617   lineno = ffesymbol_where_filelinenum (fn);
2618
2619   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2620
2621   switch (ffecom_primary_entry_kind_)
2622     {
2623     case FFEINFO_kindFUNCTION:
2624
2625       /* Determine actual return type for function. */
2626
2627       gt = FFEGLOBAL_typeFUNC;
2628       bt = ffesymbol_basictype (fn);
2629       kt = ffesymbol_kindtype (fn);
2630       if (bt == FFEINFO_basictypeNONE)
2631         {
2632           ffeimplic_establish_symbol (fn);
2633           if (ffesymbol_funcresult (fn) != NULL)
2634             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2635           bt = ffesymbol_basictype (fn);
2636           kt = ffesymbol_kindtype (fn);
2637         }
2638
2639       if (bt == FFEINFO_basictypeCHARACTER)
2640         charfunc = TRUE, cmplxfunc = FALSE;
2641       else if ((bt == FFEINFO_basictypeCOMPLEX)
2642                && ffesymbol_is_f2c (fn))
2643         charfunc = FALSE, cmplxfunc = TRUE;
2644       else
2645         charfunc = cmplxfunc = FALSE;
2646
2647       if (charfunc)
2648         type = ffecom_tree_fun_type_void;
2649       else if (ffesymbol_is_f2c (fn))
2650         type = ffecom_tree_fun_type[bt][kt];
2651       else
2652         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2653
2654       if ((type == NULL_TREE)
2655           || (TREE_TYPE (type) == NULL_TREE))
2656         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2657
2658       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2659       break;
2660
2661     case FFEINFO_kindSUBROUTINE:
2662       gt = FFEGLOBAL_typeSUBR;
2663       bt = FFEINFO_basictypeNONE;
2664       kt = FFEINFO_kindtypeNONE;
2665       if (ffecom_is_altreturning_)
2666         {                       /* Am _I_ altreturning? */
2667           for (item = ffesymbol_dummyargs (fn);
2668                item != NULL;
2669                item = ffebld_trail (item))
2670             {
2671               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2672                 {
2673                   altreturning = TRUE;
2674                   break;
2675                 }
2676             }
2677           if (altreturning)
2678             type = ffecom_tree_subr_type;
2679           else
2680             type = ffecom_tree_fun_type_void;
2681         }
2682       else
2683         type = ffecom_tree_fun_type_void;
2684       charfunc = FALSE;
2685       cmplxfunc = FALSE;
2686       multi = FALSE;
2687       break;
2688
2689     default:
2690       assert ("say what??" == NULL);
2691       /* Fall through. */
2692     case FFEINFO_kindANY:
2693       gt = FFEGLOBAL_typeANY;
2694       bt = FFEINFO_basictypeNONE;
2695       kt = FFEINFO_kindtypeNONE;
2696       type = error_mark_node;
2697       charfunc = FALSE;
2698       cmplxfunc = FALSE;
2699       multi = FALSE;
2700       break;
2701     }
2702
2703   /* build_decl uses the current lineno and input_filename to set the decl
2704      source info.  So, I've putzed with ffestd and ffeste code to update that
2705      source info to point to the appropriate statement just before calling
2706      ffecom_do_entrypoint (which calls this fn).  */
2707
2708   start_function (ffecom_get_external_identifier_ (fn),
2709                   type,
2710                   0,            /* nested/inline */
2711                   1);           /* TREE_PUBLIC */
2712
2713   if (((g = ffesymbol_global (fn)) != NULL)
2714       && ((ffeglobal_type (g) == gt)
2715           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2716     {
2717       ffeglobal_set_hook (g, current_function_decl);
2718     }
2719
2720   /* Reset args in master arg list so they get retransitioned. */
2721
2722   for (item = ffecom_master_arglist_;
2723        item != NULL;
2724        item = ffebld_trail (item))
2725     {
2726       ffebld arg;
2727       ffesymbol s;
2728
2729       arg = ffebld_head (item);
2730       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2731         continue;               /* Alternate return or some such thing. */
2732       s = ffebld_symter (arg);
2733       ffesymbol_hook (s).decl_tree = NULL_TREE;
2734       ffesymbol_hook (s).length_tree = NULL_TREE;
2735     }
2736
2737   /* Build dummy arg list for this entry point. */
2738
2739   if (charfunc || cmplxfunc)
2740     {                           /* Prepend arg for where result goes. */
2741       tree type;
2742       tree length;
2743
2744       if (charfunc)
2745         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2746       else
2747         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2748
2749       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2750
2751       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2752
2753       if (charfunc)
2754         length = ffecom_char_enhance_arg_ (&type, fn);
2755       else
2756         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2757
2758       type = build_pointer_type (type);
2759       result = build_decl (PARM_DECL, result, type);
2760
2761       push_parm_decl (result);
2762       ffecom_func_result_ = result;
2763
2764       if (charfunc)
2765         {
2766           push_parm_decl (length);
2767           ffecom_func_length_ = length;
2768         }
2769     }
2770   else
2771     result = DECL_RESULT (current_function_decl);
2772
2773   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2774
2775   store_parm_decls (0);
2776
2777   ffecom_start_compstmt ();
2778   /* Disallow temp vars at this level.  */
2779   current_binding_level->prep_state = 2;
2780
2781   /* Make local var to hold return type for multi-type master fn. */
2782
2783   if (multi)
2784     {
2785       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2786                                                      "multi_retval");
2787       multi_retval = build_decl (VAR_DECL, multi_retval,
2788                                  ffecom_multi_type_node_);
2789       multi_retval = start_decl (multi_retval, FALSE);
2790       finish_decl (multi_retval, NULL_TREE, FALSE);
2791     }
2792   else
2793     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2794
2795   /* Here we emit the actual code for the entry point. */
2796
2797   {
2798     ffebld list;
2799     ffebld arg;
2800     ffesymbol s;
2801     tree arglist = NULL_TREE;
2802     tree *plist = &arglist;
2803     tree prepend;
2804     tree call;
2805     tree actarg;
2806     tree master_fn;
2807
2808     /* Prepare actual arg list based on master arg list. */
2809
2810     for (list = ffecom_master_arglist_;
2811          list != NULL;
2812          list = ffebld_trail (list))
2813       {
2814         arg = ffebld_head (list);
2815         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2816           continue;
2817         s = ffebld_symter (arg);
2818         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2819             || ffesymbol_hook (s).decl_tree == error_mark_node)
2820           actarg = null_pointer_node;   /* We don't have this arg. */
2821         else
2822           actarg = ffesymbol_hook (s).decl_tree;
2823         *plist = build_tree_list (NULL_TREE, actarg);
2824         plist = &TREE_CHAIN (*plist);
2825       }
2826
2827     /* This code appends the length arguments for character
2828        variables/arrays.  */
2829
2830     for (list = ffecom_master_arglist_;
2831          list != NULL;
2832          list = ffebld_trail (list))
2833       {
2834         arg = ffebld_head (list);
2835         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2836           continue;
2837         s = ffebld_symter (arg);
2838         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2839           continue;             /* Only looking for CHARACTER arguments. */
2840         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2841           continue;             /* Only looking for variables and arrays. */
2842         if (ffesymbol_hook (s).length_tree == NULL_TREE
2843             || ffesymbol_hook (s).length_tree == error_mark_node)
2844           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2845         else
2846           actarg = ffesymbol_hook (s).length_tree;
2847         *plist = build_tree_list (NULL_TREE, actarg);
2848         plist = &TREE_CHAIN (*plist);
2849       }
2850
2851     /* Prepend character-value return info to actual arg list. */
2852
2853     if (charfunc)
2854       {
2855         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2856         TREE_CHAIN (prepend)
2857           = build_tree_list (NULL_TREE, ffecom_func_length_);
2858         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2859         arglist = prepend;
2860       }
2861
2862     /* Prepend multi-type return value to actual arg list. */
2863
2864     if (multi)
2865       {
2866         prepend
2867           = build_tree_list (NULL_TREE,
2868                              ffecom_1 (ADDR_EXPR,
2869                               build_pointer_type (TREE_TYPE (multi_retval)),
2870                                        multi_retval));
2871         TREE_CHAIN (prepend) = arglist;
2872         arglist = prepend;
2873       }
2874
2875     /* Prepend my entry-point number to the actual arg list. */
2876
2877     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2878     TREE_CHAIN (prepend) = arglist;
2879     arglist = prepend;
2880
2881     /* Build the call to the master function. */
2882
2883     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2884     call = ffecom_3s (CALL_EXPR,
2885                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2886                       master_fn, arglist, NULL_TREE);
2887
2888     /* Decide whether the master function is a function or subroutine, and
2889        handle the return value for my entry point. */
2890
2891     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2892                      && !altreturning))
2893       {
2894         expand_expr_stmt (call);
2895         expand_null_return ();
2896       }
2897     else if (multi && cmplxfunc)
2898       {
2899         expand_expr_stmt (call);
2900         result
2901           = ffecom_1 (INDIRECT_REF,
2902                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2903                       result);
2904         result = ffecom_modify (NULL_TREE, result,
2905                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2906                                           multi_retval,
2907                                           ffecom_multi_fields_[bt][kt]));
2908         expand_expr_stmt (result);
2909         expand_null_return ();
2910       }
2911     else if (multi)
2912       {
2913         expand_expr_stmt (call);
2914         result
2915           = ffecom_modify (NULL_TREE, result,
2916                            convert (TREE_TYPE (result),
2917                                     ffecom_2 (COMPONENT_REF,
2918                                               ffecom_tree_type[bt][kt],
2919                                               multi_retval,
2920                                               ffecom_multi_fields_[bt][kt])));
2921         expand_return (result);
2922       }
2923     else if (cmplxfunc)
2924       {
2925         result
2926           = ffecom_1 (INDIRECT_REF,
2927                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2928                       result);
2929         result = ffecom_modify (NULL_TREE, result, call);
2930         expand_expr_stmt (result);
2931         expand_null_return ();
2932       }
2933     else
2934       {
2935         result = ffecom_modify (NULL_TREE,
2936                                 result,
2937                                 convert (TREE_TYPE (result),
2938                                          call));
2939         expand_return (result);
2940       }
2941   }
2942
2943   ffecom_end_compstmt ();
2944
2945   finish_function (0);
2946
2947   lineno = old_lineno;
2948   input_filename = old_input_filename;
2949
2950   ffecom_doing_entry_ = FALSE;
2951 }
2952
2953 #endif
2954 /* Transform expr into gcc tree with possible destination
2955
2956    Recursive descent on expr while making corresponding tree nodes and
2957    attaching type info and such.  If destination supplied and compatible
2958    with temporary that would be made in certain cases, temporary isn't
2959    made, destination used instead, and dest_used flag set TRUE.  */
2960
2961 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2962 static tree
2963 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2964               bool *dest_used, bool assignp, bool widenp)
2965 {
2966   tree item;
2967   tree list;
2968   tree args;
2969   ffeinfoBasictype bt;
2970   ffeinfoKindtype kt;
2971   tree t;
2972   tree dt;                      /* decl_tree for an ffesymbol. */
2973   tree tree_type, tree_type_x;
2974   tree left, right;
2975   ffesymbol s;
2976   enum tree_code code;
2977
2978   assert (expr != NULL);
2979
2980   if (dest_used != NULL)
2981     *dest_used = FALSE;
2982
2983   bt = ffeinfo_basictype (ffebld_info (expr));
2984   kt = ffeinfo_kindtype (ffebld_info (expr));
2985   tree_type = ffecom_tree_type[bt][kt];
2986
2987   /* Widen integral arithmetic as desired while preserving signedness.  */
2988   tree_type_x = NULL_TREE;
2989   if (widenp && tree_type
2990       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2991       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2992     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2993
2994   switch (ffebld_op (expr))
2995     {
2996     case FFEBLD_opACCTER:
2997       {
2998         ffebitCount i;
2999         ffebit bits = ffebld_accter_bits (expr);
3000         ffetargetOffset source_offset = 0;
3001         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3002         tree purpose;
3003
3004         assert (dest_offset == 0
3005                 || (bt == FFEINFO_basictypeCHARACTER
3006                     && kt == FFEINFO_kindtypeCHARACTER1));
3007
3008         list = item = NULL;
3009         for (;;)
3010           {
3011             ffebldConstantUnion cu;
3012             ffebitCount length;
3013             bool value;
3014             ffebldConstantArray ca = ffebld_accter (expr);
3015
3016             ffebit_test (bits, source_offset, &value, &length);
3017             if (length == 0)
3018               break;
3019
3020             if (value)
3021               {
3022                 for (i = 0; i < length; ++i)
3023                   {
3024                     cu = ffebld_constantarray_get (ca, bt, kt,
3025                                                    source_offset + i);
3026
3027                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3028
3029                     if (i == 0
3030                         && dest_offset != 0)
3031                       purpose = build_int_2 (dest_offset, 0);
3032                     else
3033                       purpose = NULL_TREE;
3034
3035                     if (list == NULL_TREE)
3036                       list = item = build_tree_list (purpose, t);
3037                     else
3038                       {
3039                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3040                         item = TREE_CHAIN (item);
3041                       }
3042                   }
3043               }
3044             source_offset += length;
3045             dest_offset += length;
3046           }
3047       }
3048
3049       item = build_int_2 ((ffebld_accter_size (expr)
3050                            + ffebld_accter_pad (expr)) - 1, 0);
3051       ffebit_kill (ffebld_accter_bits (expr));
3052       TREE_TYPE (item) = ffecom_integer_type_node;
3053       item
3054         = build_array_type
3055           (tree_type,
3056            build_range_type (ffecom_integer_type_node,
3057                              ffecom_integer_zero_node,
3058                              item));
3059       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3060       TREE_CONSTANT (list) = 1;
3061       TREE_STATIC (list) = 1;
3062       return list;
3063
3064     case FFEBLD_opARRTER:
3065       {
3066         ffetargetOffset i;
3067
3068         list = NULL_TREE;
3069         if (ffebld_arrter_pad (expr) == 0)
3070           item = NULL_TREE;
3071         else
3072           {
3073             assert (bt == FFEINFO_basictypeCHARACTER
3074                     && kt == FFEINFO_kindtypeCHARACTER1);
3075
3076             /* Becomes PURPOSE first time through loop.  */
3077             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3078           }
3079
3080         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3081           {
3082             ffebldConstantUnion cu
3083             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3084
3085             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3086
3087             if (list == NULL_TREE)
3088               /* Assume item is PURPOSE first time through loop.  */
3089               list = item = build_tree_list (item, t);
3090             else
3091               {
3092                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3093                 item = TREE_CHAIN (item);
3094               }
3095           }
3096       }
3097
3098       item = build_int_2 ((ffebld_arrter_size (expr)
3099                           + ffebld_arrter_pad (expr)) - 1, 0);
3100       TREE_TYPE (item) = ffecom_integer_type_node;
3101       item
3102         = build_array_type
3103           (tree_type,
3104            build_range_type (ffecom_integer_type_node,
3105                              ffecom_integer_zero_node,
3106                              item));
3107       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3108       TREE_CONSTANT (list) = 1;
3109       TREE_STATIC (list) = 1;
3110       return list;
3111
3112     case FFEBLD_opCONTER:
3113       assert (ffebld_conter_pad (expr) == 0);
3114       item
3115         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3116                                 bt, kt, tree_type);
3117       return item;
3118
3119     case FFEBLD_opSYMTER:
3120       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3121           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3122         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3123       s = ffebld_symter (expr);
3124       t = ffesymbol_hook (s).decl_tree;
3125
3126       if (assignp)
3127         {                       /* ASSIGN'ed-label expr. */
3128           if (ffe_is_ugly_assign ())
3129             {
3130               /* User explicitly wants ASSIGN'ed variables to be at the same
3131                  memory address as the variables when used in non-ASSIGN
3132                  contexts.  That can make old, arcane, non-standard code
3133                  work, but don't try to do it when a pointer wouldn't fit
3134                  in the normal variable (take other approach, and warn,
3135                  instead).  */
3136
3137               if (t == NULL_TREE)
3138                 {
3139                   s = ffecom_sym_transform_ (s);
3140                   t = ffesymbol_hook (s).decl_tree;
3141                   assert (t != NULL_TREE);
3142                 }
3143
3144               if (t == error_mark_node)
3145                 return t;
3146
3147               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3148                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3149                 {
3150                   if (ffesymbol_hook (s).addr)
3151                     t = ffecom_1 (INDIRECT_REF,
3152                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3153                   return t;
3154                 }
3155
3156               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3157                 {
3158                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3159                                     FFEBAD_severityWARNING);
3160                   ffebad_string (ffesymbol_text (s));
3161                   ffebad_here (0, ffesymbol_where_line (s),
3162                                ffesymbol_where_column (s));
3163                   ffebad_finish ();
3164                 }
3165             }
3166
3167           /* Don't use the normal variable's tree for ASSIGN, though mark
3168              it as in the system header (housekeeping).  Use an explicit,
3169              specially created sibling that is known to be wide enough
3170              to hold pointers to labels.  */
3171
3172           if (t != NULL_TREE
3173               && TREE_CODE (t) == VAR_DECL)
3174             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3175
3176           t = ffesymbol_hook (s).assign_tree;
3177           if (t == NULL_TREE)
3178             {
3179               s = ffecom_sym_transform_assign_ (s);
3180               t = ffesymbol_hook (s).assign_tree;
3181               assert (t != NULL_TREE);
3182             }
3183         }
3184       else
3185         {
3186           if (t == NULL_TREE)
3187             {
3188               s = ffecom_sym_transform_ (s);
3189               t = ffesymbol_hook (s).decl_tree;
3190               assert (t != NULL_TREE);
3191             }
3192           if (ffesymbol_hook (s).addr)
3193             t = ffecom_1 (INDIRECT_REF,
3194                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3195         }
3196       return t;
3197
3198     case FFEBLD_opARRAYREF:
3199       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3200
3201     case FFEBLD_opUPLUS:
3202       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3203       return ffecom_1 (NOP_EXPR, tree_type, left);
3204
3205     case FFEBLD_opPAREN:
3206       /* ~~~Make sure Fortran rules respected here */
3207       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3208       return ffecom_1 (NOP_EXPR, tree_type, left);
3209
3210     case FFEBLD_opUMINUS:
3211       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3212       if (tree_type_x)
3213         {
3214           tree_type = tree_type_x;
3215           left = convert (tree_type, left);
3216         }
3217       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3218
3219     case FFEBLD_opADD:
3220       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3221       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3222       if (tree_type_x)
3223         {
3224           tree_type = tree_type_x;
3225           left = convert (tree_type, left);
3226           right = convert (tree_type, right);
3227         }
3228       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3229
3230     case FFEBLD_opSUBTRACT:
3231       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3232       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3233       if (tree_type_x)
3234         {
3235           tree_type = tree_type_x;
3236           left = convert (tree_type, left);
3237           right = convert (tree_type, right);
3238         }
3239       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3240
3241     case FFEBLD_opMULTIPLY:
3242       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3243       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3244       if (tree_type_x)
3245         {
3246           tree_type = tree_type_x;
3247           left = convert (tree_type, left);
3248           right = convert (tree_type, right);
3249         }
3250       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3251
3252     case FFEBLD_opDIVIDE:
3253       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3254       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3255       if (tree_type_x)
3256         {
3257           tree_type = tree_type_x;
3258           left = convert (tree_type, left);
3259           right = convert (tree_type, right);
3260         }
3261       return ffecom_tree_divide_ (tree_type, left, right,
3262                                   dest_tree, dest, dest_used,
3263                                   ffebld_nonter_hook (expr));
3264
3265     case FFEBLD_opPOWER:
3266       {
3267         ffebld left = ffebld_left (expr);
3268         ffebld right = ffebld_right (expr);
3269         ffecomGfrt code;
3270         ffeinfoKindtype rtkt;
3271         ffeinfoKindtype ltkt;
3272         bool ref = TRUE;
3273
3274         switch (ffeinfo_basictype (ffebld_info (right)))
3275           {
3276
3277           case FFEINFO_basictypeINTEGER:
3278             if (1 || optimize)
3279               {
3280                 item = ffecom_expr_power_integer_ (expr);
3281                 if (item != NULL_TREE)
3282                   return item;
3283               }
3284
3285             rtkt = FFEINFO_kindtypeINTEGER1;
3286             switch (ffeinfo_basictype (ffebld_info (left)))
3287               {
3288               case FFEINFO_basictypeINTEGER:
3289                 if ((ffeinfo_kindtype (ffebld_info (left))
3290                     == FFEINFO_kindtypeINTEGER4)
3291                     || (ffeinfo_kindtype (ffebld_info (right))
3292                         == FFEINFO_kindtypeINTEGER4))
3293                   {
3294                     code = FFECOM_gfrtPOW_QQ;
3295                     ltkt = FFEINFO_kindtypeINTEGER4;
3296                     rtkt = FFEINFO_kindtypeINTEGER4;
3297                   }
3298                 else
3299                   {
3300                     code = FFECOM_gfrtPOW_II;
3301                     ltkt = FFEINFO_kindtypeINTEGER1;
3302                   }
3303                 break;
3304
3305               case FFEINFO_basictypeREAL:
3306                 if (ffeinfo_kindtype (ffebld_info (left))
3307                     == FFEINFO_kindtypeREAL1)
3308                   {
3309                     code = FFECOM_gfrtPOW_RI;
3310                     ltkt = FFEINFO_kindtypeREAL1;
3311                   }
3312                 else
3313                   {
3314                     code = FFECOM_gfrtPOW_DI;
3315                     ltkt = FFEINFO_kindtypeREAL2;
3316                   }
3317                 break;
3318
3319               case FFEINFO_basictypeCOMPLEX:
3320                 if (ffeinfo_kindtype (ffebld_info (left))
3321                     == FFEINFO_kindtypeREAL1)
3322                   {
3323                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3324                     ltkt = FFEINFO_kindtypeREAL1;
3325                   }
3326                 else
3327                   {
3328                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3329                     ltkt = FFEINFO_kindtypeREAL2;
3330                   }
3331                 break;
3332
3333               default:
3334                 assert ("bad pow_*i" == NULL);
3335                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3336                 ltkt = FFEINFO_kindtypeREAL1;
3337                 break;
3338               }
3339             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3340               left = ffeexpr_convert (left, NULL, NULL,
3341                                       ffeinfo_basictype (ffebld_info (left)),
3342                                       ltkt, 0,
3343                                       FFETARGET_charactersizeNONE,
3344                                       FFEEXPR_contextLET);
3345             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3346               right = ffeexpr_convert (right, NULL, NULL,
3347                                        FFEINFO_basictypeINTEGER,
3348                                        rtkt, 0,
3349                                        FFETARGET_charactersizeNONE,
3350                                        FFEEXPR_contextLET);
3351             break;
3352
3353           case FFEINFO_basictypeREAL:
3354             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3355               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3356                                       FFEINFO_kindtypeREALDOUBLE, 0,
3357                                       FFETARGET_charactersizeNONE,
3358                                       FFEEXPR_contextLET);
3359             if (ffeinfo_kindtype (ffebld_info (right))
3360                 == FFEINFO_kindtypeREAL1)
3361               right = ffeexpr_convert (right, NULL, NULL,
3362                                        FFEINFO_basictypeREAL,
3363                                        FFEINFO_kindtypeREALDOUBLE, 0,
3364                                        FFETARGET_charactersizeNONE,
3365                                        FFEEXPR_contextLET);
3366             /* We used to call FFECOM_gfrtPOW_DD here,
3367                which passes arguments by reference.  */
3368             code = FFECOM_gfrtL_POW;
3369             /* Pass arguments by value. */
3370             ref  = FALSE;
3371             break;
3372
3373           case FFEINFO_basictypeCOMPLEX:
3374             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3375               left = ffeexpr_convert (left, NULL, NULL,
3376                                       FFEINFO_basictypeCOMPLEX,
3377                                       FFEINFO_kindtypeREALDOUBLE, 0,
3378                                       FFETARGET_charactersizeNONE,
3379                                       FFEEXPR_contextLET);
3380             if (ffeinfo_kindtype (ffebld_info (right))
3381                 == FFEINFO_kindtypeREAL1)
3382               right = ffeexpr_convert (right, NULL, NULL,
3383                                        FFEINFO_basictypeCOMPLEX,
3384                                        FFEINFO_kindtypeREALDOUBLE, 0,
3385                                        FFETARGET_charactersizeNONE,
3386                                        FFEEXPR_contextLET);
3387             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3388             ref = TRUE;                 /* Pass arguments by reference. */
3389             break;
3390
3391           default:
3392             assert ("bad pow_x*" == NULL);
3393             code = FFECOM_gfrtPOW_II;
3394             break;
3395           }
3396         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3397                                    ffecom_gfrt_kindtype (code),
3398                                    (ffe_is_f2c_library ()
3399                                     && ffecom_gfrt_complex_[code]),
3400                                    tree_type, left, right,
3401                                    dest_tree, dest, dest_used,
3402                                    NULL_TREE, FALSE, ref,
3403                                    ffebld_nonter_hook (expr));
3404       }
3405
3406     case FFEBLD_opNOT:
3407       switch (bt)
3408         {
3409         case FFEINFO_basictypeLOGICAL:
3410           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3411           return convert (tree_type, item);
3412
3413         case FFEINFO_basictypeINTEGER:
3414           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3415                            ffecom_expr (ffebld_left (expr)));
3416
3417         default:
3418           assert ("NOT bad basictype" == NULL);
3419           /* Fall through. */
3420         case FFEINFO_basictypeANY:
3421           return error_mark_node;
3422         }
3423       break;
3424
3425     case FFEBLD_opFUNCREF:
3426       assert (ffeinfo_basictype (ffebld_info (expr))
3427               != FFEINFO_basictypeCHARACTER);
3428       /* Fall through.   */
3429     case FFEBLD_opSUBRREF:
3430       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3431           == FFEINFO_whereINTRINSIC)
3432         {                       /* Invocation of an intrinsic. */
3433           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3434                                          dest_used);
3435           return item;
3436         }
3437       s = ffebld_symter (ffebld_left (expr));
3438       dt = ffesymbol_hook (s).decl_tree;
3439       if (dt == NULL_TREE)
3440         {
3441           s = ffecom_sym_transform_ (s);
3442           dt = ffesymbol_hook (s).decl_tree;
3443         }
3444       if (dt == error_mark_node)
3445         return dt;
3446
3447       if (ffesymbol_hook (s).addr)
3448         item = dt;
3449       else
3450         item = ffecom_1_fn (dt);
3451
3452       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3453         args = ffecom_list_expr (ffebld_right (expr));
3454       else
3455         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3456
3457       if (args == error_mark_node)
3458         return error_mark_node;
3459
3460       item = ffecom_call_ (item, kt,
3461                            ffesymbol_is_f2c (s)
3462                            && (bt == FFEINFO_basictypeCOMPLEX)
3463                            && (ffesymbol_where (s)
3464                                != FFEINFO_whereCONSTANT),
3465                            tree_type,
3466                            args,
3467                            dest_tree, dest, dest_used,
3468                            error_mark_node, FALSE,
3469                            ffebld_nonter_hook (expr));
3470       TREE_SIDE_EFFECTS (item) = 1;
3471       return item;
3472
3473     case FFEBLD_opAND:
3474       switch (bt)
3475         {
3476         case FFEINFO_basictypeLOGICAL:
3477           item
3478             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3479                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3480                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3481           return convert (tree_type, item);
3482
3483         case FFEINFO_basictypeINTEGER:
3484           return ffecom_2 (BIT_AND_EXPR, tree_type,
3485                            ffecom_expr (ffebld_left (expr)),
3486                            ffecom_expr (ffebld_right (expr)));
3487
3488         default:
3489           assert ("AND bad basictype" == NULL);
3490           /* Fall through. */
3491         case FFEINFO_basictypeANY:
3492           return error_mark_node;
3493         }
3494       break;
3495
3496     case FFEBLD_opOR:
3497       switch (bt)
3498         {
3499         case FFEINFO_basictypeLOGICAL:
3500           item
3501             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3502                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3503                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3504           return convert (tree_type, item);
3505
3506         case FFEINFO_basictypeINTEGER:
3507           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3508                            ffecom_expr (ffebld_left (expr)),
3509                            ffecom_expr (ffebld_right (expr)));
3510
3511         default:
3512           assert ("OR bad basictype" == NULL);
3513           /* Fall through. */
3514         case FFEINFO_basictypeANY:
3515           return error_mark_node;
3516         }
3517       break;
3518
3519     case FFEBLD_opXOR:
3520     case FFEBLD_opNEQV:
3521       switch (bt)
3522         {
3523         case FFEINFO_basictypeLOGICAL:
3524           item
3525             = ffecom_2 (NE_EXPR, integer_type_node,
3526                         ffecom_expr (ffebld_left (expr)),
3527                         ffecom_expr (ffebld_right (expr)));
3528           return convert (tree_type, ffecom_truth_value (item));
3529
3530         case FFEINFO_basictypeINTEGER:
3531           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3532                            ffecom_expr (ffebld_left (expr)),
3533                            ffecom_expr (ffebld_right (expr)));
3534
3535         default:
3536           assert ("XOR/NEQV bad basictype" == NULL);
3537           /* Fall through. */
3538         case FFEINFO_basictypeANY:
3539           return error_mark_node;
3540         }
3541       break;
3542
3543     case FFEBLD_opEQV:
3544       switch (bt)
3545         {
3546         case FFEINFO_basictypeLOGICAL:
3547           item
3548             = ffecom_2 (EQ_EXPR, integer_type_node,
3549                         ffecom_expr (ffebld_left (expr)),
3550                         ffecom_expr (ffebld_right (expr)));
3551           return convert (tree_type, ffecom_truth_value (item));
3552
3553         case FFEINFO_basictypeINTEGER:
3554           return
3555             ffecom_1 (BIT_NOT_EXPR, tree_type,
3556                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3557                                 ffecom_expr (ffebld_left (expr)),
3558                                 ffecom_expr (ffebld_right (expr))));
3559
3560         default:
3561           assert ("EQV bad basictype" == NULL);
3562           /* Fall through. */
3563         case FFEINFO_basictypeANY:
3564           return error_mark_node;
3565         }
3566       break;
3567
3568     case FFEBLD_opCONVERT:
3569       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3570         return error_mark_node;
3571
3572       switch (bt)
3573         {
3574         case FFEINFO_basictypeLOGICAL:
3575         case FFEINFO_basictypeINTEGER:
3576         case FFEINFO_basictypeREAL:
3577           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3578
3579         case FFEINFO_basictypeCOMPLEX:
3580           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3581             {
3582             case FFEINFO_basictypeINTEGER:
3583             case FFEINFO_basictypeLOGICAL:
3584             case FFEINFO_basictypeREAL:
3585               item = ffecom_expr (ffebld_left (expr));
3586               if (item == error_mark_node)
3587                 return error_mark_node;
3588               /* convert() takes care of converting to the subtype first,
3589                  at least in gcc-2.7.2. */
3590               item = convert (tree_type, item);
3591               return item;
3592
3593             case FFEINFO_basictypeCOMPLEX:
3594               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3595
3596             default:
3597               assert ("CONVERT COMPLEX bad basictype" == NULL);
3598               /* Fall through. */
3599             case FFEINFO_basictypeANY:
3600               return error_mark_node;
3601             }
3602           break;
3603
3604         default:
3605           assert ("CONVERT bad basictype" == NULL);
3606           /* Fall through. */
3607         case FFEINFO_basictypeANY:
3608           return error_mark_node;
3609         }
3610       break;
3611
3612     case FFEBLD_opLT:
3613       code = LT_EXPR;
3614       goto relational;          /* :::::::::::::::::::: */
3615
3616     case FFEBLD_opLE:
3617       code = LE_EXPR;
3618       goto relational;          /* :::::::::::::::::::: */
3619
3620     case FFEBLD_opEQ:
3621       code = EQ_EXPR;
3622       goto relational;          /* :::::::::::::::::::: */
3623
3624     case FFEBLD_opNE:
3625       code = NE_EXPR;
3626       goto relational;          /* :::::::::::::::::::: */
3627
3628     case FFEBLD_opGT:
3629       code = GT_EXPR;
3630       goto relational;          /* :::::::::::::::::::: */
3631
3632     case FFEBLD_opGE:
3633       code = GE_EXPR;
3634
3635     relational:         /* :::::::::::::::::::: */
3636       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3637         {
3638         case FFEINFO_basictypeLOGICAL:
3639         case FFEINFO_basictypeINTEGER:
3640         case FFEINFO_basictypeREAL:
3641           item = ffecom_2 (code, integer_type_node,
3642                            ffecom_expr (ffebld_left (expr)),
3643                            ffecom_expr (ffebld_right (expr)));
3644           return convert (tree_type, item);
3645
3646         case FFEINFO_basictypeCOMPLEX:
3647           assert (code == EQ_EXPR || code == NE_EXPR);
3648           {
3649             tree real_type;
3650             tree arg1 = ffecom_expr (ffebld_left (expr));
3651             tree arg2 = ffecom_expr (ffebld_right (expr));
3652
3653             if (arg1 == error_mark_node || arg2 == error_mark_node)
3654               return error_mark_node;
3655
3656             arg1 = ffecom_save_tree (arg1);
3657             arg2 = ffecom_save_tree (arg2);
3658
3659             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3660               {
3661                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3662                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3663               }
3664             else
3665               {
3666                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3667                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3668               }
3669
3670             item
3671               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3672                           ffecom_2 (EQ_EXPR, integer_type_node,
3673                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3674                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3675                           ffecom_2 (EQ_EXPR, integer_type_node,
3676                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3677                                     ffecom_1 (IMAGPART_EXPR, real_type,
3678                                               arg2)));
3679             if (code == EQ_EXPR)
3680               item = ffecom_truth_value (item);
3681             else
3682               item = ffecom_truth_value_invert (item);
3683             return convert (tree_type, item);
3684           }
3685
3686         case FFEINFO_basictypeCHARACTER:
3687           {
3688             ffebld left = ffebld_left (expr);
3689             ffebld right = ffebld_right (expr);
3690             tree left_tree;
3691             tree right_tree;
3692             tree left_length;
3693             tree right_length;
3694
3695             /* f2c run-time functions do the implicit blank-padding for us,
3696                so we don't usually have to implement blank-padding ourselves.
3697                (The exception is when we pass an argument to a separately
3698                compiled statement function -- if we know the arg is not the
3699                same length as the dummy, we must truncate or extend it.  If
3700                we "inline" statement functions, that necessity goes away as
3701                well.)
3702
3703                Strip off the CONVERT operators that blank-pad.  (Truncation by
3704                CONVERT shouldn't happen here, but it can happen in
3705                assignments.) */
3706
3707             while (ffebld_op (left) == FFEBLD_opCONVERT)
3708               left = ffebld_left (left);
3709             while (ffebld_op (right) == FFEBLD_opCONVERT)
3710               right = ffebld_left (right);
3711
3712             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3713             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3714
3715             if (left_tree == error_mark_node || left_length == error_mark_node
3716                 || right_tree == error_mark_node
3717                 || right_length == error_mark_node)
3718               return error_mark_node;
3719
3720             if ((ffebld_size_known (left) == 1)
3721                 && (ffebld_size_known (right) == 1))
3722               {
3723                 left_tree
3724                   = ffecom_1 (INDIRECT_REF,
3725                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3726                               left_tree);
3727                 right_tree
3728                   = ffecom_1 (INDIRECT_REF,
3729                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3730                               right_tree);
3731
3732                 item
3733                   = ffecom_2 (code, integer_type_node,
3734                               ffecom_2 (ARRAY_REF,
3735                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3736                                         left_tree,
3737                                         integer_one_node),
3738                               ffecom_2 (ARRAY_REF,
3739                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3740                                         right_tree,
3741                                         integer_one_node));
3742               }
3743             else
3744               {
3745                 item = build_tree_list (NULL_TREE, left_tree);
3746                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3747                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3748                                                                left_length);
3749                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3750                   = build_tree_list (NULL_TREE, right_length);
3751                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3752                 item = ffecom_2 (code, integer_type_node,
3753                                  item,
3754                                  convert (TREE_TYPE (item),
3755                                           integer_zero_node));
3756               }
3757             item = convert (tree_type, item);
3758           }
3759
3760           return item;
3761
3762         default:
3763           assert ("relational bad basictype" == NULL);
3764           /* Fall through. */
3765         case FFEINFO_basictypeANY:
3766           return error_mark_node;
3767         }
3768       break;
3769
3770     case FFEBLD_opPERCENT_LOC:
3771       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3772       return convert (tree_type, item);
3773
3774     case FFEBLD_opITEM:
3775     case FFEBLD_opSTAR:
3776     case FFEBLD_opBOUNDS:
3777     case FFEBLD_opREPEAT:
3778     case FFEBLD_opLABTER:
3779     case FFEBLD_opLABTOK:
3780     case FFEBLD_opIMPDO:
3781     case FFEBLD_opCONCATENATE:
3782     case FFEBLD_opSUBSTR:
3783     default:
3784       assert ("bad op" == NULL);
3785       /* Fall through. */
3786     case FFEBLD_opANY:
3787       return error_mark_node;
3788     }
3789
3790 #if 1
3791   assert ("didn't think anything got here anymore!!" == NULL);
3792 #else
3793   switch (ffebld_arity (expr))
3794     {
3795     case 2:
3796       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3797       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3798       if (TREE_OPERAND (item, 0) == error_mark_node
3799           || TREE_OPERAND (item, 1) == error_mark_node)
3800         return error_mark_node;
3801       break;
3802
3803     case 1:
3804       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3805       if (TREE_OPERAND (item, 0) == error_mark_node)
3806         return error_mark_node;
3807       break;
3808
3809     default:
3810       break;
3811     }
3812
3813   return fold (item);
3814 #endif
3815 }
3816
3817 #endif
3818 /* Returns the tree that does the intrinsic invocation.
3819
3820    Note: this function applies only to intrinsics returning
3821    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3822    subroutines.  */
3823
3824 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3825 static tree
3826 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3827                         ffebld dest, bool *dest_used)
3828 {
3829   tree expr_tree;
3830   tree saved_expr1;             /* For those who need it. */
3831   tree saved_expr2;             /* For those who need it. */
3832   ffeinfoBasictype bt;
3833   ffeinfoKindtype kt;
3834   tree tree_type;
3835   tree arg1_type;
3836   tree real_type;               /* REAL type corresponding to COMPLEX. */
3837   tree tempvar;
3838   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3839   ffebld arg1;                  /* For handy reference. */
3840   ffebld arg2;
3841   ffebld arg3;
3842   ffeintrinImp codegen_imp;
3843   ffecomGfrt gfrt;
3844
3845   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3846
3847   if (dest_used != NULL)
3848     *dest_used = FALSE;
3849
3850   bt = ffeinfo_basictype (ffebld_info (expr));
3851   kt = ffeinfo_kindtype (ffebld_info (expr));
3852   tree_type = ffecom_tree_type[bt][kt];
3853
3854   if (list != NULL)
3855     {
3856       arg1 = ffebld_head (list);
3857       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3858         return error_mark_node;
3859       if ((list = ffebld_trail (list)) != NULL)
3860         {
3861           arg2 = ffebld_head (list);
3862           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3863             return error_mark_node;
3864           if ((list = ffebld_trail (list)) != NULL)
3865             {
3866               arg3 = ffebld_head (list);
3867               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3868                 return error_mark_node;
3869             }
3870           else
3871             arg3 = NULL;
3872         }
3873       else
3874         arg2 = arg3 = NULL;
3875     }
3876   else
3877     arg1 = arg2 = arg3 = NULL;
3878
3879   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3880      args.  This is used by the MAX/MIN expansions. */
3881
3882   if (arg1 != NULL)
3883     arg1_type = ffecom_tree_type
3884       [ffeinfo_basictype (ffebld_info (arg1))]
3885       [ffeinfo_kindtype (ffebld_info (arg1))];
3886   else
3887     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3888                                    here. */
3889
3890   /* There are several ways for each of the cases in the following switch
3891      statements to exit (from simplest to use to most complicated):
3892
3893      break;  (when expr_tree == NULL)
3894
3895      A standard call is made to the specific intrinsic just as if it had been
3896      passed in as a dummy procedure and called as any old procedure.  This
3897      method can produce slower code but in some cases it's the easiest way for
3898      now.  However, if a (presumably faster) direct call is available,
3899      that is used, so this is the easiest way in many more cases now.
3900
3901      gfrt = FFECOM_gfrtWHATEVER;
3902      break;
3903
3904      gfrt contains the gfrt index of a library function to call, passing the
3905      argument(s) by value rather than by reference.  Used when a more
3906      careful choice of library function is needed than that provided
3907      by the vanilla `break;'.
3908
3909      return expr_tree;
3910
3911      The expr_tree has been completely set up and is ready to be returned
3912      as is.  No further actions are taken.  Use this when the tree is not
3913      in the simple form for one of the arity_n labels.   */
3914
3915   /* For info on how the switch statement cases were written, see the files
3916      enclosed in comments below the switch statement. */
3917
3918   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3919   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3920   if (gfrt == FFECOM_gfrt)
3921     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3922
3923   switch (codegen_imp)
3924     {
3925     case FFEINTRIN_impABS:
3926     case FFEINTRIN_impCABS:
3927     case FFEINTRIN_impCDABS:
3928     case FFEINTRIN_impDABS:
3929     case FFEINTRIN_impIABS:
3930       if (ffeinfo_basictype (ffebld_info (arg1))
3931           == FFEINFO_basictypeCOMPLEX)
3932         {
3933           if (kt == FFEINFO_kindtypeREAL1)
3934             gfrt = FFECOM_gfrtCABS;
3935           else if (kt == FFEINFO_kindtypeREAL2)
3936             gfrt = FFECOM_gfrtCDABS;
3937           break;
3938         }
3939       return ffecom_1 (ABS_EXPR, tree_type,
3940                        convert (tree_type, ffecom_expr (arg1)));
3941
3942     case FFEINTRIN_impACOS:
3943     case FFEINTRIN_impDACOS:
3944       break;
3945
3946     case FFEINTRIN_impAIMAG:
3947     case FFEINTRIN_impDIMAG:
3948     case FFEINTRIN_impIMAGPART:
3949       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3950         arg1_type = TREE_TYPE (arg1_type);
3951       else
3952         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3953
3954       return
3955         convert (tree_type,
3956                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3957                            ffecom_expr (arg1)));
3958
3959     case FFEINTRIN_impAINT:
3960     case FFEINTRIN_impDINT:
3961 #if 0
3962       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3963       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3964 #else /* in the meantime, must use floor to avoid range problems with ints */
3965       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3966       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3967       return
3968         convert (tree_type,
3969                  ffecom_3 (COND_EXPR, double_type_node,
3970                            ffecom_truth_value
3971                            (ffecom_2 (GE_EXPR, integer_type_node,
3972                                       saved_expr1,
3973                                       convert (arg1_type,
3974                                                ffecom_float_zero_))),
3975                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3976                                              build_tree_list (NULL_TREE,
3977                                                   convert (double_type_node,
3978                                                            saved_expr1)),
3979                                              NULL_TREE),
3980                            ffecom_1 (NEGATE_EXPR, double_type_node,
3981                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3982                                                  build_tree_list (NULL_TREE,
3983                                                   convert (double_type_node,
3984                                                       ffecom_1 (NEGATE_EXPR,
3985                                                                 arg1_type,
3986                                                                saved_expr1))),
3987                                                        NULL_TREE)
3988                                      ))
3989                  );
3990 #endif
3991
3992     case FFEINTRIN_impANINT:
3993     case FFEINTRIN_impDNINT:
3994 #if 0                           /* This way of doing it won't handle real
3995                                    numbers of large magnitudes. */
3996       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3997       expr_tree = convert (tree_type,
3998                            convert (integer_type_node,
3999                                     ffecom_3 (COND_EXPR, tree_type,
4000                                               ffecom_truth_value
4001                                               (ffecom_2 (GE_EXPR,
4002                                                          integer_type_node,
4003                                                          saved_expr1,
4004                                                        ffecom_float_zero_)),
4005                                               ffecom_2 (PLUS_EXPR,
4006                                                         tree_type,
4007                                                         saved_expr1,
4008                                                         ffecom_float_half_),
4009                                               ffecom_2 (MINUS_EXPR,
4010                                                         tree_type,
4011                                                         saved_expr1,
4012                                                      ffecom_float_half_))));
4013       return expr_tree;
4014 #else /* So we instead call floor. */
4015       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4016       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4017       return
4018         convert (tree_type,
4019                  ffecom_3 (COND_EXPR, double_type_node,
4020                            ffecom_truth_value
4021                            (ffecom_2 (GE_EXPR, integer_type_node,
4022                                       saved_expr1,
4023                                       convert (arg1_type,
4024                                                ffecom_float_zero_))),
4025                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4026                                              build_tree_list (NULL_TREE,
4027                                                   convert (double_type_node,
4028                                                            ffecom_2 (PLUS_EXPR,
4029                                                                      arg1_type,
4030                                                                      saved_expr1,
4031                                                                      convert (arg1_type,
4032                                                                               ffecom_float_half_)))),
4033                                              NULL_TREE),
4034                            ffecom_1 (NEGATE_EXPR, double_type_node,
4035                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4036                                                        build_tree_list (NULL_TREE,
4037                                                                         convert (double_type_node,
4038                                                                                  ffecom_2 (MINUS_EXPR,
4039                                                                                            arg1_type,
4040                                                                                            convert (arg1_type,
4041                                                                                                     ffecom_float_half_),
4042                                                                                            saved_expr1))),
4043                                                        NULL_TREE))
4044                            )
4045                  );
4046 #endif
4047
4048     case FFEINTRIN_impASIN:
4049     case FFEINTRIN_impDASIN:
4050     case FFEINTRIN_impATAN:
4051     case FFEINTRIN_impDATAN:
4052     case FFEINTRIN_impATAN2:
4053     case FFEINTRIN_impDATAN2:
4054       break;
4055
4056     case FFEINTRIN_impCHAR:
4057     case FFEINTRIN_impACHAR:
4058 #ifdef HOHO
4059       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4060 #else
4061       tempvar = ffebld_nonter_hook (expr);
4062       assert (tempvar);
4063 #endif
4064       {
4065         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4066
4067         expr_tree = ffecom_modify (tmv,
4068                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4069                                              integer_one_node),
4070                                    convert (tmv, ffecom_expr (arg1)));
4071       }
4072       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4073                             expr_tree,
4074                             tempvar);
4075       expr_tree = ffecom_1 (ADDR_EXPR,
4076                             build_pointer_type (TREE_TYPE (expr_tree)),
4077                             expr_tree);
4078       return expr_tree;
4079
4080     case FFEINTRIN_impCMPLX:
4081     case FFEINTRIN_impDCMPLX:
4082       if (arg2 == NULL)
4083         return
4084           convert (tree_type, ffecom_expr (arg1));
4085
4086       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4087       return
4088         ffecom_2 (COMPLEX_EXPR, tree_type,
4089                   convert (real_type, ffecom_expr (arg1)),
4090                   convert (real_type,
4091                            ffecom_expr (arg2)));
4092
4093     case FFEINTRIN_impCOMPLEX:
4094       return
4095         ffecom_2 (COMPLEX_EXPR, tree_type,
4096                   ffecom_expr (arg1),
4097                   ffecom_expr (arg2));
4098
4099     case FFEINTRIN_impCONJG:
4100     case FFEINTRIN_impDCONJG:
4101       {
4102         tree arg1_tree;
4103
4104         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4105         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4106         return
4107           ffecom_2 (COMPLEX_EXPR, tree_type,
4108                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4109                     ffecom_1 (NEGATE_EXPR, real_type,
4110                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4111       }
4112
4113     case FFEINTRIN_impCOS:
4114     case FFEINTRIN_impCCOS:
4115     case FFEINTRIN_impCDCOS:
4116     case FFEINTRIN_impDCOS:
4117       if (bt == FFEINFO_basictypeCOMPLEX)
4118         {
4119           if (kt == FFEINFO_kindtypeREAL1)
4120             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4121           else if (kt == FFEINFO_kindtypeREAL2)
4122             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4123         }
4124       break;
4125
4126     case FFEINTRIN_impCOSH:
4127     case FFEINTRIN_impDCOSH:
4128       break;
4129
4130     case FFEINTRIN_impDBLE:
4131     case FFEINTRIN_impDFLOAT:
4132     case FFEINTRIN_impDREAL:
4133     case FFEINTRIN_impFLOAT:
4134     case FFEINTRIN_impIDINT:
4135     case FFEINTRIN_impIFIX:
4136     case FFEINTRIN_impINT2:
4137     case FFEINTRIN_impINT8:
4138     case FFEINTRIN_impINT:
4139     case FFEINTRIN_impLONG:
4140     case FFEINTRIN_impREAL:
4141     case FFEINTRIN_impSHORT:
4142     case FFEINTRIN_impSNGL:
4143       return convert (tree_type, ffecom_expr (arg1));
4144
4145     case FFEINTRIN_impDIM:
4146     case FFEINTRIN_impDDIM:
4147     case FFEINTRIN_impIDIM:
4148       saved_expr1 = ffecom_save_tree (convert (tree_type,
4149                                                ffecom_expr (arg1)));
4150       saved_expr2 = ffecom_save_tree (convert (tree_type,
4151                                                ffecom_expr (arg2)));
4152       return
4153         ffecom_3 (COND_EXPR, tree_type,
4154                   ffecom_truth_value
4155                   (ffecom_2 (GT_EXPR, integer_type_node,
4156                              saved_expr1,
4157                              saved_expr2)),
4158                   ffecom_2 (MINUS_EXPR, tree_type,
4159                             saved_expr1,
4160                             saved_expr2),
4161                   convert (tree_type, ffecom_float_zero_));
4162
4163     case FFEINTRIN_impDPROD:
4164       return
4165         ffecom_2 (MULT_EXPR, tree_type,
4166                   convert (tree_type, ffecom_expr (arg1)),
4167                   convert (tree_type, ffecom_expr (arg2)));
4168
4169     case FFEINTRIN_impEXP:
4170     case FFEINTRIN_impCDEXP:
4171     case FFEINTRIN_impCEXP:
4172     case FFEINTRIN_impDEXP:
4173       if (bt == FFEINFO_basictypeCOMPLEX)
4174         {
4175           if (kt == FFEINFO_kindtypeREAL1)
4176             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4177           else if (kt == FFEINFO_kindtypeREAL2)
4178             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4179         }
4180       break;
4181
4182     case FFEINTRIN_impICHAR:
4183     case FFEINTRIN_impIACHAR:
4184 #if 0                           /* The simple approach. */
4185       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4186       expr_tree
4187         = ffecom_1 (INDIRECT_REF,
4188                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4189                     expr_tree);
4190       expr_tree
4191         = ffecom_2 (ARRAY_REF,
4192                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4193                     expr_tree,
4194                     integer_one_node);
4195       return convert (tree_type, expr_tree);
4196 #else /* The more interesting (and more optimal) approach. */
4197       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4198       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4199                             saved_expr1,
4200                             expr_tree,
4201                             convert (tree_type, integer_zero_node));
4202       return expr_tree;
4203 #endif
4204
4205     case FFEINTRIN_impINDEX:
4206       break;
4207
4208     case FFEINTRIN_impLEN:
4209 #if 0
4210       break;                                    /* The simple approach. */
4211 #else
4212       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4213 #endif
4214
4215     case FFEINTRIN_impLGE:
4216     case FFEINTRIN_impLGT:
4217     case FFEINTRIN_impLLE:
4218     case FFEINTRIN_impLLT:
4219       break;
4220
4221     case FFEINTRIN_impLOG:
4222     case FFEINTRIN_impALOG:
4223     case FFEINTRIN_impCDLOG:
4224     case FFEINTRIN_impCLOG:
4225     case FFEINTRIN_impDLOG:
4226       if (bt == FFEINFO_basictypeCOMPLEX)
4227         {
4228           if (kt == FFEINFO_kindtypeREAL1)
4229             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4230           else if (kt == FFEINFO_kindtypeREAL2)
4231             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4232         }
4233       break;
4234
4235     case FFEINTRIN_impLOG10:
4236     case FFEINTRIN_impALOG10:
4237     case FFEINTRIN_impDLOG10:
4238       if (gfrt != FFECOM_gfrt)
4239         break;  /* Already picked one, stick with it. */
4240
4241       if (kt == FFEINFO_kindtypeREAL1)
4242         /* We used to call FFECOM_gfrtALOG10 here.  */
4243         gfrt = FFECOM_gfrtL_LOG10;
4244       else if (kt == FFEINFO_kindtypeREAL2)
4245         /* We used to call FFECOM_gfrtDLOG10 here.  */
4246         gfrt = FFECOM_gfrtL_LOG10;
4247       break;
4248
4249     case FFEINTRIN_impMAX:
4250     case FFEINTRIN_impAMAX0:
4251     case FFEINTRIN_impAMAX1:
4252     case FFEINTRIN_impDMAX1:
4253     case FFEINTRIN_impMAX0:
4254     case FFEINTRIN_impMAX1:
4255       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4256         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4257       else
4258         arg1_type = tree_type;
4259       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4260                             convert (arg1_type, ffecom_expr (arg1)),
4261                             convert (arg1_type, ffecom_expr (arg2)));
4262       for (; list != NULL; list = ffebld_trail (list))
4263         {
4264           if ((ffebld_head (list) == NULL)
4265               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4266             continue;
4267           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4268                                 expr_tree,
4269                                 convert (arg1_type,
4270                                          ffecom_expr (ffebld_head (list))));
4271         }
4272       return convert (tree_type, expr_tree);
4273
4274     case FFEINTRIN_impMIN:
4275     case FFEINTRIN_impAMIN0:
4276     case FFEINTRIN_impAMIN1:
4277     case FFEINTRIN_impDMIN1:
4278     case FFEINTRIN_impMIN0:
4279     case FFEINTRIN_impMIN1:
4280       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4281         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4282       else
4283         arg1_type = tree_type;
4284       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4285                             convert (arg1_type, ffecom_expr (arg1)),
4286                             convert (arg1_type, ffecom_expr (arg2)));
4287       for (; list != NULL; list = ffebld_trail (list))
4288         {
4289           if ((ffebld_head (list) == NULL)
4290               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4291             continue;
4292           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4293                                 expr_tree,
4294                                 convert (arg1_type,
4295                                          ffecom_expr (ffebld_head (list))));
4296         }
4297       return convert (tree_type, expr_tree);
4298
4299     case FFEINTRIN_impMOD:
4300     case FFEINTRIN_impAMOD:
4301     case FFEINTRIN_impDMOD:
4302       if (bt != FFEINFO_basictypeREAL)
4303         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4304                          convert (tree_type, ffecom_expr (arg1)),
4305                          convert (tree_type, ffecom_expr (arg2)));
4306
4307       if (kt == FFEINFO_kindtypeREAL1)
4308         /* We used to call FFECOM_gfrtAMOD here.  */
4309         gfrt = FFECOM_gfrtL_FMOD;
4310       else if (kt == FFEINFO_kindtypeREAL2)
4311         /* We used to call FFECOM_gfrtDMOD here.  */
4312         gfrt = FFECOM_gfrtL_FMOD;
4313       break;
4314
4315     case FFEINTRIN_impNINT:
4316     case FFEINTRIN_impIDNINT:
4317 #if 0
4318       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4319       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4320 #else
4321       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4322       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4323       return
4324         convert (ffecom_integer_type_node,
4325                  ffecom_3 (COND_EXPR, arg1_type,
4326                            ffecom_truth_value
4327                            (ffecom_2 (GE_EXPR, integer_type_node,
4328                                       saved_expr1,
4329                                       convert (arg1_type,
4330                                                ffecom_float_zero_))),
4331                            ffecom_2 (PLUS_EXPR, arg1_type,
4332                                      saved_expr1,
4333                                      convert (arg1_type,
4334                                               ffecom_float_half_)),
4335                            ffecom_2 (MINUS_EXPR, arg1_type,
4336                                      saved_expr1,
4337                                      convert (arg1_type,
4338                                               ffecom_float_half_))));
4339 #endif
4340
4341     case FFEINTRIN_impSIGN:
4342     case FFEINTRIN_impDSIGN:
4343     case FFEINTRIN_impISIGN:
4344       {
4345         tree arg2_tree = ffecom_expr (arg2);
4346
4347         saved_expr1
4348           = ffecom_save_tree
4349           (ffecom_1 (ABS_EXPR, tree_type,
4350                      convert (tree_type,
4351                               ffecom_expr (arg1))));
4352         expr_tree
4353           = ffecom_3 (COND_EXPR, tree_type,
4354                       ffecom_truth_value
4355                       (ffecom_2 (GE_EXPR, integer_type_node,
4356                                  arg2_tree,
4357                                  convert (TREE_TYPE (arg2_tree),
4358                                           integer_zero_node))),
4359                       saved_expr1,
4360                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4361         /* Make sure SAVE_EXPRs get referenced early enough. */
4362         expr_tree
4363           = ffecom_2 (COMPOUND_EXPR, tree_type,
4364                       convert (void_type_node, saved_expr1),
4365                       expr_tree);
4366       }
4367       return expr_tree;
4368
4369     case FFEINTRIN_impSIN:
4370     case FFEINTRIN_impCDSIN:
4371     case FFEINTRIN_impCSIN:
4372     case FFEINTRIN_impDSIN:
4373       if (bt == FFEINFO_basictypeCOMPLEX)
4374         {
4375           if (kt == FFEINFO_kindtypeREAL1)
4376             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4377           else if (kt == FFEINFO_kindtypeREAL2)
4378             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4379         }
4380       break;
4381
4382     case FFEINTRIN_impSINH:
4383     case FFEINTRIN_impDSINH:
4384       break;
4385
4386     case FFEINTRIN_impSQRT:
4387     case FFEINTRIN_impCDSQRT:
4388     case FFEINTRIN_impCSQRT:
4389     case FFEINTRIN_impDSQRT:
4390       if (bt == FFEINFO_basictypeCOMPLEX)
4391         {
4392           if (kt == FFEINFO_kindtypeREAL1)
4393             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4394           else if (kt == FFEINFO_kindtypeREAL2)
4395             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4396         }
4397       break;
4398
4399     case FFEINTRIN_impTAN:
4400     case FFEINTRIN_impDTAN:
4401     case FFEINTRIN_impTANH:
4402     case FFEINTRIN_impDTANH:
4403       break;
4404
4405     case FFEINTRIN_impREALPART:
4406       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4407         arg1_type = TREE_TYPE (arg1_type);
4408       else
4409         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4410
4411       return
4412         convert (tree_type,
4413                  ffecom_1 (REALPART_EXPR, arg1_type,
4414                            ffecom_expr (arg1)));
4415
4416     case FFEINTRIN_impIAND:
4417     case FFEINTRIN_impAND:
4418       return ffecom_2 (BIT_AND_EXPR, tree_type,
4419                        convert (tree_type,
4420                                 ffecom_expr (arg1)),
4421                        convert (tree_type,
4422                                 ffecom_expr (arg2)));
4423
4424     case FFEINTRIN_impIOR:
4425     case FFEINTRIN_impOR:
4426       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4427                        convert (tree_type,
4428                                 ffecom_expr (arg1)),
4429                        convert (tree_type,
4430                                 ffecom_expr (arg2)));
4431
4432     case FFEINTRIN_impIEOR:
4433     case FFEINTRIN_impXOR:
4434       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4435                        convert (tree_type,
4436                                 ffecom_expr (arg1)),
4437                        convert (tree_type,
4438                                 ffecom_expr (arg2)));
4439
4440     case FFEINTRIN_impLSHIFT:
4441       return ffecom_2 (LSHIFT_EXPR, tree_type,
4442                        ffecom_expr (arg1),
4443                        convert (integer_type_node,
4444                                 ffecom_expr (arg2)));
4445
4446     case FFEINTRIN_impRSHIFT:
4447       return ffecom_2 (RSHIFT_EXPR, tree_type,
4448                        ffecom_expr (arg1),
4449                        convert (integer_type_node,
4450                                 ffecom_expr (arg2)));
4451
4452     case FFEINTRIN_impNOT:
4453       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4454
4455     case FFEINTRIN_impBIT_SIZE:
4456       return convert (tree_type, TYPE_SIZE (arg1_type));
4457
4458     case FFEINTRIN_impBTEST:
4459       {
4460         ffetargetLogical1 target_true;
4461         ffetargetLogical1 target_false;
4462         tree true_tree;
4463         tree false_tree;
4464
4465         ffetarget_logical1 (&target_true, TRUE);
4466         ffetarget_logical1 (&target_false, FALSE);
4467         if (target_true == 1)
4468           true_tree = convert (tree_type, integer_one_node);
4469         else
4470           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4471         if (target_false == 0)
4472           false_tree = convert (tree_type, integer_zero_node);
4473         else
4474           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4475
4476         return
4477           ffecom_3 (COND_EXPR, tree_type,
4478                     ffecom_truth_value
4479                     (ffecom_2 (EQ_EXPR, integer_type_node,
4480                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4481                                          ffecom_expr (arg1),
4482                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4483                                                    convert (arg1_type,
4484                                                           integer_one_node),
4485                                                    convert (integer_type_node,
4486                                                             ffecom_expr (arg2)))),
4487                                convert (arg1_type,
4488                                         integer_zero_node))),
4489                     false_tree,
4490                     true_tree);
4491       }
4492
4493     case FFEINTRIN_impIBCLR:
4494       return
4495         ffecom_2 (BIT_AND_EXPR, tree_type,
4496                   ffecom_expr (arg1),
4497                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4498                             ffecom_2 (LSHIFT_EXPR, tree_type,
4499                                       convert (tree_type,
4500                                                integer_one_node),
4501                                       convert (integer_type_node,
4502                                                ffecom_expr (arg2)))));
4503
4504     case FFEINTRIN_impIBITS:
4505       {
4506         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4507                                                     ffecom_expr (arg3)));
4508         tree uns_type
4509         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4510
4511         expr_tree
4512           = ffecom_2 (BIT_AND_EXPR, tree_type,
4513                       ffecom_2 (RSHIFT_EXPR, tree_type,
4514                                 ffecom_expr (arg1),
4515                                 convert (integer_type_node,
4516                                          ffecom_expr (arg2))),
4517                       convert (tree_type,
4518                                ffecom_2 (RSHIFT_EXPR, uns_type,
4519                                          ffecom_1 (BIT_NOT_EXPR,
4520                                                    uns_type,
4521                                                    convert (uns_type,
4522                                                         integer_zero_node)),
4523                                          ffecom_2 (MINUS_EXPR,
4524                                                    integer_type_node,
4525                                                    TYPE_SIZE (uns_type),
4526                                                    arg3_tree))));
4527 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4528         expr_tree
4529           = ffecom_3 (COND_EXPR, tree_type,
4530                       ffecom_truth_value
4531                       (ffecom_2 (NE_EXPR, integer_type_node,
4532                                  arg3_tree,
4533                                  integer_zero_node)),
4534                       expr_tree,
4535                       convert (tree_type, integer_zero_node));
4536 #endif
4537       }
4538       return expr_tree;
4539
4540     case FFEINTRIN_impIBSET:
4541       return
4542         ffecom_2 (BIT_IOR_EXPR, tree_type,
4543                   ffecom_expr (arg1),
4544                   ffecom_2 (LSHIFT_EXPR, tree_type,
4545                             convert (tree_type, integer_one_node),
4546                             convert (integer_type_node,
4547                                      ffecom_expr (arg2))));
4548
4549     case FFEINTRIN_impISHFT:
4550       {
4551         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4552         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4553                                                     ffecom_expr (arg2)));
4554         tree uns_type
4555         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4556
4557         expr_tree
4558           = ffecom_3 (COND_EXPR, tree_type,
4559                       ffecom_truth_value
4560                       (ffecom_2 (GE_EXPR, integer_type_node,
4561                                  arg2_tree,
4562                                  integer_zero_node)),
4563                       ffecom_2 (LSHIFT_EXPR, tree_type,
4564                                 arg1_tree,
4565                                 arg2_tree),
4566                       convert (tree_type,
4567                                ffecom_2 (RSHIFT_EXPR, uns_type,
4568                                          convert (uns_type, arg1_tree),
4569                                          ffecom_1 (NEGATE_EXPR,
4570                                                    integer_type_node,
4571                                                    arg2_tree))));
4572 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4573         expr_tree
4574           = ffecom_3 (COND_EXPR, tree_type,
4575                       ffecom_truth_value
4576                       (ffecom_2 (NE_EXPR, integer_type_node,
4577                                  arg2_tree,
4578                                  TYPE_SIZE (uns_type))),
4579                       expr_tree,
4580                       convert (tree_type, integer_zero_node));
4581 #endif
4582         /* Make sure SAVE_EXPRs get referenced early enough. */
4583         expr_tree
4584           = ffecom_2 (COMPOUND_EXPR, tree_type,
4585                       convert (void_type_node, arg1_tree),
4586                       ffecom_2 (COMPOUND_EXPR, tree_type,
4587                                 convert (void_type_node, arg2_tree),
4588                                 expr_tree));
4589       }
4590       return expr_tree;
4591
4592     case FFEINTRIN_impISHFTC:
4593       {
4594         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4595         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4596                                                     ffecom_expr (arg2)));
4597         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4598         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4599         tree shift_neg;
4600         tree shift_pos;
4601         tree mask_arg1;
4602         tree masked_arg1;
4603         tree uns_type
4604         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4605
4606         mask_arg1
4607           = ffecom_2 (LSHIFT_EXPR, tree_type,
4608                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4609                                 convert (tree_type, integer_zero_node)),
4610                       arg3_tree);
4611 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4612         mask_arg1
4613           = ffecom_3 (COND_EXPR, tree_type,
4614                       ffecom_truth_value
4615                       (ffecom_2 (NE_EXPR, integer_type_node,
4616                                  arg3_tree,
4617                                  TYPE_SIZE (uns_type))),
4618                       mask_arg1,
4619                       convert (tree_type, integer_zero_node));
4620 #endif
4621         mask_arg1 = ffecom_save_tree (mask_arg1);
4622         masked_arg1
4623           = ffecom_2 (BIT_AND_EXPR, tree_type,
4624                       arg1_tree,
4625                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4626                                 mask_arg1));
4627         masked_arg1 = ffecom_save_tree (masked_arg1);
4628         shift_neg
4629           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4630                       convert (tree_type,
4631                                ffecom_2 (RSHIFT_EXPR, uns_type,
4632                                          convert (uns_type, masked_arg1),
4633                                          ffecom_1 (NEGATE_EXPR,
4634                                                    integer_type_node,
4635                                                    arg2_tree))),
4636                       ffecom_2 (LSHIFT_EXPR, tree_type,
4637                                 arg1_tree,
4638                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4639                                           arg2_tree,
4640                                           arg3_tree)));
4641         shift_pos
4642           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4643                       ffecom_2 (LSHIFT_EXPR, tree_type,
4644                                 arg1_tree,
4645                                 arg2_tree),
4646                       convert (tree_type,
4647                                ffecom_2 (RSHIFT_EXPR, uns_type,
4648                                          convert (uns_type, masked_arg1),
4649                                          ffecom_2 (MINUS_EXPR,
4650                                                    integer_type_node,
4651                                                    arg3_tree,
4652                                                    arg2_tree))));
4653         expr_tree
4654           = ffecom_3 (COND_EXPR, tree_type,
4655                       ffecom_truth_value
4656                       (ffecom_2 (LT_EXPR, integer_type_node,
4657                                  arg2_tree,
4658                                  integer_zero_node)),
4659                       shift_neg,
4660                       shift_pos);
4661         expr_tree
4662           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4663                       ffecom_2 (BIT_AND_EXPR, tree_type,
4664                                 mask_arg1,
4665                                 arg1_tree),
4666                       ffecom_2 (BIT_AND_EXPR, tree_type,
4667                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4668                                           mask_arg1),
4669                                 expr_tree));
4670         expr_tree
4671           = ffecom_3 (COND_EXPR, tree_type,
4672                       ffecom_truth_value
4673                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4674                                  ffecom_2 (EQ_EXPR, integer_type_node,
4675                                            ffecom_1 (ABS_EXPR,
4676                                                      integer_type_node,
4677                                                      arg2_tree),
4678                                            arg3_tree),
4679                                  ffecom_2 (EQ_EXPR, integer_type_node,
4680                                            arg2_tree,
4681                                            integer_zero_node))),
4682                       arg1_tree,
4683                       expr_tree);
4684         /* Make sure SAVE_EXPRs get referenced early enough. */
4685         expr_tree
4686           = ffecom_2 (COMPOUND_EXPR, tree_type,
4687                       convert (void_type_node, arg1_tree),
4688                       ffecom_2 (COMPOUND_EXPR, tree_type,
4689                                 convert (void_type_node, arg2_tree),
4690                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4691                                           convert (void_type_node,
4692                                                    mask_arg1),
4693                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4694                                                     convert (void_type_node,
4695                                                              masked_arg1),
4696                                                     expr_tree))));
4697         expr_tree
4698           = ffecom_2 (COMPOUND_EXPR, tree_type,
4699                       convert (void_type_node,
4700                                arg3_tree),
4701                       expr_tree);
4702       }
4703       return expr_tree;
4704
4705     case FFEINTRIN_impLOC:
4706       {
4707         tree arg1_tree = ffecom_expr (arg1);
4708
4709         expr_tree
4710           = convert (tree_type,
4711                      ffecom_1 (ADDR_EXPR,
4712                                build_pointer_type (TREE_TYPE (arg1_tree)),
4713                                arg1_tree));
4714       }
4715       return expr_tree;
4716
4717     case FFEINTRIN_impMVBITS:
4718       {
4719         tree arg1_tree;
4720         tree arg2_tree;
4721         tree arg3_tree;
4722         ffebld arg4 = ffebld_head (ffebld_trail (list));
4723         tree arg4_tree;
4724         tree arg4_type;
4725         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4726         tree arg5_tree;
4727         tree prep_arg1;
4728         tree prep_arg4;
4729         tree arg5_plus_arg3;
4730
4731         arg2_tree = convert (integer_type_node,
4732                              ffecom_expr (arg2));
4733         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4734                                                ffecom_expr (arg3)));
4735         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4736         arg4_type = TREE_TYPE (arg4_tree);
4737
4738         arg1_tree = ffecom_save_tree (convert (arg4_type,
4739                                                ffecom_expr (arg1)));
4740
4741         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4742                                                ffecom_expr (arg5)));
4743
4744         prep_arg1
4745           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4746                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4747                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4748                                           arg1_tree,
4749                                           arg2_tree),
4750                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4751                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4752                                                     ffecom_1 (BIT_NOT_EXPR,
4753                                                               arg4_type,
4754                                                               convert
4755                                                               (arg4_type,
4756                                                         integer_zero_node)),
4757                                                     arg3_tree))),
4758                       arg5_tree);
4759         arg5_plus_arg3
4760           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4761                                         arg5_tree,
4762                                         arg3_tree));
4763         prep_arg4
4764           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4765                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4766                                 convert (arg4_type,
4767                                          integer_zero_node)),
4768                       arg5_plus_arg3);
4769 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4770         prep_arg4
4771           = ffecom_3 (COND_EXPR, arg4_type,
4772                       ffecom_truth_value
4773                       (ffecom_2 (NE_EXPR, integer_type_node,
4774                                  arg5_plus_arg3,
4775                                  convert (TREE_TYPE (arg5_plus_arg3),
4776                                           TYPE_SIZE (arg4_type)))),
4777                       prep_arg4,
4778                       convert (arg4_type, integer_zero_node));
4779 #endif
4780         prep_arg4
4781           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4782                       arg4_tree,
4783                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4784                                 prep_arg4,
4785                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4786                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4787                                                     ffecom_1 (BIT_NOT_EXPR,
4788                                                               arg4_type,
4789                                                               convert
4790                                                               (arg4_type,
4791                                                         integer_zero_node)),
4792                                                     arg5_tree))));
4793         prep_arg1
4794           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4795                       prep_arg1,
4796                       prep_arg4);
4797 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4798         prep_arg1
4799           = ffecom_3 (COND_EXPR, arg4_type,
4800                       ffecom_truth_value
4801                       (ffecom_2 (NE_EXPR, integer_type_node,
4802                                  arg3_tree,
4803                                  convert (TREE_TYPE (arg3_tree),
4804                                           integer_zero_node))),
4805                       prep_arg1,
4806                       arg4_tree);
4807         prep_arg1
4808           = ffecom_3 (COND_EXPR, arg4_type,
4809                       ffecom_truth_value
4810                       (ffecom_2 (NE_EXPR, integer_type_node,
4811                                  arg3_tree,
4812                                  convert (TREE_TYPE (arg3_tree),
4813                                           TYPE_SIZE (arg4_type)))),
4814                       prep_arg1,
4815                       arg1_tree);
4816 #endif
4817         expr_tree
4818           = ffecom_2s (MODIFY_EXPR, void_type_node,
4819                        arg4_tree,
4820                        prep_arg1);
4821         /* Make sure SAVE_EXPRs get referenced early enough. */
4822         expr_tree
4823           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4824                       arg1_tree,
4825                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4826                                 arg3_tree,
4827                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4828                                           arg5_tree,
4829                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4830                                                     arg5_plus_arg3,
4831                                                     expr_tree))));
4832         expr_tree
4833           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4834                       arg4_tree,
4835                       expr_tree);
4836
4837       }
4838       return expr_tree;
4839
4840     case FFEINTRIN_impDERF:
4841     case FFEINTRIN_impERF:
4842     case FFEINTRIN_impDERFC:
4843     case FFEINTRIN_impERFC:
4844       break;
4845
4846     case FFEINTRIN_impIARGC:
4847       /* extern int xargc; i__1 = xargc - 1; */
4848       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4849                             ffecom_tree_xargc_,
4850                             convert (TREE_TYPE (ffecom_tree_xargc_),
4851                                      integer_one_node));
4852       return expr_tree;
4853
4854     case FFEINTRIN_impSIGNAL_func:
4855     case FFEINTRIN_impSIGNAL_subr:
4856       {
4857         tree arg1_tree;
4858         tree arg2_tree;
4859         tree arg3_tree;
4860
4861         arg1_tree = convert (ffecom_f2c_integer_type_node,
4862                              ffecom_expr (arg1));
4863         arg1_tree = ffecom_1 (ADDR_EXPR,
4864                               build_pointer_type (TREE_TYPE (arg1_tree)),
4865                               arg1_tree);
4866
4867         /* Pass procedure as a pointer to it, anything else by value.  */
4868         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4869           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4870         else
4871           arg2_tree = ffecom_ptr_to_expr (arg2);
4872         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4873                              arg2_tree);
4874
4875         if (arg3 != NULL)
4876           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4877         else
4878           arg3_tree = NULL_TREE;
4879
4880         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4881         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4882         TREE_CHAIN (arg1_tree) = arg2_tree;
4883
4884         expr_tree
4885           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4886                           ffecom_gfrt_kindtype (gfrt),
4887                           FALSE,
4888                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4889                            NULL_TREE :
4890                            tree_type),
4891                           arg1_tree,
4892                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4893                           ffebld_nonter_hook (expr));
4894
4895         if (arg3_tree != NULL_TREE)
4896           expr_tree
4897             = ffecom_modify (NULL_TREE, arg3_tree,
4898                              convert (TREE_TYPE (arg3_tree),
4899                                       expr_tree));
4900       }
4901       return expr_tree;
4902
4903     case FFEINTRIN_impALARM:
4904       {
4905         tree arg1_tree;
4906         tree arg2_tree;
4907         tree arg3_tree;
4908
4909         arg1_tree = convert (ffecom_f2c_integer_type_node,
4910                              ffecom_expr (arg1));
4911         arg1_tree = ffecom_1 (ADDR_EXPR,
4912                               build_pointer_type (TREE_TYPE (arg1_tree)),
4913                               arg1_tree);
4914
4915         /* Pass procedure as a pointer to it, anything else by value.  */
4916         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4917           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4918         else
4919           arg2_tree = ffecom_ptr_to_expr (arg2);
4920         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4921                              arg2_tree);
4922
4923         if (arg3 != NULL)
4924           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4925         else
4926           arg3_tree = NULL_TREE;
4927
4928         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4929         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4930         TREE_CHAIN (arg1_tree) = arg2_tree;
4931
4932         expr_tree
4933           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4934                           ffecom_gfrt_kindtype (gfrt),
4935                           FALSE,
4936                           NULL_TREE,
4937                           arg1_tree,
4938                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4939                           ffebld_nonter_hook (expr));
4940
4941         if (arg3_tree != NULL_TREE)
4942           expr_tree
4943             = ffecom_modify (NULL_TREE, arg3_tree,
4944                              convert (TREE_TYPE (arg3_tree),
4945                                       expr_tree));
4946       }
4947       return expr_tree;
4948
4949     case FFEINTRIN_impCHDIR_subr:
4950     case FFEINTRIN_impFDATE_subr:
4951     case FFEINTRIN_impFGET_subr:
4952     case FFEINTRIN_impFPUT_subr:
4953     case FFEINTRIN_impGETCWD_subr:
4954     case FFEINTRIN_impHOSTNM_subr:
4955     case FFEINTRIN_impSYSTEM_subr:
4956     case FFEINTRIN_impUNLINK_subr:
4957       {
4958         tree arg1_len = integer_zero_node;
4959         tree arg1_tree;
4960         tree arg2_tree;
4961
4962         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4963
4964         if (arg2 != NULL)
4965           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4966         else
4967           arg2_tree = NULL_TREE;
4968
4969         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4970         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4971         TREE_CHAIN (arg1_tree) = arg1_len;
4972
4973         expr_tree
4974           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4975                           ffecom_gfrt_kindtype (gfrt),
4976                           FALSE,
4977                           NULL_TREE,
4978                           arg1_tree,
4979                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4980                           ffebld_nonter_hook (expr));
4981
4982         if (arg2_tree != NULL_TREE)
4983           expr_tree
4984             = ffecom_modify (NULL_TREE, arg2_tree,
4985                              convert (TREE_TYPE (arg2_tree),
4986                                       expr_tree));
4987       }
4988       return expr_tree;
4989
4990     case FFEINTRIN_impEXIT:
4991       if (arg1 != NULL)
4992         break;
4993
4994       expr_tree = build_tree_list (NULL_TREE,
4995                                    ffecom_1 (ADDR_EXPR,
4996                                              build_pointer_type
4997                                              (ffecom_integer_type_node),
4998                                              integer_zero_node));
4999
5000       return
5001         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5002                       ffecom_gfrt_kindtype (gfrt),
5003                       FALSE,
5004                       void_type_node,
5005                       expr_tree,
5006                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5007                       ffebld_nonter_hook (expr));
5008
5009     case FFEINTRIN_impFLUSH:
5010       if (arg1 == NULL)
5011         gfrt = FFECOM_gfrtFLUSH;
5012       else
5013         gfrt = FFECOM_gfrtFLUSH1;
5014       break;
5015
5016     case FFEINTRIN_impCHMOD_subr:
5017     case FFEINTRIN_impLINK_subr:
5018     case FFEINTRIN_impRENAME_subr:
5019     case FFEINTRIN_impSYMLNK_subr:
5020       {
5021         tree arg1_len = integer_zero_node;
5022         tree arg1_tree;
5023         tree arg2_len = integer_zero_node;
5024         tree arg2_tree;
5025         tree arg3_tree;
5026
5027         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5028         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5029         if (arg3 != NULL)
5030           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5031         else
5032           arg3_tree = NULL_TREE;
5033
5034         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5035         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5036         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5037         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5038         TREE_CHAIN (arg1_tree) = arg2_tree;
5039         TREE_CHAIN (arg2_tree) = arg1_len;
5040         TREE_CHAIN (arg1_len) = arg2_len;
5041         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5042                                   ffecom_gfrt_kindtype (gfrt),
5043                                   FALSE,
5044                                   NULL_TREE,
5045                                   arg1_tree,
5046                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5047                                   ffebld_nonter_hook (expr));
5048         if (arg3_tree != NULL_TREE)
5049           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5050                                      convert (TREE_TYPE (arg3_tree),
5051                                               expr_tree));
5052       }
5053       return expr_tree;
5054
5055     case FFEINTRIN_impLSTAT_subr:
5056     case FFEINTRIN_impSTAT_subr:
5057       {
5058         tree arg1_len = integer_zero_node;
5059         tree arg1_tree;
5060         tree arg2_tree;
5061         tree arg3_tree;
5062
5063         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5064
5065         arg2_tree = ffecom_ptr_to_expr (arg2);
5066
5067         if (arg3 != NULL)
5068           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5069         else
5070           arg3_tree = NULL_TREE;
5071
5072         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5073         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5074         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5075         TREE_CHAIN (arg1_tree) = arg2_tree;
5076         TREE_CHAIN (arg2_tree) = arg1_len;
5077         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5078                                   ffecom_gfrt_kindtype (gfrt),
5079                                   FALSE,
5080                                   NULL_TREE,
5081                                   arg1_tree,
5082                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5083                                   ffebld_nonter_hook (expr));
5084         if (arg3_tree != NULL_TREE)
5085           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5086                                      convert (TREE_TYPE (arg3_tree),
5087                                               expr_tree));
5088       }
5089       return expr_tree;
5090
5091     case FFEINTRIN_impFGETC_subr:
5092     case FFEINTRIN_impFPUTC_subr:
5093       {
5094         tree arg1_tree;
5095         tree arg2_tree;
5096         tree arg2_len = integer_zero_node;
5097         tree arg3_tree;
5098
5099         arg1_tree = convert (ffecom_f2c_integer_type_node,
5100                              ffecom_expr (arg1));
5101         arg1_tree = ffecom_1 (ADDR_EXPR,
5102                               build_pointer_type (TREE_TYPE (arg1_tree)),
5103                               arg1_tree);
5104
5105         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5106         if (arg3 != NULL)
5107           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5108         else
5109           arg3_tree = NULL_TREE;
5110
5111         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5112         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5113         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5114         TREE_CHAIN (arg1_tree) = arg2_tree;
5115         TREE_CHAIN (arg2_tree) = arg2_len;
5116
5117         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5118                                   ffecom_gfrt_kindtype (gfrt),
5119                                   FALSE,
5120                                   NULL_TREE,
5121                                   arg1_tree,
5122                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5123                                   ffebld_nonter_hook (expr));
5124         if (arg3_tree != NULL_TREE)
5125           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5126                                      convert (TREE_TYPE (arg3_tree),
5127                                               expr_tree));
5128       }
5129       return expr_tree;
5130
5131     case FFEINTRIN_impFSTAT_subr:
5132       {
5133         tree arg1_tree;
5134         tree arg2_tree;
5135         tree arg3_tree;
5136
5137         arg1_tree = convert (ffecom_f2c_integer_type_node,
5138                              ffecom_expr (arg1));
5139         arg1_tree = ffecom_1 (ADDR_EXPR,
5140                               build_pointer_type (TREE_TYPE (arg1_tree)),
5141                               arg1_tree);
5142
5143         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5144                              ffecom_ptr_to_expr (arg2));
5145
5146         if (arg3 == NULL)
5147           arg3_tree = NULL_TREE;
5148         else
5149           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5150
5151         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5152         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5153         TREE_CHAIN (arg1_tree) = arg2_tree;
5154         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5155                                   ffecom_gfrt_kindtype (gfrt),
5156                                   FALSE,
5157                                   NULL_TREE,
5158                                   arg1_tree,
5159                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5160                                   ffebld_nonter_hook (expr));
5161         if (arg3_tree != NULL_TREE) {
5162           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5163                                      convert (TREE_TYPE (arg3_tree),
5164                                               expr_tree));
5165         }
5166       }
5167       return expr_tree;
5168
5169     case FFEINTRIN_impKILL_subr:
5170       {
5171         tree arg1_tree;
5172         tree arg2_tree;
5173         tree arg3_tree;
5174
5175         arg1_tree = convert (ffecom_f2c_integer_type_node,
5176                              ffecom_expr (arg1));
5177         arg1_tree = ffecom_1 (ADDR_EXPR,
5178                               build_pointer_type (TREE_TYPE (arg1_tree)),
5179                               arg1_tree);
5180
5181         arg2_tree = convert (ffecom_f2c_integer_type_node,
5182                              ffecom_expr (arg2));
5183         arg2_tree = ffecom_1 (ADDR_EXPR,
5184                               build_pointer_type (TREE_TYPE (arg2_tree)),
5185                               arg2_tree);
5186
5187         if (arg3 == NULL)
5188           arg3_tree = NULL_TREE;
5189         else
5190           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5191
5192         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5193         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5194         TREE_CHAIN (arg1_tree) = arg2_tree;
5195         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5196                                   ffecom_gfrt_kindtype (gfrt),
5197                                   FALSE,
5198                                   NULL_TREE,
5199                                   arg1_tree,
5200                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5201                                   ffebld_nonter_hook (expr));
5202         if (arg3_tree != NULL_TREE) {
5203           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5204                                      convert (TREE_TYPE (arg3_tree),
5205                                               expr_tree));
5206         }
5207       }
5208       return expr_tree;
5209
5210     case FFEINTRIN_impCTIME_subr:
5211     case FFEINTRIN_impTTYNAM_subr:
5212       {
5213         tree arg1_len = integer_zero_node;
5214         tree arg1_tree;
5215         tree arg2_tree;
5216
5217         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5218
5219         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5220                               ffecom_f2c_longint_type_node :
5221                               ffecom_f2c_integer_type_node),
5222                              ffecom_expr (arg1));
5223         arg2_tree = ffecom_1 (ADDR_EXPR,
5224                               build_pointer_type (TREE_TYPE (arg2_tree)),
5225                               arg2_tree);
5226
5227         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5228         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5229         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5230         TREE_CHAIN (arg1_len) = arg2_tree;
5231         TREE_CHAIN (arg1_tree) = arg1_len;
5232
5233         expr_tree
5234           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5235                           ffecom_gfrt_kindtype (gfrt),
5236                           FALSE,
5237                           NULL_TREE,
5238                           arg1_tree,
5239                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5240                           ffebld_nonter_hook (expr));
5241         TREE_SIDE_EFFECTS (expr_tree) = 1;
5242       }
5243       return expr_tree;
5244
5245     case FFEINTRIN_impIRAND:
5246     case FFEINTRIN_impRAND:
5247       /* Arg defaults to 0 (normal random case) */
5248       {
5249         tree arg1_tree;
5250
5251         if (arg1 == NULL)
5252           arg1_tree = ffecom_integer_zero_node;
5253         else
5254           arg1_tree = ffecom_expr (arg1);
5255         arg1_tree = convert (ffecom_f2c_integer_type_node,
5256                              arg1_tree);
5257         arg1_tree = ffecom_1 (ADDR_EXPR,
5258                               build_pointer_type (TREE_TYPE (arg1_tree)),
5259                               arg1_tree);
5260         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5261
5262         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5263                                   ffecom_gfrt_kindtype (gfrt),
5264                                   FALSE,
5265                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5266                                    ffecom_f2c_integer_type_node :
5267                                    ffecom_f2c_real_type_node),
5268                                   arg1_tree,
5269                                   dest_tree, dest, dest_used,
5270                                   NULL_TREE, TRUE,
5271                                   ffebld_nonter_hook (expr));
5272       }
5273       return expr_tree;
5274
5275     case FFEINTRIN_impFTELL_subr:
5276     case FFEINTRIN_impUMASK_subr:
5277       {
5278         tree arg1_tree;
5279         tree arg2_tree;
5280
5281         arg1_tree = convert (ffecom_f2c_integer_type_node,
5282                              ffecom_expr (arg1));
5283         arg1_tree = ffecom_1 (ADDR_EXPR,
5284                               build_pointer_type (TREE_TYPE (arg1_tree)),
5285                               arg1_tree);
5286
5287         if (arg2 == NULL)
5288           arg2_tree = NULL_TREE;
5289         else
5290           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5291
5292         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5293                                   ffecom_gfrt_kindtype (gfrt),
5294                                   FALSE,
5295                                   NULL_TREE,
5296                                   build_tree_list (NULL_TREE, arg1_tree),
5297                                   NULL_TREE, NULL, NULL, NULL_TREE,
5298                                   TRUE,
5299                                   ffebld_nonter_hook (expr));
5300         if (arg2_tree != NULL_TREE) {
5301           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5302                                      convert (TREE_TYPE (arg2_tree),
5303                                               expr_tree));
5304         }
5305       }
5306       return expr_tree;
5307
5308     case FFEINTRIN_impCPU_TIME:
5309     case FFEINTRIN_impSECOND_subr:
5310       {
5311         tree arg1_tree;
5312
5313         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5314
5315         expr_tree
5316           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5317                           ffecom_gfrt_kindtype (gfrt),
5318                           FALSE,
5319                           NULL_TREE,
5320                           NULL_TREE,
5321                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5322                           ffebld_nonter_hook (expr));
5323
5324         expr_tree
5325           = ffecom_modify (NULL_TREE, arg1_tree,
5326                            convert (TREE_TYPE (arg1_tree),
5327                                     expr_tree));
5328       }
5329       return expr_tree;
5330
5331     case FFEINTRIN_impDTIME_subr:
5332     case FFEINTRIN_impETIME_subr:
5333       {
5334         tree arg1_tree;
5335         tree result_tree;
5336
5337         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5338
5339         arg1_tree = ffecom_ptr_to_expr (arg1);
5340
5341         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5342                                   ffecom_gfrt_kindtype (gfrt),
5343                                   FALSE,
5344                                   NULL_TREE,
5345                                   build_tree_list (NULL_TREE, arg1_tree),
5346                                   NULL_TREE, NULL, NULL, NULL_TREE,
5347                                   TRUE,
5348                                   ffebld_nonter_hook (expr));
5349         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5350                                    convert (TREE_TYPE (result_tree),
5351                                             expr_tree));
5352       }
5353       return expr_tree;
5354
5355       /* Straightforward calls of libf2c routines: */
5356     case FFEINTRIN_impABORT:
5357     case FFEINTRIN_impACCESS:
5358     case FFEINTRIN_impBESJ0:
5359     case FFEINTRIN_impBESJ1:
5360     case FFEINTRIN_impBESJN:
5361     case FFEINTRIN_impBESY0:
5362     case FFEINTRIN_impBESY1:
5363     case FFEINTRIN_impBESYN:
5364     case FFEINTRIN_impCHDIR_func:
5365     case FFEINTRIN_impCHMOD_func:
5366     case FFEINTRIN_impDATE:
5367     case FFEINTRIN_impDATE_AND_TIME:
5368     case FFEINTRIN_impDBESJ0:
5369     case FFEINTRIN_impDBESJ1:
5370     case FFEINTRIN_impDBESJN:
5371     case FFEINTRIN_impDBESY0:
5372     case FFEINTRIN_impDBESY1:
5373     case FFEINTRIN_impDBESYN:
5374     case FFEINTRIN_impDTIME_func:
5375     case FFEINTRIN_impETIME_func:
5376     case FFEINTRIN_impFGETC_func:
5377     case FFEINTRIN_impFGET_func:
5378     case FFEINTRIN_impFNUM:
5379     case FFEINTRIN_impFPUTC_func:
5380     case FFEINTRIN_impFPUT_func:
5381     case FFEINTRIN_impFSEEK:
5382     case FFEINTRIN_impFSTAT_func:
5383     case FFEINTRIN_impFTELL_func:
5384     case FFEINTRIN_impGERROR:
5385     case FFEINTRIN_impGETARG:
5386     case FFEINTRIN_impGETCWD_func:
5387     case FFEINTRIN_impGETENV:
5388     case FFEINTRIN_impGETGID:
5389     case FFEINTRIN_impGETLOG:
5390     case FFEINTRIN_impGETPID:
5391     case FFEINTRIN_impGETUID:
5392     case FFEINTRIN_impGMTIME:
5393     case FFEINTRIN_impHOSTNM_func:
5394     case FFEINTRIN_impIDATE_unix:
5395     case FFEINTRIN_impIDATE_vxt:
5396     case FFEINTRIN_impIERRNO:
5397     case FFEINTRIN_impISATTY:
5398     case FFEINTRIN_impITIME:
5399     case FFEINTRIN_impKILL_func:
5400     case FFEINTRIN_impLINK_func:
5401     case FFEINTRIN_impLNBLNK:
5402     case FFEINTRIN_impLSTAT_func:
5403     case FFEINTRIN_impLTIME:
5404     case FFEINTRIN_impMCLOCK8:
5405     case FFEINTRIN_impMCLOCK:
5406     case FFEINTRIN_impPERROR:
5407     case FFEINTRIN_impRENAME_func:
5408     case FFEINTRIN_impSECNDS:
5409     case FFEINTRIN_impSECOND_func:
5410     case FFEINTRIN_impSLEEP:
5411     case FFEINTRIN_impSRAND:
5412     case FFEINTRIN_impSTAT_func:
5413     case FFEINTRIN_impSYMLNK_func:
5414     case FFEINTRIN_impSYSTEM_CLOCK:
5415     case FFEINTRIN_impSYSTEM_func:
5416     case FFEINTRIN_impTIME8:
5417     case FFEINTRIN_impTIME_unix:
5418     case FFEINTRIN_impTIME_vxt:
5419     case FFEINTRIN_impUMASK_func:
5420     case FFEINTRIN_impUNLINK_func:
5421       break;
5422
5423     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5424     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5425     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5426     case FFEINTRIN_impNONE:
5427     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5428       fprintf (stderr, "No %s implementation.\n",
5429                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5430       assert ("unimplemented intrinsic" == NULL);
5431       return error_mark_node;
5432     }
5433
5434   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5435
5436   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5437                                     ffebld_right (expr));
5438
5439   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5440                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5441                        tree_type,
5442                        expr_tree, dest_tree, dest, dest_used,
5443                        NULL_TREE, TRUE,
5444                        ffebld_nonter_hook (expr));
5445
5446   /* See bottom of this file for f2c transforms used to determine
5447      many of the above implementations.  The info seems to confuse
5448      Emacs's C mode indentation, which is why it's been moved to
5449      the bottom of this source file.  */
5450 }
5451
5452 #endif
5453 /* For power (exponentiation) where right-hand operand is type INTEGER,
5454    generate in-line code to do it the fast way (which, if the operand
5455    is a constant, might just mean a series of multiplies).  */
5456
5457 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5458 static tree
5459 ffecom_expr_power_integer_ (ffebld expr)
5460 {
5461   tree l = ffecom_expr (ffebld_left (expr));
5462   tree r = ffecom_expr (ffebld_right (expr));
5463   tree ltype = TREE_TYPE (l);
5464   tree rtype = TREE_TYPE (r);
5465   tree result = NULL_TREE;
5466
5467   if (l == error_mark_node
5468       || r == error_mark_node)
5469     return error_mark_node;
5470
5471   if (TREE_CODE (r) == INTEGER_CST)
5472     {
5473       int sgn = tree_int_cst_sgn (r);
5474
5475       if (sgn == 0)
5476         return convert (ltype, integer_one_node);
5477
5478       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5479           && (sgn < 0))
5480         {
5481           /* Reciprocal of integer is either 0, -1, or 1, so after
5482              calculating that (which we leave to the back end to do
5483              or not do optimally), don't bother with any multiplying.  */
5484
5485           result = ffecom_tree_divide_ (ltype,
5486                                         convert (ltype, integer_one_node),
5487                                         l,
5488                                         NULL_TREE, NULL, NULL, NULL_TREE);
5489           r = ffecom_1 (NEGATE_EXPR,
5490                         rtype,
5491                         r);
5492           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5493             result = ffecom_1 (ABS_EXPR, rtype,
5494                                result);
5495         }
5496
5497       /* Generate appropriate series of multiplies, preceded
5498          by divide if the exponent is negative.  */
5499
5500       l = save_expr (l);
5501
5502       if (sgn < 0)
5503         {
5504           l = ffecom_tree_divide_ (ltype,
5505                                    convert (ltype, integer_one_node),
5506                                    l,
5507                                    NULL_TREE, NULL, NULL,
5508                                    ffebld_nonter_hook (expr));
5509           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5510           assert (TREE_CODE (r) == INTEGER_CST);
5511
5512           if (tree_int_cst_sgn (r) < 0)
5513             {                   /* The "most negative" number.  */
5514               r = ffecom_1 (NEGATE_EXPR, rtype,
5515                             ffecom_2 (RSHIFT_EXPR, rtype,
5516                                       r,
5517                                       integer_one_node));
5518               l = save_expr (l);
5519               l = ffecom_2 (MULT_EXPR, ltype,
5520                             l,
5521                             l);
5522             }
5523         }
5524
5525       for (;;)
5526         {
5527           if (TREE_INT_CST_LOW (r) & 1)
5528             {
5529               if (result == NULL_TREE)
5530                 result = l;
5531               else
5532                 result = ffecom_2 (MULT_EXPR, ltype,
5533                                    result,
5534                                    l);
5535             }
5536
5537           r = ffecom_2 (RSHIFT_EXPR, rtype,
5538                         r,
5539                         integer_one_node);
5540           if (integer_zerop (r))
5541             break;
5542           assert (TREE_CODE (r) == INTEGER_CST);
5543
5544           l = save_expr (l);
5545           l = ffecom_2 (MULT_EXPR, ltype,
5546                         l,
5547                         l);
5548         }
5549       return result;
5550     }
5551
5552   /* Though rhs isn't a constant, in-line code cannot be expanded
5553      while transforming dummies
5554      because the back end cannot be easily convinced to generate
5555      stores (MODIFY_EXPR), handle temporaries, and so on before
5556      all the appropriate rtx's have been generated for things like
5557      dummy args referenced in rhs -- which doesn't happen until
5558      store_parm_decls() is called (expand_function_start, I believe,
5559      does the actual rtx-stuffing of PARM_DECLs).
5560
5561      So, in this case, let the caller generate the call to the
5562      run-time-library function to evaluate the power for us.  */
5563
5564   if (ffecom_transform_only_dummies_)
5565     return NULL_TREE;
5566
5567   /* Right-hand operand not a constant, expand in-line code to figure
5568      out how to do the multiplies, &c.
5569
5570      The returned expression is expressed this way in GNU C, where l and
5571      r are the "inputs":
5572
5573      ({ typeof (r) rtmp = r;
5574         typeof (l) ltmp = l;
5575         typeof (l) result;
5576
5577         if (rtmp == 0)
5578           result = 1;
5579         else
5580           {
5581             if ((basetypeof (l) == basetypeof (int))
5582                 && (rtmp < 0))
5583               {
5584                 result = ((typeof (l)) 1) / ltmp;
5585                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5586                   result = -result;
5587               }
5588             else
5589               {
5590                 result = 1;
5591                 if ((basetypeof (l) != basetypeof (int))
5592                     && (rtmp < 0))
5593                   {
5594                     ltmp = ((typeof (l)) 1) / ltmp;
5595                     rtmp = -rtmp;
5596                     if (rtmp < 0)
5597                       {
5598                         rtmp = -(rtmp >> 1);
5599                         ltmp *= ltmp;
5600                       }
5601                   }
5602                 for (;;)
5603                   {
5604                     if (rtmp & 1)
5605                       result *= ltmp;
5606                     if ((rtmp >>= 1) == 0)
5607                       break;
5608                     ltmp *= ltmp;
5609                   }
5610               }
5611           }
5612         result;
5613      })
5614
5615      Note that some of the above is compile-time collapsable, such as
5616      the first part of the if statements that checks the base type of
5617      l against int.  The if statements are phrased that way to suggest
5618      an easy way to generate the if/else constructs here, knowing that
5619      the back end should (and probably does) eliminate the resulting
5620      dead code (either the int case or the non-int case), something
5621      it couldn't do without the redundant phrasing, requiring explicit
5622      dead-code elimination here, which would be kind of difficult to
5623      read.  */
5624
5625   {
5626     tree rtmp;
5627     tree ltmp;
5628     tree divide;
5629     tree basetypeof_l_is_int;
5630     tree se;
5631     tree t;
5632
5633     basetypeof_l_is_int
5634       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5635
5636     se = expand_start_stmt_expr ();
5637
5638     ffecom_start_compstmt ();
5639
5640 #ifndef HAHA
5641     rtmp = ffecom_make_tempvar ("power_r", rtype,
5642                                 FFETARGET_charactersizeNONE, -1);
5643     ltmp = ffecom_make_tempvar ("power_l", ltype,
5644                                 FFETARGET_charactersizeNONE, -1);
5645     result = ffecom_make_tempvar ("power_res", ltype,
5646                                   FFETARGET_charactersizeNONE, -1);
5647     if (TREE_CODE (ltype) == COMPLEX_TYPE
5648         || TREE_CODE (ltype) == RECORD_TYPE)
5649       divide = ffecom_make_tempvar ("power_div", ltype,
5650                                     FFETARGET_charactersizeNONE, -1);
5651     else
5652       divide = NULL_TREE;
5653 #else  /* HAHA */
5654     {
5655       tree hook;
5656
5657       hook = ffebld_nonter_hook (expr);
5658       assert (hook);
5659       assert (TREE_CODE (hook) == TREE_VEC);
5660       assert (TREE_VEC_LENGTH (hook) == 4);
5661       rtmp = TREE_VEC_ELT (hook, 0);
5662       ltmp = TREE_VEC_ELT (hook, 1);
5663       result = TREE_VEC_ELT (hook, 2);
5664       divide = TREE_VEC_ELT (hook, 3);
5665       if (TREE_CODE (ltype) == COMPLEX_TYPE
5666           || TREE_CODE (ltype) == RECORD_TYPE)
5667         assert (divide);
5668       else
5669         assert (! divide);
5670     }
5671 #endif  /* HAHA */
5672
5673     expand_expr_stmt (ffecom_modify (void_type_node,
5674                                      rtmp,
5675                                      r));
5676     expand_expr_stmt (ffecom_modify (void_type_node,
5677                                      ltmp,
5678                                      l));
5679     expand_start_cond (ffecom_truth_value
5680                        (ffecom_2 (EQ_EXPR, integer_type_node,
5681                                   rtmp,
5682                                   convert (rtype, integer_zero_node))),
5683                        0);
5684     expand_expr_stmt (ffecom_modify (void_type_node,
5685                                      result,
5686                                      convert (ltype, integer_one_node)));
5687     expand_start_else ();
5688     if (! integer_zerop (basetypeof_l_is_int))
5689       {
5690         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5691                                      rtmp,
5692                                      convert (rtype,
5693                                               integer_zero_node)),
5694                            0);
5695         expand_expr_stmt (ffecom_modify (void_type_node,
5696                                          result,
5697                                          ffecom_tree_divide_
5698                                          (ltype,
5699                                           convert (ltype, integer_one_node),
5700                                           ltmp,
5701                                           NULL_TREE, NULL, NULL,
5702                                           divide)));
5703         expand_start_cond (ffecom_truth_value
5704                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5705                                       ffecom_2 (LT_EXPR, integer_type_node,
5706                                                 ltmp,
5707                                                 convert (ltype,
5708                                                          integer_zero_node)),
5709                                       ffecom_2 (EQ_EXPR, integer_type_node,
5710                                                 ffecom_2 (BIT_AND_EXPR,
5711                                                           rtype,
5712                                                           ffecom_1 (NEGATE_EXPR,
5713                                                                     rtype,
5714                                                                     rtmp),
5715                                                           convert (rtype,
5716                                                                    integer_one_node)),
5717                                                 convert (rtype,
5718                                                          integer_zero_node)))),
5719                            0);
5720         expand_expr_stmt (ffecom_modify (void_type_node,
5721                                          result,
5722                                          ffecom_1 (NEGATE_EXPR,
5723                                                    ltype,
5724                                                    result)));
5725         expand_end_cond ();
5726         expand_start_else ();
5727       }
5728     expand_expr_stmt (ffecom_modify (void_type_node,
5729                                      result,
5730                                      convert (ltype, integer_one_node)));
5731     expand_start_cond (ffecom_truth_value
5732                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5733                                   ffecom_truth_value_invert
5734                                   (basetypeof_l_is_int),
5735                                   ffecom_2 (LT_EXPR, integer_type_node,
5736                                             rtmp,
5737                                             convert (rtype,
5738                                                      integer_zero_node)))),
5739                        0);
5740     expand_expr_stmt (ffecom_modify (void_type_node,
5741                                      ltmp,
5742                                      ffecom_tree_divide_
5743                                      (ltype,
5744                                       convert (ltype, integer_one_node),
5745                                       ltmp,
5746                                       NULL_TREE, NULL, NULL,
5747                                       divide)));
5748     expand_expr_stmt (ffecom_modify (void_type_node,
5749                                      rtmp,
5750                                      ffecom_1 (NEGATE_EXPR, rtype,
5751                                                rtmp)));
5752     expand_start_cond (ffecom_truth_value
5753                        (ffecom_2 (LT_EXPR, integer_type_node,
5754                                   rtmp,
5755                                   convert (rtype, integer_zero_node))),
5756                        0);
5757     expand_expr_stmt (ffecom_modify (void_type_node,
5758                                      rtmp,
5759                                      ffecom_1 (NEGATE_EXPR, rtype,
5760                                                ffecom_2 (RSHIFT_EXPR,
5761                                                          rtype,
5762                                                          rtmp,
5763                                                          integer_one_node))));
5764     expand_expr_stmt (ffecom_modify (void_type_node,
5765                                      ltmp,
5766                                      ffecom_2 (MULT_EXPR, ltype,
5767                                                ltmp,
5768                                                ltmp)));
5769     expand_end_cond ();
5770     expand_end_cond ();
5771     expand_start_loop (1);
5772     expand_start_cond (ffecom_truth_value
5773                        (ffecom_2 (BIT_AND_EXPR, rtype,
5774                                   rtmp,
5775                                   convert (rtype, integer_one_node))),
5776                        0);
5777     expand_expr_stmt (ffecom_modify (void_type_node,
5778                                      result,
5779                                      ffecom_2 (MULT_EXPR, ltype,
5780                                                result,
5781                                                ltmp)));
5782     expand_end_cond ();
5783     expand_exit_loop_if_false (NULL,
5784                                ffecom_truth_value
5785                                (ffecom_modify (rtype,
5786                                                rtmp,
5787                                                ffecom_2 (RSHIFT_EXPR,
5788                                                          rtype,
5789                                                          rtmp,
5790                                                          integer_one_node))));
5791     expand_expr_stmt (ffecom_modify (void_type_node,
5792                                      ltmp,
5793                                      ffecom_2 (MULT_EXPR, ltype,
5794                                                ltmp,
5795                                                ltmp)));
5796     expand_end_loop ();
5797     expand_end_cond ();
5798     if (!integer_zerop (basetypeof_l_is_int))
5799       expand_end_cond ();
5800     expand_expr_stmt (result);
5801
5802     t = ffecom_end_compstmt ();
5803
5804     result = expand_end_stmt_expr (se);
5805
5806     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5807
5808     if (TREE_CODE (t) == BLOCK)
5809       {
5810         /* Make a BIND_EXPR for the BLOCK already made.  */
5811         result = build (BIND_EXPR, TREE_TYPE (result),
5812                         NULL_TREE, result, t);
5813         /* Remove the block from the tree at this point.
5814            It gets put back at the proper place
5815            when the BIND_EXPR is expanded.  */
5816         delete_block (t);
5817       }
5818     else
5819       result = t;
5820   }
5821
5822   return result;
5823 }
5824
5825 #endif
5826 /* ffecom_expr_transform_ -- Transform symbols in expr
5827
5828    ffebld expr;  // FFE expression.
5829    ffecom_expr_transform_ (expr);
5830
5831    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5832
5833 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5834 static void
5835 ffecom_expr_transform_ (ffebld expr)
5836 {
5837   tree t;
5838   ffesymbol s;
5839
5840 tail_recurse:                   /* :::::::::::::::::::: */
5841
5842   if (expr == NULL)
5843     return;
5844
5845   switch (ffebld_op (expr))
5846     {
5847     case FFEBLD_opSYMTER:
5848       s = ffebld_symter (expr);
5849       t = ffesymbol_hook (s).decl_tree;
5850       if ((t == NULL_TREE)
5851           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5852               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5853                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5854         {
5855           s = ffecom_sym_transform_ (s);
5856           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5857                                                    DIMENSION expr? */
5858         }
5859       break;                    /* Ok if (t == NULL) here. */
5860
5861     case FFEBLD_opITEM:
5862       ffecom_expr_transform_ (ffebld_head (expr));
5863       expr = ffebld_trail (expr);
5864       goto tail_recurse;        /* :::::::::::::::::::: */
5865
5866     default:
5867       break;
5868     }
5869
5870   switch (ffebld_arity (expr))
5871     {
5872     case 2:
5873       ffecom_expr_transform_ (ffebld_left (expr));
5874       expr = ffebld_right (expr);
5875       goto tail_recurse;        /* :::::::::::::::::::: */
5876
5877     case 1:
5878       expr = ffebld_left (expr);
5879       goto tail_recurse;        /* :::::::::::::::::::: */
5880
5881     default:
5882       break;
5883     }
5884
5885   return;
5886 }
5887
5888 #endif
5889 /* Make a type based on info in live f2c.h file.  */
5890
5891 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5892 static void
5893 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5894 {
5895   switch (tcode)
5896     {
5897     case FFECOM_f2ccodeCHAR:
5898       *type = make_signed_type (CHAR_TYPE_SIZE);
5899       break;
5900
5901     case FFECOM_f2ccodeSHORT:
5902       *type = make_signed_type (SHORT_TYPE_SIZE);
5903       break;
5904
5905     case FFECOM_f2ccodeINT:
5906       *type = make_signed_type (INT_TYPE_SIZE);
5907       break;
5908
5909     case FFECOM_f2ccodeLONG:
5910       *type = make_signed_type (LONG_TYPE_SIZE);
5911       break;
5912
5913     case FFECOM_f2ccodeLONGLONG:
5914       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5915       break;
5916
5917     case FFECOM_f2ccodeCHARPTR:
5918       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5919                                   ? signed_char_type_node
5920                                   : unsigned_char_type_node);
5921       break;
5922
5923     case FFECOM_f2ccodeFLOAT:
5924       *type = make_node (REAL_TYPE);
5925       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5926       layout_type (*type);
5927       break;
5928
5929     case FFECOM_f2ccodeDOUBLE:
5930       *type = make_node (REAL_TYPE);
5931       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5932       layout_type (*type);
5933       break;
5934
5935     case FFECOM_f2ccodeLONGDOUBLE:
5936       *type = make_node (REAL_TYPE);
5937       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5938       layout_type (*type);
5939       break;
5940
5941     case FFECOM_f2ccodeTWOREALS:
5942       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5943       break;
5944
5945     case FFECOM_f2ccodeTWODOUBLEREALS:
5946       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5947       break;
5948
5949     default:
5950       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5951       *type = error_mark_node;
5952       return;
5953     }
5954
5955   pushdecl (build_decl (TYPE_DECL,
5956                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5957                         *type));
5958 }
5959
5960 #endif
5961 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5962 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5963    given size.  */
5964
5965 static void
5966 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5967                           int code)
5968 {
5969   int j;
5970   tree t;
5971
5972   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5973     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5974         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5975       {
5976         assert (code != -1);
5977         ffecom_f2c_typecode_[bt][j] = code;
5978         code = -1;
5979       }
5980 }
5981
5982 #endif
5983 /* Finish up globals after doing all program units in file
5984
5985    Need to handle only uninitialized COMMON areas.  */
5986
5987 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5988 static ffeglobal
5989 ffecom_finish_global_ (ffeglobal global)
5990 {
5991   tree cbtype;
5992   tree cbt;
5993   tree size;
5994
5995   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5996       return global;
5997
5998   if (ffeglobal_common_init (global))
5999       return global;
6000
6001   cbt = ffeglobal_hook (global);
6002   if ((cbt == NULL_TREE)
6003       || !ffeglobal_common_have_size (global))
6004     return global;              /* No need to make common, never ref'd. */
6005
6006   DECL_EXTERNAL (cbt) = 0;
6007
6008   /* Give the array a size now.  */
6009
6010   size = build_int_2 ((ffeglobal_common_size (global)
6011                       + ffeglobal_common_pad (global)) - 1,
6012                       0);
6013
6014   cbtype = TREE_TYPE (cbt);
6015   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6016                                            integer_zero_node,
6017                                            size);
6018   if (!TREE_TYPE (size))
6019     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6020   layout_type (cbtype);
6021
6022   cbt = start_decl (cbt, FALSE);
6023   assert (cbt == ffeglobal_hook (global));
6024
6025   finish_decl (cbt, NULL_TREE, FALSE);
6026
6027   return global;
6028 }
6029
6030 #endif
6031 /* Finish up any untransformed symbols.  */
6032
6033 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6034 static ffesymbol
6035 ffecom_finish_symbol_transform_ (ffesymbol s)
6036 {
6037   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6038     return s;
6039
6040   /* It's easy to know to transform an untransformed symbol, to make sure
6041      we put out debugging info for it.  But COMMON variables, unlike
6042      EQUIVALENCE ones, aren't given declarations in addition to the
6043      tree expressions that specify offsets, because COMMON variables
6044      can be referenced in the outer scope where only dummy arguments
6045      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6046      VAR_DECLs for COMMON variables when we transform them for real
6047      use, and therefore we do all the VAR_DECL creating here.  */
6048
6049   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6050     {
6051       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6052           || (ffesymbol_where (s) != FFEINFO_whereNONE
6053               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6054               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6055         /* Not transformed, and not CHARACTER*(*), and not a dummy
6056            argument, which can happen only if the entry point names
6057            it "rides in on" are all invalidated for other reasons.  */
6058         s = ffecom_sym_transform_ (s);
6059     }
6060
6061   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6062       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6063     {
6064       /* This isn't working, at least for dbxout.  The .s file looks
6065          okay to me (burley), but in gdb 4.9 at least, the variables
6066          appear to reside somewhere outside of the common area, so
6067          it doesn't make sense to mislead anyone by generating the info
6068          on those variables until this is fixed.  NOTE: Same problem
6069          with EQUIVALENCE, sadly...see similar #if later.  */
6070       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6071                              ffesymbol_storage (s));
6072     }
6073
6074   return s;
6075 }
6076
6077 #endif
6078 /* Append underscore(s) to name before calling get_identifier.  "us"
6079    is nonzero if the name already contains an underscore and thus
6080    needs two underscores appended.  */
6081
6082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6083 static tree
6084 ffecom_get_appended_identifier_ (char us, const char *name)
6085 {
6086   int i;
6087   char *newname;
6088   tree id;
6089
6090   newname = xmalloc ((i = strlen (name)) + 1
6091                      + ffe_is_underscoring ()
6092                      + us);
6093   memcpy (newname, name, i);
6094   newname[i] = '_';
6095   newname[i + us] = '_';
6096   newname[i + 1 + us] = '\0';
6097   id = get_identifier (newname);
6098
6099   free (newname);
6100
6101   return id;
6102 }
6103
6104 #endif
6105 /* Decide whether to append underscore to name before calling
6106    get_identifier.  */
6107
6108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6109 static tree
6110 ffecom_get_external_identifier_ (ffesymbol s)
6111 {
6112   char us;
6113   const char *name = ffesymbol_text (s);
6114
6115   /* If name is a built-in name, just return it as is.  */
6116
6117   if (!ffe_is_underscoring ()
6118       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6119 #if FFETARGET_isENFORCED_MAIN_NAME
6120       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6121 #else
6122       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6123 #endif
6124       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6125     return get_identifier (name);
6126
6127   us = ffe_is_second_underscore ()
6128     ? (strchr (name, '_') != NULL)
6129       : 0;
6130
6131   return ffecom_get_appended_identifier_ (us, name);
6132 }
6133
6134 #endif
6135 /* Decide whether to append underscore to internal name before calling
6136    get_identifier.
6137
6138    This is for non-external, top-function-context names only.  Transform
6139    identifier so it doesn't conflict with the transformed result
6140    of using a _different_ external name.  E.g. if "CALL FOO" is
6141    transformed into "FOO_();", then the variable in "FOO_ = 3"
6142    must be transformed into something that does not conflict, since
6143    these two things should be independent.
6144
6145    The transformation is as follows.  If the name does not contain
6146    an underscore, there is no possible conflict, so just return.
6147    If the name does contain an underscore, then transform it just
6148    like we transform an external identifier.  */
6149
6150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6151 static tree
6152 ffecom_get_identifier_ (const char *name)
6153 {
6154   /* If name does not contain an underscore, just return it as is.  */
6155
6156   if (!ffe_is_underscoring ()
6157       || (strchr (name, '_') == NULL))
6158     return get_identifier (name);
6159
6160   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6161                                           name);
6162 }
6163
6164 #endif
6165 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6166
6167    tree t;
6168    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6169    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6170          ffesymbol_kindtype(s));
6171
6172    Call after setting up containing function and getting trees for all
6173    other symbols.  */
6174
6175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6176 static tree
6177 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6178 {
6179   ffebld expr = ffesymbol_sfexpr (s);
6180   tree type;
6181   tree func;
6182   tree result;
6183   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6184   static bool recurse = FALSE;
6185   int old_lineno = lineno;
6186   const char *old_input_filename = input_filename;
6187
6188   ffecom_nested_entry_ = s;
6189
6190   /* For now, we don't have a handy pointer to where the sfunc is actually
6191      defined, though that should be easy to add to an ffesymbol. (The
6192      token/where info available might well point to the place where the type
6193      of the sfunc is declared, especially if that precedes the place where
6194      the sfunc itself is defined, which is typically the case.)  We should
6195      put out a null pointer rather than point somewhere wrong, but I want to
6196      see how it works at this point.  */
6197
6198   input_filename = ffesymbol_where_filename (s);
6199   lineno = ffesymbol_where_filelinenum (s);
6200
6201   /* Pretransform the expression so any newly discovered things belong to the
6202      outer program unit, not to the statement function. */
6203
6204   ffecom_expr_transform_ (expr);
6205
6206   /* Make sure no recursive invocation of this fn (a specific case of failing
6207      to pretransform an sfunc's expression, i.e. where its expression
6208      references another untransformed sfunc) happens. */
6209
6210   assert (!recurse);
6211   recurse = TRUE;
6212
6213   push_f_function_context ();
6214
6215   if (charfunc)
6216     type = void_type_node;
6217   else
6218     {
6219       type = ffecom_tree_type[bt][kt];
6220       if (type == NULL_TREE)
6221         type = integer_type_node;       /* _sym_exec_transition reports
6222                                            error. */
6223     }
6224
6225   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6226                   build_function_type (type, NULL_TREE),
6227                   1,            /* nested/inline */
6228                   0);           /* TREE_PUBLIC */
6229
6230   /* We don't worry about COMPLEX return values here, because this is
6231      entirely internal to our code, and gcc has the ability to return COMPLEX
6232      directly as a value.  */
6233
6234   if (charfunc)
6235     {                           /* Prepend arg for where result goes. */
6236       tree type;
6237
6238       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6239
6240       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6241
6242       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6243
6244       type = build_pointer_type (type);
6245       result = build_decl (PARM_DECL, result, type);
6246
6247       push_parm_decl (result);
6248     }
6249   else
6250     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6251
6252   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6253
6254   store_parm_decls (0);
6255
6256   ffecom_start_compstmt ();
6257
6258   if (expr != NULL)
6259     {
6260       if (charfunc)
6261         {
6262           ffetargetCharacterSize sz = ffesymbol_size (s);
6263           tree result_length;
6264
6265           result_length = build_int_2 (sz, 0);
6266           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6267
6268           ffecom_prepare_let_char_ (sz, expr);
6269
6270           ffecom_prepare_end ();
6271
6272           ffecom_let_char_ (result, result_length, sz, expr);
6273           expand_null_return ();
6274         }
6275       else
6276         {
6277           ffecom_prepare_expr (expr);
6278
6279           ffecom_prepare_end ();
6280
6281           expand_return (ffecom_modify (NULL_TREE,
6282                                         DECL_RESULT (current_function_decl),
6283                                         ffecom_expr (expr)));
6284         }
6285     }
6286
6287   ffecom_end_compstmt ();
6288
6289   func = current_function_decl;
6290   finish_function (1);
6291
6292   pop_f_function_context ();
6293
6294   recurse = FALSE;
6295
6296   lineno = old_lineno;
6297   input_filename = old_input_filename;
6298
6299   ffecom_nested_entry_ = NULL;
6300
6301   return func;
6302 }
6303
6304 #endif
6305
6306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6307 static const char *
6308 ffecom_gfrt_args_ (ffecomGfrt ix)
6309 {
6310   return ffecom_gfrt_argstring_[ix];
6311 }
6312
6313 #endif
6314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6315 static tree
6316 ffecom_gfrt_tree_ (ffecomGfrt ix)
6317 {
6318   if (ffecom_gfrt_[ix] == NULL_TREE)
6319     ffecom_make_gfrt_ (ix);
6320
6321   return ffecom_1 (ADDR_EXPR,
6322                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6323                    ffecom_gfrt_[ix]);
6324 }
6325
6326 #endif
6327 /* Return initialize-to-zero expression for this VAR_DECL.  */
6328
6329 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6330 /* A somewhat evil way to prevent the garbage collector
6331    from collecting 'tree' structures.  */
6332 #define NUM_TRACKED_CHUNK 63
6333 static struct tree_ggc_tracker
6334 {
6335   struct tree_ggc_tracker *next;
6336   tree trees[NUM_TRACKED_CHUNK];
6337 } *tracker_head = NULL;
6338
6339 static void
6340 mark_tracker_head (void *arg)
6341 {
6342   struct tree_ggc_tracker *head;
6343   int i;
6344
6345   for (head = * (struct tree_ggc_tracker **) arg;
6346        head != NULL;
6347        head = head->next)
6348   {
6349     ggc_mark (head);
6350     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6351       ggc_mark_tree (head->trees[i]);
6352   }
6353 }
6354
6355 void
6356 ffecom_save_tree_forever (tree t)
6357 {
6358   int i;
6359   if (tracker_head != NULL)
6360     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6361       if (tracker_head->trees[i] == NULL)
6362         {
6363           tracker_head->trees[i] = t;
6364           return;
6365         }
6366
6367   {
6368     /* Need to allocate a new block.  */
6369     struct tree_ggc_tracker *old_head = tracker_head;
6370
6371     tracker_head = ggc_alloc (sizeof (*tracker_head));
6372     tracker_head->next = old_head;
6373     tracker_head->trees[0] = t;
6374     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6375       tracker_head->trees[i] = NULL;
6376   }
6377 }
6378
6379 static tree
6380 ffecom_init_zero_ (tree decl)
6381 {
6382   tree init;
6383   int incremental = TREE_STATIC (decl);
6384   tree type = TREE_TYPE (decl);
6385
6386   if (incremental)
6387     {
6388       make_decl_rtl (decl, NULL);
6389       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6390     }
6391
6392   if ((TREE_CODE (type) != ARRAY_TYPE)
6393       && (TREE_CODE (type) != RECORD_TYPE)
6394       && (TREE_CODE (type) != UNION_TYPE)
6395       && !incremental)
6396     init = convert (type, integer_zero_node);
6397   else if (!incremental)
6398     {
6399       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6400       TREE_CONSTANT (init) = 1;
6401       TREE_STATIC (init) = 1;
6402     }
6403   else
6404     {
6405       assemble_zeros (int_size_in_bytes (type));
6406       init = error_mark_node;
6407     }
6408
6409   return init;
6410 }
6411
6412 #endif
6413 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6414 static tree
6415 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6416                          tree *maybe_tree)
6417 {
6418   tree expr_tree;
6419   tree length_tree;
6420
6421   switch (ffebld_op (arg))
6422     {
6423     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6424       if (ffetarget_length_character1
6425           (ffebld_constant_character1
6426            (ffebld_conter (arg))) == 0)
6427         {
6428           *maybe_tree = integer_zero_node;
6429           return convert (tree_type, integer_zero_node);
6430         }
6431
6432       *maybe_tree = integer_one_node;
6433       expr_tree = build_int_2 (*ffetarget_text_character1
6434                                (ffebld_constant_character1
6435                                 (ffebld_conter (arg))),
6436                                0);
6437       TREE_TYPE (expr_tree) = tree_type;
6438       return expr_tree;
6439
6440     case FFEBLD_opSYMTER:
6441     case FFEBLD_opARRAYREF:
6442     case FFEBLD_opFUNCREF:
6443     case FFEBLD_opSUBSTR:
6444       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6445
6446       if ((expr_tree == error_mark_node)
6447           || (length_tree == error_mark_node))
6448         {
6449           *maybe_tree = error_mark_node;
6450           return error_mark_node;
6451         }
6452
6453       if (integer_zerop (length_tree))
6454         {
6455           *maybe_tree = integer_zero_node;
6456           return convert (tree_type, integer_zero_node);
6457         }
6458
6459       expr_tree
6460         = ffecom_1 (INDIRECT_REF,
6461                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6462                     expr_tree);
6463       expr_tree
6464         = ffecom_2 (ARRAY_REF,
6465                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6466                     expr_tree,
6467                     integer_one_node);
6468       expr_tree = convert (tree_type, expr_tree);
6469
6470       if (TREE_CODE (length_tree) == INTEGER_CST)
6471         *maybe_tree = integer_one_node;
6472       else                      /* Must check length at run time.  */
6473         *maybe_tree
6474           = ffecom_truth_value
6475             (ffecom_2 (GT_EXPR, integer_type_node,
6476                        length_tree,
6477                        ffecom_f2c_ftnlen_zero_node));
6478       return expr_tree;
6479
6480     case FFEBLD_opPAREN:
6481     case FFEBLD_opCONVERT:
6482       if (ffeinfo_size (ffebld_info (arg)) == 0)
6483         {
6484           *maybe_tree = integer_zero_node;
6485           return convert (tree_type, integer_zero_node);
6486         }
6487       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6488                                       maybe_tree);
6489
6490     case FFEBLD_opCONCATENATE:
6491       {
6492         tree maybe_left;
6493         tree maybe_right;
6494         tree expr_left;
6495         tree expr_right;
6496
6497         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6498                                              &maybe_left);
6499         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6500                                               &maybe_right);
6501         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6502                                 maybe_left,
6503                                 maybe_right);
6504         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6505                               maybe_left,
6506                               expr_left,
6507                               expr_right);
6508         return expr_tree;
6509       }
6510
6511     default:
6512       assert ("bad op in ICHAR" == NULL);
6513       return error_mark_node;
6514     }
6515 }
6516
6517 #endif
6518 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6519
6520    tree length_arg;
6521    ffebld expr;
6522    length_arg = ffecom_intrinsic_len_ (expr);
6523
6524    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6525    subexpressions by constructing the appropriate tree for the
6526    length-of-character-text argument in a calling sequence.  */
6527
6528 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6529 static tree
6530 ffecom_intrinsic_len_ (ffebld expr)
6531 {
6532   ffetargetCharacter1 val;
6533   tree length;
6534
6535   switch (ffebld_op (expr))
6536     {
6537     case FFEBLD_opCONTER:
6538       val = ffebld_constant_character1 (ffebld_conter (expr));
6539       length = build_int_2 (ffetarget_length_character1 (val), 0);
6540       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6541       break;
6542
6543     case FFEBLD_opSYMTER:
6544       {
6545         ffesymbol s = ffebld_symter (expr);
6546         tree item;
6547
6548         item = ffesymbol_hook (s).decl_tree;
6549         if (item == NULL_TREE)
6550           {
6551             s = ffecom_sym_transform_ (s);
6552             item = ffesymbol_hook (s).decl_tree;
6553           }
6554         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6555           {
6556             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6557               length = ffesymbol_hook (s).length_tree;
6558             else
6559               {
6560                 length = build_int_2 (ffesymbol_size (s), 0);
6561                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6562               }
6563           }
6564         else if (item == error_mark_node)
6565           length = error_mark_node;
6566         else                    /* FFEINFO_kindFUNCTION: */
6567           length = NULL_TREE;
6568       }
6569       break;
6570
6571     case FFEBLD_opARRAYREF:
6572       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6573       break;
6574
6575     case FFEBLD_opSUBSTR:
6576       {
6577         ffebld start;
6578         ffebld end;
6579         ffebld thing = ffebld_right (expr);
6580         tree start_tree;
6581         tree end_tree;
6582
6583         assert (ffebld_op (thing) == FFEBLD_opITEM);
6584         start = ffebld_head (thing);
6585         thing = ffebld_trail (thing);
6586         assert (ffebld_trail (thing) == NULL);
6587         end = ffebld_head (thing);
6588
6589         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6590
6591         if (length == error_mark_node)
6592           break;
6593
6594         if (start == NULL)
6595           {
6596             if (end == NULL)
6597               ;
6598             else
6599               {
6600                 length = convert (ffecom_f2c_ftnlen_type_node,
6601                                   ffecom_expr (end));
6602               }
6603           }
6604         else
6605           {
6606             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6607                                   ffecom_expr (start));
6608
6609             if (start_tree == error_mark_node)
6610               {
6611                 length = error_mark_node;
6612                 break;
6613               }
6614
6615             if (end == NULL)
6616               {
6617                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6618                                    ffecom_f2c_ftnlen_one_node,
6619                                    ffecom_2 (MINUS_EXPR,
6620                                              ffecom_f2c_ftnlen_type_node,
6621                                              length,
6622                                              start_tree));
6623               }
6624             else
6625               {
6626                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6627                                     ffecom_expr (end));
6628
6629                 if (end_tree == error_mark_node)
6630                   {
6631                     length = error_mark_node;
6632                     break;
6633                   }
6634
6635                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6636                                    ffecom_f2c_ftnlen_one_node,
6637                                    ffecom_2 (MINUS_EXPR,
6638                                              ffecom_f2c_ftnlen_type_node,
6639                                              end_tree, start_tree));
6640               }
6641           }
6642       }
6643       break;
6644
6645     case FFEBLD_opCONCATENATE:
6646       length
6647         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6648                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6649                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6650       break;
6651
6652     case FFEBLD_opFUNCREF:
6653     case FFEBLD_opCONVERT:
6654       length = build_int_2 (ffebld_size (expr), 0);
6655       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6656       break;
6657
6658     default:
6659       assert ("bad op for single char arg expr" == NULL);
6660       length = ffecom_f2c_ftnlen_zero_node;
6661       break;
6662     }
6663
6664   assert (length != NULL_TREE);
6665
6666   return length;
6667 }
6668
6669 #endif
6670 /* Handle CHARACTER assignments.
6671
6672    Generates code to do the assignment.  Used by ordinary assignment
6673    statement handler ffecom_let_stmt and by statement-function
6674    handler to generate code for a statement function.  */
6675
6676 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6677 static void
6678 ffecom_let_char_ (tree dest_tree, tree dest_length,
6679                   ffetargetCharacterSize dest_size, ffebld source)
6680 {
6681   ffecomConcatList_ catlist;
6682   tree source_length;
6683   tree source_tree;
6684   tree expr_tree;
6685
6686   if ((dest_tree == error_mark_node)
6687       || (dest_length == error_mark_node))
6688     return;
6689
6690   assert (dest_tree != NULL_TREE);
6691   assert (dest_length != NULL_TREE);
6692
6693   /* Source might be an opCONVERT, which just means it is a different size
6694      than the destination.  Since the underlying implementation here handles
6695      that (directly or via the s_copy or s_cat run-time-library functions),
6696      we don't need the "convenience" of an opCONVERT that tells us to
6697      truncate or blank-pad, particularly since the resulting implementation
6698      would probably be slower than otherwise. */
6699
6700   while (ffebld_op (source) == FFEBLD_opCONVERT)
6701     source = ffebld_left (source);
6702
6703   catlist = ffecom_concat_list_new_ (source, dest_size);
6704   switch (ffecom_concat_list_count_ (catlist))
6705     {
6706     case 0:                     /* Shouldn't happen, but in case it does... */
6707       ffecom_concat_list_kill_ (catlist);
6708       source_tree = null_pointer_node;
6709       source_length = ffecom_f2c_ftnlen_zero_node;
6710       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6711       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6712       TREE_CHAIN (TREE_CHAIN (expr_tree))
6713         = build_tree_list (NULL_TREE, dest_length);
6714       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6715         = build_tree_list (NULL_TREE, source_length);
6716
6717       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6718       TREE_SIDE_EFFECTS (expr_tree) = 1;
6719
6720       expand_expr_stmt (expr_tree);
6721
6722       return;
6723
6724     case 1:                     /* The (fairly) easy case. */
6725       ffecom_char_args_ (&source_tree, &source_length,
6726                          ffecom_concat_list_expr_ (catlist, 0));
6727       ffecom_concat_list_kill_ (catlist);
6728       assert (source_tree != NULL_TREE);
6729       assert (source_length != NULL_TREE);
6730
6731       if ((source_tree == error_mark_node)
6732           || (source_length == error_mark_node))
6733         return;
6734
6735       if (dest_size == 1)
6736         {
6737           dest_tree
6738             = ffecom_1 (INDIRECT_REF,
6739                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6740                                                       (dest_tree))),
6741                         dest_tree);
6742           dest_tree
6743             = ffecom_2 (ARRAY_REF,
6744                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6745                                                       (dest_tree))),
6746                         dest_tree,
6747                         integer_one_node);
6748           source_tree
6749             = ffecom_1 (INDIRECT_REF,
6750                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6751                                                       (source_tree))),
6752                         source_tree);
6753           source_tree
6754             = ffecom_2 (ARRAY_REF,
6755                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6756                                                       (source_tree))),
6757                         source_tree,
6758                         integer_one_node);
6759
6760           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6761
6762           expand_expr_stmt (expr_tree);
6763
6764           return;
6765         }
6766
6767       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6768       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6769       TREE_CHAIN (TREE_CHAIN (expr_tree))
6770         = build_tree_list (NULL_TREE, dest_length);
6771       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6772         = build_tree_list (NULL_TREE, source_length);
6773
6774       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6775       TREE_SIDE_EFFECTS (expr_tree) = 1;
6776
6777       expand_expr_stmt (expr_tree);
6778
6779       return;
6780
6781     default:                    /* Must actually concatenate things. */
6782       break;
6783     }
6784
6785   /* Heavy-duty concatenation. */
6786
6787   {
6788     int count = ffecom_concat_list_count_ (catlist);
6789     int i;
6790     tree lengths;
6791     tree items;
6792     tree length_array;
6793     tree item_array;
6794     tree citem;
6795     tree clength;
6796
6797 #ifdef HOHO
6798     length_array
6799       = lengths
6800       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6801                              FFETARGET_charactersizeNONE, count, TRUE);
6802     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6803                                               FFETARGET_charactersizeNONE,
6804                                               count, TRUE);
6805 #else
6806     {
6807       tree hook;
6808
6809       hook = ffebld_nonter_hook (source);
6810       assert (hook);
6811       assert (TREE_CODE (hook) == TREE_VEC);
6812       assert (TREE_VEC_LENGTH (hook) == 2);
6813       length_array = lengths = TREE_VEC_ELT (hook, 0);
6814       item_array = items = TREE_VEC_ELT (hook, 1);
6815     }
6816 #endif
6817
6818     for (i = 0; i < count; ++i)
6819       {
6820         ffecom_char_args_ (&citem, &clength,
6821                            ffecom_concat_list_expr_ (catlist, i));
6822         if ((citem == error_mark_node)
6823             || (clength == error_mark_node))
6824           {
6825             ffecom_concat_list_kill_ (catlist);
6826             return;
6827           }
6828
6829         items
6830           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6831                       ffecom_modify (void_type_node,
6832                                      ffecom_2 (ARRAY_REF,
6833                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6834                                                item_array,
6835                                                build_int_2 (i, 0)),
6836                                      citem),
6837                       items);
6838         lengths
6839           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6840                       ffecom_modify (void_type_node,
6841                                      ffecom_2 (ARRAY_REF,
6842                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6843                                                length_array,
6844                                                build_int_2 (i, 0)),
6845                                      clength),
6846                       lengths);
6847       }
6848
6849     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6850     TREE_CHAIN (expr_tree)
6851       = build_tree_list (NULL_TREE,
6852                          ffecom_1 (ADDR_EXPR,
6853                                    build_pointer_type (TREE_TYPE (items)),
6854                                    items));
6855     TREE_CHAIN (TREE_CHAIN (expr_tree))
6856       = build_tree_list (NULL_TREE,
6857                          ffecom_1 (ADDR_EXPR,
6858                                    build_pointer_type (TREE_TYPE (lengths)),
6859                                    lengths));
6860     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6861       = build_tree_list
6862         (NULL_TREE,
6863          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6864                    convert (ffecom_f2c_ftnlen_type_node,
6865                             build_int_2 (count, 0))));
6866     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6867       = build_tree_list (NULL_TREE, dest_length);
6868
6869     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6870     TREE_SIDE_EFFECTS (expr_tree) = 1;
6871
6872     expand_expr_stmt (expr_tree);
6873   }
6874
6875   ffecom_concat_list_kill_ (catlist);
6876 }
6877
6878 #endif
6879 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6880
6881    ffecomGfrt ix;
6882    ffecom_make_gfrt_(ix);
6883
6884    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6885    for the indicated run-time routine (ix).  */
6886
6887 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6888 static void
6889 ffecom_make_gfrt_ (ffecomGfrt ix)
6890 {
6891   tree t;
6892   tree ttype;
6893
6894   switch (ffecom_gfrt_type_[ix])
6895     {
6896     case FFECOM_rttypeVOID_:
6897       ttype = void_type_node;
6898       break;
6899
6900     case FFECOM_rttypeVOIDSTAR_:
6901       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6902       break;
6903
6904     case FFECOM_rttypeFTNINT_:
6905       ttype = ffecom_f2c_ftnint_type_node;
6906       break;
6907
6908     case FFECOM_rttypeINTEGER_:
6909       ttype = ffecom_f2c_integer_type_node;
6910       break;
6911
6912     case FFECOM_rttypeLONGINT_:
6913       ttype = ffecom_f2c_longint_type_node;
6914       break;
6915
6916     case FFECOM_rttypeLOGICAL_:
6917       ttype = ffecom_f2c_logical_type_node;
6918       break;
6919
6920     case FFECOM_rttypeREAL_F2C_:
6921       ttype = double_type_node;
6922       break;
6923
6924     case FFECOM_rttypeREAL_GNU_:
6925       ttype = float_type_node;
6926       break;
6927
6928     case FFECOM_rttypeCOMPLEX_F2C_:
6929       ttype = void_type_node;
6930       break;
6931
6932     case FFECOM_rttypeCOMPLEX_GNU_:
6933       ttype = ffecom_f2c_complex_type_node;
6934       break;
6935
6936     case FFECOM_rttypeDOUBLE_:
6937       ttype = double_type_node;
6938       break;
6939
6940     case FFECOM_rttypeDOUBLEREAL_:
6941       ttype = ffecom_f2c_doublereal_type_node;
6942       break;
6943
6944     case FFECOM_rttypeDBLCMPLX_F2C_:
6945       ttype = void_type_node;
6946       break;
6947
6948     case FFECOM_rttypeDBLCMPLX_GNU_:
6949       ttype = ffecom_f2c_doublecomplex_type_node;
6950       break;
6951
6952     case FFECOM_rttypeCHARACTER_:
6953       ttype = void_type_node;
6954       break;
6955
6956     default:
6957       ttype = NULL;
6958       assert ("bad rttype" == NULL);
6959       break;
6960     }
6961
6962   ttype = build_function_type (ttype, NULL_TREE);
6963   t = build_decl (FUNCTION_DECL,
6964                   get_identifier (ffecom_gfrt_name_[ix]),
6965                   ttype);
6966   DECL_EXTERNAL (t) = 1;
6967   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6968   TREE_PUBLIC (t) = 1;
6969   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6970
6971   /* Sanity check:  A function that's const cannot be volatile.  */
6972
6973   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6974
6975   /* Sanity check: A function that's const cannot return complex.  */
6976
6977   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6978
6979   t = start_decl (t, TRUE);
6980
6981   finish_decl (t, NULL_TREE, TRUE);
6982
6983   ffecom_gfrt_[ix] = t;
6984 }
6985
6986 #endif
6987 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6988
6989 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6990 static void
6991 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6992 {
6993   ffesymbol s = ffestorag_symbol (st);
6994
6995   if (ffesymbol_namelisted (s))
6996     ffecom_member_namelisted_ = TRUE;
6997 }
6998
6999 #endif
7000 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7001    the member so debugger will see it.  Otherwise nobody should be
7002    referencing the member.  */
7003
7004 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7005 static void
7006 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7007 {
7008   ffesymbol s;
7009   tree t;
7010   tree mt;
7011   tree type;
7012
7013   if ((mst == NULL)
7014       || ((mt = ffestorag_hook (mst)) == NULL)
7015       || (mt == error_mark_node))
7016     return;
7017
7018   if ((st == NULL)
7019       || ((s = ffestorag_symbol (st)) == NULL))
7020     return;
7021
7022   type = ffecom_type_localvar_ (s,
7023                                 ffesymbol_basictype (s),
7024                                 ffesymbol_kindtype (s));
7025   if (type == error_mark_node)
7026     return;
7027
7028   t = build_decl (VAR_DECL,
7029                   ffecom_get_identifier_ (ffesymbol_text (s)),
7030                   type);
7031
7032   TREE_STATIC (t) = TREE_STATIC (mt);
7033   DECL_INITIAL (t) = NULL_TREE;
7034   TREE_ASM_WRITTEN (t) = 1;
7035   TREE_USED (t) = 1;
7036
7037   SET_DECL_RTL (t,
7038                 gen_rtx (MEM, TYPE_MODE (type),
7039                          plus_constant (XEXP (DECL_RTL (mt), 0),
7040                                         ffestorag_modulo (mst)
7041                                         + ffestorag_offset (st)
7042                                         - ffestorag_offset (mst))));
7043
7044   t = start_decl (t, FALSE);
7045
7046   finish_decl (t, NULL_TREE, FALSE);
7047 }
7048
7049 #endif
7050 /* Prepare source expression for assignment into a destination perhaps known
7051    to be of a specific size.  */
7052
7053 static void
7054 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7055 {
7056   ffecomConcatList_ catlist;
7057   int count;
7058   int i;
7059   tree ltmp;
7060   tree itmp;
7061   tree tempvar = NULL_TREE;
7062
7063   while (ffebld_op (source) == FFEBLD_opCONVERT)
7064     source = ffebld_left (source);
7065
7066   catlist = ffecom_concat_list_new_ (source, dest_size);
7067   count = ffecom_concat_list_count_ (catlist);
7068
7069   if (count >= 2)
7070     {
7071       ltmp
7072         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7073                                FFETARGET_charactersizeNONE, count);
7074       itmp
7075         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7076                                FFETARGET_charactersizeNONE, count);
7077
7078       tempvar = make_tree_vec (2);
7079       TREE_VEC_ELT (tempvar, 0) = ltmp;
7080       TREE_VEC_ELT (tempvar, 1) = itmp;
7081     }
7082
7083   for (i = 0; i < count; ++i)
7084     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7085
7086   ffecom_concat_list_kill_ (catlist);
7087
7088   if (tempvar)
7089     {
7090       ffebld_nonter_set_hook (source, tempvar);
7091       current_binding_level->prep_state = 1;
7092     }
7093 }
7094
7095 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7096
7097    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7098    (which generates their trees) and then their trees get push_parm_decl'd.
7099
7100    The second arg is TRUE if the dummies are for a statement function, in
7101    which case lengths are not pushed for character arguments (since they are
7102    always known by both the caller and the callee, though the code allows
7103    for someday permitting CHAR*(*) stmtfunc dummies).  */
7104
7105 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7106 static void
7107 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7108 {
7109   ffebld dummy;
7110   ffebld dumlist;
7111   ffesymbol s;
7112   tree parm;
7113
7114   ffecom_transform_only_dummies_ = TRUE;
7115
7116   /* First push the parms corresponding to actual dummy "contents".  */
7117
7118   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7119     {
7120       dummy = ffebld_head (dumlist);
7121       switch (ffebld_op (dummy))
7122         {
7123         case FFEBLD_opSTAR:
7124         case FFEBLD_opANY:
7125           continue;             /* Forget alternate returns. */
7126
7127         default:
7128           break;
7129         }
7130       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7131       s = ffebld_symter (dummy);
7132       parm = ffesymbol_hook (s).decl_tree;
7133       if (parm == NULL_TREE)
7134         {
7135           s = ffecom_sym_transform_ (s);
7136           parm = ffesymbol_hook (s).decl_tree;
7137           assert (parm != NULL_TREE);
7138         }
7139       if (parm != error_mark_node)
7140         push_parm_decl (parm);
7141     }
7142
7143   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7144
7145   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7146     {
7147       dummy = ffebld_head (dumlist);
7148       switch (ffebld_op (dummy))
7149         {
7150         case FFEBLD_opSTAR:
7151         case FFEBLD_opANY:
7152           continue;             /* Forget alternate returns, they mean
7153                                    NOTHING! */
7154
7155         default:
7156           break;
7157         }
7158       s = ffebld_symter (dummy);
7159       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7160         continue;               /* Only looking for CHARACTER arguments. */
7161       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7162         continue;               /* Stmtfunc arg with known size needs no
7163                                    length param. */
7164       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7165         continue;               /* Only looking for variables and arrays. */
7166       parm = ffesymbol_hook (s).length_tree;
7167       assert (parm != NULL_TREE);
7168       if (parm != error_mark_node)
7169         push_parm_decl (parm);
7170     }
7171
7172   ffecom_transform_only_dummies_ = FALSE;
7173 }
7174
7175 #endif
7176 /* ffecom_start_progunit_ -- Beginning of program unit
7177
7178    Does GNU back end stuff necessary to teach it about the start of its
7179    equivalent of a Fortran program unit.  */
7180
7181 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7182 static void
7183 ffecom_start_progunit_ ()
7184 {
7185   ffesymbol fn = ffecom_primary_entry_;
7186   ffebld arglist;
7187   tree id;                      /* Identifier (name) of function. */
7188   tree type;                    /* Type of function. */
7189   tree result;                  /* Result of function. */
7190   ffeinfoBasictype bt;
7191   ffeinfoKindtype kt;
7192   ffeglobal g;
7193   ffeglobalType gt;
7194   ffeglobalType egt = FFEGLOBAL_type;
7195   bool charfunc;
7196   bool cmplxfunc;
7197   bool altentries = (ffecom_num_entrypoints_ != 0);
7198   bool multi
7199   = altentries
7200   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7201   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7202   bool main_program = FALSE;
7203   int old_lineno = lineno;
7204   const char *old_input_filename = input_filename;
7205
7206   assert (fn != NULL);
7207   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7208
7209   input_filename = ffesymbol_where_filename (fn);
7210   lineno = ffesymbol_where_filelinenum (fn);
7211
7212   switch (ffecom_primary_entry_kind_)
7213     {
7214     case FFEINFO_kindPROGRAM:
7215       main_program = TRUE;
7216       gt = FFEGLOBAL_typeMAIN;
7217       bt = FFEINFO_basictypeNONE;
7218       kt = FFEINFO_kindtypeNONE;
7219       type = ffecom_tree_fun_type_void;
7220       charfunc = FALSE;
7221       cmplxfunc = FALSE;
7222       break;
7223
7224     case FFEINFO_kindBLOCKDATA:
7225       gt = FFEGLOBAL_typeBDATA;
7226       bt = FFEINFO_basictypeNONE;
7227       kt = FFEINFO_kindtypeNONE;
7228       type = ffecom_tree_fun_type_void;
7229       charfunc = FALSE;
7230       cmplxfunc = FALSE;
7231       break;
7232
7233     case FFEINFO_kindFUNCTION:
7234       gt = FFEGLOBAL_typeFUNC;
7235       egt = FFEGLOBAL_typeEXT;
7236       bt = ffesymbol_basictype (fn);
7237       kt = ffesymbol_kindtype (fn);
7238       if (bt == FFEINFO_basictypeNONE)
7239         {
7240           ffeimplic_establish_symbol (fn);
7241           if (ffesymbol_funcresult (fn) != NULL)
7242             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7243           bt = ffesymbol_basictype (fn);
7244           kt = ffesymbol_kindtype (fn);
7245         }
7246
7247       if (multi)
7248         charfunc = cmplxfunc = FALSE;
7249       else if (bt == FFEINFO_basictypeCHARACTER)
7250         charfunc = TRUE, cmplxfunc = FALSE;
7251       else if ((bt == FFEINFO_basictypeCOMPLEX)
7252                && ffesymbol_is_f2c (fn)
7253                && !altentries)
7254         charfunc = FALSE, cmplxfunc = TRUE;
7255       else
7256         charfunc = cmplxfunc = FALSE;
7257
7258       if (multi || charfunc)
7259         type = ffecom_tree_fun_type_void;
7260       else if (ffesymbol_is_f2c (fn) && !altentries)
7261         type = ffecom_tree_fun_type[bt][kt];
7262       else
7263         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7264
7265       if ((type == NULL_TREE)
7266           || (TREE_TYPE (type) == NULL_TREE))
7267         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7268       break;
7269
7270     case FFEINFO_kindSUBROUTINE:
7271       gt = FFEGLOBAL_typeSUBR;
7272       egt = FFEGLOBAL_typeEXT;
7273       bt = FFEINFO_basictypeNONE;
7274       kt = FFEINFO_kindtypeNONE;
7275       if (ffecom_is_altreturning_)
7276         type = ffecom_tree_subr_type;
7277       else
7278         type = ffecom_tree_fun_type_void;
7279       charfunc = FALSE;
7280       cmplxfunc = FALSE;
7281       break;
7282
7283     default:
7284       assert ("say what??" == NULL);
7285       /* Fall through. */
7286     case FFEINFO_kindANY:
7287       gt = FFEGLOBAL_typeANY;
7288       bt = FFEINFO_basictypeNONE;
7289       kt = FFEINFO_kindtypeNONE;
7290       type = error_mark_node;
7291       charfunc = FALSE;
7292       cmplxfunc = FALSE;
7293       break;
7294     }
7295
7296   if (altentries)
7297     {
7298       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7299                                            ffesymbol_text (fn));
7300     }
7301 #if FFETARGET_isENFORCED_MAIN
7302   else if (main_program)
7303     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7304 #endif
7305   else
7306     id = ffecom_get_external_identifier_ (fn);
7307
7308   start_function (id,
7309                   type,
7310                   0,            /* nested/inline */
7311                   !altentries); /* TREE_PUBLIC */
7312
7313   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7314
7315   if (!altentries
7316       && ((g = ffesymbol_global (fn)) != NULL)
7317       && ((ffeglobal_type (g) == gt)
7318           || (ffeglobal_type (g) == egt)))
7319     {
7320       ffeglobal_set_hook (g, current_function_decl);
7321     }
7322
7323   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7324      exec-transitioning needs current_function_decl to be filled in.  So we
7325      do these things in two phases. */
7326
7327   if (altentries)
7328     {                           /* 1st arg identifies which entrypoint. */
7329       ffecom_which_entrypoint_decl_
7330         = build_decl (PARM_DECL,
7331                       ffecom_get_invented_identifier ("__g77_%s",
7332                                                       "which_entrypoint"),
7333                       integer_type_node);
7334       push_parm_decl (ffecom_which_entrypoint_decl_);
7335     }
7336
7337   if (charfunc
7338       || cmplxfunc
7339       || multi)
7340     {                           /* Arg for result (return value). */
7341       tree type;
7342       tree length;
7343
7344       if (charfunc)
7345         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7346       else if (cmplxfunc)
7347         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7348       else
7349         type = ffecom_multi_type_node_;
7350
7351       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7352
7353       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7354
7355       if (charfunc)
7356         length = ffecom_char_enhance_arg_ (&type, fn);
7357       else
7358         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7359
7360       type = build_pointer_type (type);
7361       result = build_decl (PARM_DECL, result, type);
7362
7363       push_parm_decl (result);
7364       if (multi)
7365         ffecom_multi_retval_ = result;
7366       else
7367         ffecom_func_result_ = result;
7368
7369       if (charfunc)
7370         {
7371           push_parm_decl (length);
7372           ffecom_func_length_ = length;
7373         }
7374     }
7375
7376   if (ffecom_primary_entry_is_proc_)
7377     {
7378       if (altentries)
7379         arglist = ffecom_master_arglist_;
7380       else
7381         arglist = ffesymbol_dummyargs (fn);
7382       ffecom_push_dummy_decls_ (arglist, FALSE);
7383     }
7384
7385   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7386     store_parm_decls (main_program ? 1 : 0);
7387
7388   ffecom_start_compstmt ();
7389   /* Disallow temp vars at this level.  */
7390   current_binding_level->prep_state = 2;
7391
7392   lineno = old_lineno;
7393   input_filename = old_input_filename;
7394
7395   /* This handles any symbols still untransformed, in case -g specified.
7396      This used to be done in ffecom_finish_progunit, but it turns out to
7397      be necessary to do it here so that statement functions are
7398      expanded before code.  But don't bother for BLOCK DATA.  */
7399
7400   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7401     ffesymbol_drive (ffecom_finish_symbol_transform_);
7402 }
7403
7404 #endif
7405 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7406
7407    ffesymbol s;
7408    ffecom_sym_transform_(s);
7409
7410    The ffesymbol_hook info for s is updated with appropriate backend info
7411    on the symbol.  */
7412
7413 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7414 static ffesymbol
7415 ffecom_sym_transform_ (ffesymbol s)
7416 {
7417   tree t;                       /* Transformed thingy. */
7418   tree tlen;                    /* Length if CHAR*(*). */
7419   bool addr;                    /* Is t the address of the thingy? */
7420   ffeinfoBasictype bt;
7421   ffeinfoKindtype kt;
7422   ffeglobal g;
7423   int old_lineno = lineno;
7424   const char *old_input_filename = input_filename;
7425
7426   /* Must ensure special ASSIGN variables are declared at top of outermost
7427      block, else they'll end up in the innermost block when their first
7428      ASSIGN is seen, which leaves them out of scope when they're the
7429      subject of a GOTO or I/O statement.
7430
7431      We make this variable even if -fugly-assign.  Just let it go unused,
7432      in case it turns out there are cases where we really want to use this
7433      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7434
7435   if (! ffecom_transform_only_dummies_
7436       && ffesymbol_assigned (s)
7437       && ! ffesymbol_hook (s).assign_tree)
7438     s = ffecom_sym_transform_assign_ (s);
7439
7440   if (ffesymbol_sfdummyparent (s) == NULL)
7441     {
7442       input_filename = ffesymbol_where_filename (s);
7443       lineno = ffesymbol_where_filelinenum (s);
7444     }
7445   else
7446     {
7447       ffesymbol sf = ffesymbol_sfdummyparent (s);
7448
7449       input_filename = ffesymbol_where_filename (sf);
7450       lineno = ffesymbol_where_filelinenum (sf);
7451     }
7452
7453   bt = ffeinfo_basictype (ffebld_info (s));
7454   kt = ffeinfo_kindtype (ffebld_info (s));
7455
7456   t = NULL_TREE;
7457   tlen = NULL_TREE;
7458   addr = FALSE;
7459
7460   switch (ffesymbol_kind (s))
7461     {
7462     case FFEINFO_kindNONE:
7463       switch (ffesymbol_where (s))
7464         {
7465         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7466           assert (ffecom_transform_only_dummies_);
7467
7468           /* Before 0.4, this could be ENTITY/DUMMY, but see
7469              ffestu_sym_end_transition -- no longer true (in particular, if
7470              it could be an ENTITY, it _will_ be made one, so that
7471              possibility won't come through here).  So we never make length
7472              arg for CHARACTER type.  */
7473
7474           t = build_decl (PARM_DECL,
7475                           ffecom_get_identifier_ (ffesymbol_text (s)),
7476                           ffecom_tree_ptr_to_subr_type);
7477 #if BUILT_FOR_270
7478           DECL_ARTIFICIAL (t) = 1;
7479 #endif
7480           addr = TRUE;
7481           break;
7482
7483         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7484           assert (!ffecom_transform_only_dummies_);
7485
7486           if (((g = ffesymbol_global (s)) != NULL)
7487               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7488                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7489                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7490               && (ffeglobal_hook (g) != NULL_TREE)
7491               && ffe_is_globals ())
7492             {
7493               t = ffeglobal_hook (g);
7494               break;
7495             }
7496
7497           t = build_decl (FUNCTION_DECL,
7498                           ffecom_get_external_identifier_ (s),
7499                           ffecom_tree_subr_type);       /* Assume subr. */
7500           DECL_EXTERNAL (t) = 1;
7501           TREE_PUBLIC (t) = 1;
7502
7503           t = start_decl (t, FALSE);
7504           finish_decl (t, NULL_TREE, FALSE);
7505
7506           if ((g != NULL)
7507               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7508                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7509                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7510             ffeglobal_set_hook (g, t);
7511
7512           ffecom_save_tree_forever (t);
7513
7514           break;
7515
7516         default:
7517           assert ("NONE where unexpected" == NULL);
7518           /* Fall through. */
7519         case FFEINFO_whereANY:
7520           break;
7521         }
7522       break;
7523
7524     case FFEINFO_kindENTITY:
7525       switch (ffeinfo_where (ffesymbol_info (s)))
7526         {
7527
7528         case FFEINFO_whereCONSTANT:
7529           /* ~~Debugging info needed? */
7530           assert (!ffecom_transform_only_dummies_);
7531           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7532           break;
7533
7534         case FFEINFO_whereLOCAL:
7535           assert (!ffecom_transform_only_dummies_);
7536
7537           {
7538             ffestorag st = ffesymbol_storage (s);
7539             tree type;
7540
7541             if ((st != NULL)
7542                 && (ffestorag_size (st) == 0))
7543               {
7544                 t = error_mark_node;
7545                 break;
7546               }
7547
7548             type = ffecom_type_localvar_ (s, bt, kt);
7549
7550             if (type == error_mark_node)
7551               {
7552                 t = error_mark_node;
7553                 break;
7554               }
7555
7556             if ((st != NULL)
7557                 && (ffestorag_parent (st) != NULL))
7558               {                 /* Child of EQUIVALENCE parent. */
7559                 ffestorag est;
7560                 tree et;
7561                 ffetargetOffset offset;
7562
7563                 est = ffestorag_parent (st);
7564                 ffecom_transform_equiv_ (est);
7565
7566                 et = ffestorag_hook (est);
7567                 assert (et != NULL_TREE);
7568
7569                 if (! TREE_STATIC (et))
7570                   put_var_into_stack (et);
7571
7572                 offset = ffestorag_modulo (est)
7573                   + ffestorag_offset (ffesymbol_storage (s))
7574                   - ffestorag_offset (est);
7575
7576                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7577
7578                 /* (t_type *) (((char *) &et) + offset) */
7579
7580                 t = convert (string_type_node,  /* (char *) */
7581                              ffecom_1 (ADDR_EXPR,
7582                                        build_pointer_type (TREE_TYPE (et)),
7583                                        et));
7584                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7585                               t,
7586                               build_int_2 (offset, 0));
7587                 t = convert (build_pointer_type (type),
7588                              t);
7589                 TREE_CONSTANT (t) = staticp (et);
7590
7591                 addr = TRUE;
7592               }
7593             else
7594               {
7595                 tree initexpr;
7596                 bool init = ffesymbol_is_init (s);
7597
7598                 t = build_decl (VAR_DECL,
7599                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7600                                 type);
7601
7602                 if (init
7603                     || ffesymbol_namelisted (s)
7604 #ifdef FFECOM_sizeMAXSTACKITEM
7605                     || ((st != NULL)
7606                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7607 #endif
7608                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7609                         && (ffecom_primary_entry_kind_
7610                             != FFEINFO_kindBLOCKDATA)
7611                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7612                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7613                 else
7614                   TREE_STATIC (t) = 0;  /* No need to make static. */
7615
7616                 if (init || ffe_is_init_local_zero ())
7617                   DECL_INITIAL (t) = error_mark_node;
7618
7619                 /* Keep -Wunused from complaining about var if it
7620                    is used as sfunc arg or DATA implied-DO.  */
7621                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7622                   DECL_IN_SYSTEM_HEADER (t) = 1;
7623
7624                 t = start_decl (t, FALSE);
7625
7626                 if (init)
7627                   {
7628                     if (ffesymbol_init (s) != NULL)
7629                       initexpr = ffecom_expr (ffesymbol_init (s));
7630                     else
7631                       initexpr = ffecom_init_zero_ (t);
7632                   }
7633                 else if (ffe_is_init_local_zero ())
7634                   initexpr = ffecom_init_zero_ (t);
7635                 else
7636                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7637
7638                 finish_decl (t, initexpr, FALSE);
7639
7640                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7641                   {
7642                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7643                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7644                                                    ffestorag_size (st)));
7645                   }
7646               }
7647           }
7648           break;
7649
7650         case FFEINFO_whereRESULT:
7651           assert (!ffecom_transform_only_dummies_);
7652
7653           if (bt == FFEINFO_basictypeCHARACTER)
7654             {                   /* Result is already in list of dummies, use
7655                                    it (& length). */
7656               t = ffecom_func_result_;
7657               tlen = ffecom_func_length_;
7658               addr = TRUE;
7659               break;
7660             }
7661           if ((ffecom_num_entrypoints_ == 0)
7662               && (bt == FFEINFO_basictypeCOMPLEX)
7663               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7664             {                   /* Result is already in list of dummies, use
7665                                    it. */
7666               t = ffecom_func_result_;
7667               addr = TRUE;
7668               break;
7669             }
7670           if (ffecom_func_result_ != NULL_TREE)
7671             {
7672               t = ffecom_func_result_;
7673               break;
7674             }
7675           if ((ffecom_num_entrypoints_ != 0)
7676               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7677             {
7678               assert (ffecom_multi_retval_ != NULL_TREE);
7679               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7680                             ffecom_multi_retval_);
7681               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7682                             t, ffecom_multi_fields_[bt][kt]);
7683
7684               break;
7685             }
7686
7687           t = build_decl (VAR_DECL,
7688                           ffecom_get_identifier_ (ffesymbol_text (s)),
7689                           ffecom_tree_type[bt][kt]);
7690           TREE_STATIC (t) = 0;  /* Put result on stack. */
7691           t = start_decl (t, FALSE);
7692           finish_decl (t, NULL_TREE, FALSE);
7693
7694           ffecom_func_result_ = t;
7695
7696           break;
7697
7698         case FFEINFO_whereDUMMY:
7699           {
7700             tree type;
7701             ffebld dl;
7702             ffebld dim;
7703             tree low;
7704             tree high;
7705             tree old_sizes;
7706             bool adjustable = FALSE;    /* Conditionally adjustable? */
7707
7708             type = ffecom_tree_type[bt][kt];
7709             if (ffesymbol_sfdummyparent (s) != NULL)
7710               {
7711                 if (current_function_decl == ffecom_outer_function_decl_)
7712                   {                     /* Exec transition before sfunc
7713                                            context; get it later. */
7714                     break;
7715                   }
7716                 t = ffecom_get_identifier_ (ffesymbol_text
7717                                             (ffesymbol_sfdummyparent (s)));
7718               }
7719             else
7720               t = ffecom_get_identifier_ (ffesymbol_text (s));
7721
7722             assert (ffecom_transform_only_dummies_);
7723
7724             old_sizes = get_pending_sizes ();
7725             put_pending_sizes (old_sizes);
7726
7727             if (bt == FFEINFO_basictypeCHARACTER)
7728               tlen = ffecom_char_enhance_arg_ (&type, s);
7729             type = ffecom_check_size_overflow_ (s, type, TRUE);
7730
7731             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7732               {
7733                 if (type == error_mark_node)
7734                   break;
7735
7736                 dim = ffebld_head (dl);
7737                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7738                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7739                   low = ffecom_integer_one_node;
7740                 else
7741                   low = ffecom_expr (ffebld_left (dim));
7742                 assert (ffebld_right (dim) != NULL);
7743                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7744                     || ffecom_doing_entry_)
7745                   {
7746                     /* Used to just do high=low.  But for ffecom_tree_
7747                        canonize_ref_, it probably is important to correctly
7748                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7749                        C(2)=CFUNC(C), overlap can happen, while it can't
7750                        for, say, C(1)=CFUNC(C(2)).  */
7751                     /* Even more recently used to set to INT_MAX, but that
7752                        broke when some overflow checking went into the back
7753                        end.  Now we just leave the upper bound unspecified.  */
7754                     high = NULL;
7755                   }
7756                 else
7757                   high = ffecom_expr (ffebld_right (dim));
7758
7759                 /* Determine whether array is conditionally adjustable,
7760                    to decide whether back-end magic is needed.
7761
7762                    Normally the front end uses the back-end function
7763                    variable_size to wrap SAVE_EXPR's around expressions
7764                    affecting the size/shape of an array so that the
7765                    size/shape info doesn't change during execution
7766                    of the compiled code even though variables and
7767                    functions referenced in those expressions might.
7768
7769                    variable_size also makes sure those saved expressions
7770                    get evaluated immediately upon entry to the
7771                    compiled procedure -- the front end normally doesn't
7772                    have to worry about that.
7773
7774                    However, there is a problem with this that affects
7775                    g77's implementation of entry points, and that is
7776                    that it is _not_ true that each invocation of the
7777                    compiled procedure is permitted to evaluate
7778                    array size/shape info -- because it is possible
7779                    that, for some invocations, that info is invalid (in
7780                    which case it is "promised" -- i.e. a violation of
7781                    the Fortran standard -- that the compiled code
7782                    won't reference the array or its size/shape
7783                    during that particular invocation).
7784
7785                    To phrase this in C terms, consider this gcc function:
7786
7787                      void foo (int *n, float (*a)[*n])
7788                      {
7789                        // a is "pointer to array ...", fyi.
7790                      }
7791
7792                    Suppose that, for some invocations, it is permitted
7793                    for a caller of foo to do this:
7794
7795                        foo (NULL, NULL);
7796
7797                    Now the _written_ code for foo can take such a call
7798                    into account by either testing explicitly for whether
7799                    (a == NULL) || (n == NULL) -- presumably it is
7800                    not permitted to reference *a in various fashions
7801                    if (n == NULL) I suppose -- or it can avoid it by
7802                    looking at other info (other arguments, static/global
7803                    data, etc.).
7804
7805                    However, this won't work in gcc 2.5.8 because it'll
7806                    automatically emit the code to save the "*n"
7807                    expression, which'll yield a NULL dereference for
7808                    the "foo (NULL, NULL)" call, something the code
7809                    for foo cannot prevent.
7810
7811                    g77 definitely needs to avoid executing such
7812                    code anytime the pointer to the adjustable array
7813                    is NULL, because even if its bounds expressions
7814                    don't have any references to possible "absent"
7815                    variables like "*n" -- say all variable references
7816                    are to COMMON variables, i.e. global (though in C,
7817                    local static could actually make sense) -- the
7818                    expressions could yield other run-time problems
7819                    for allowably "dead" values in those variables.
7820
7821                    For example, let's consider a more complicated
7822                    version of foo:
7823
7824                      extern int i;
7825                      extern int j;
7826
7827                      void foo (float (*a)[i/j])
7828                      {
7829                        ...
7830                      }
7831
7832                    The above is (essentially) quite valid for Fortran
7833                    but, again, for a call like "foo (NULL);", it is
7834                    permitted for i and j to be undefined when the
7835                    call is made.  If j happened to be zero, for
7836                    example, emitting the code to evaluate "i/j"
7837                    could result in a run-time error.
7838
7839                    Offhand, though I don't have my F77 or F90
7840                    standards handy, it might even be valid for a
7841                    bounds expression to contain a function reference,
7842                    in which case I doubt it is permitted for an
7843                    implementation to invoke that function in the
7844                    Fortran case involved here (invocation of an
7845                    alternate ENTRY point that doesn't have the adjustable
7846                    array as one of its arguments).
7847
7848                    So, the code that the compiler would normally emit
7849                    to preevaluate the size/shape info for an
7850                    adjustable array _must not_ be executed at run time
7851                    in certain cases.  Specifically, for Fortran,
7852                    the case is when the pointer to the adjustable
7853                    array == NULL.  (For gnu-ish C, it might be nice
7854                    for the source code itself to specify an expression
7855                    that, if TRUE, inhibits execution of the code.  Or
7856                    reverse the sense for elegance.)
7857
7858                    (Note that g77 could use a different test than NULL,
7859                    actually, since it happens to always pass an
7860                    integer to the called function that specifies which
7861                    entry point is being invoked.  Hmm, this might
7862                    solve the next problem.)
7863
7864                    One way a user could, I suppose, write "foo" so
7865                    it works is to insert COND_EXPR's for the
7866                    size/shape info so the dangerous stuff isn't
7867                    actually done, as in:
7868
7869                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7870                      {
7871                        ...
7872                      }
7873
7874                    The next problem is that the front end needs to
7875                    be able to tell the back end about the array's
7876                    decl _before_ it tells it about the conditional
7877                    expression to inhibit evaluation of size/shape info,
7878                    as shown above.
7879
7880                    To solve this, the front end needs to be able
7881                    to give the back end the expression to inhibit
7882                    generation of the preevaluation code _after_
7883                    it makes the decl for the adjustable array.
7884
7885                    Until then, the above example using the COND_EXPR
7886                    doesn't pass muster with gcc because the "(a == NULL)"
7887                    part has a reference to "a", which is still
7888                    undefined at that point.
7889
7890                    g77 will therefore use a different mechanism in the
7891                    meantime.  */
7892
7893                 if (!adjustable
7894                     && ((TREE_CODE (low) != INTEGER_CST)
7895                         || (high && TREE_CODE (high) != INTEGER_CST)))
7896                   adjustable = TRUE;
7897
7898 #if 0                           /* Old approach -- see below. */
7899                 if (TREE_CODE (low) != INTEGER_CST)
7900                   low = ffecom_3 (COND_EXPR, integer_type_node,
7901                                   ffecom_adjarray_passed_ (s),
7902                                   low,
7903                                   ffecom_integer_zero_node);
7904
7905                 if (high && TREE_CODE (high) != INTEGER_CST)
7906                   high = ffecom_3 (COND_EXPR, integer_type_node,
7907                                    ffecom_adjarray_passed_ (s),
7908                                    high,
7909                                    ffecom_integer_zero_node);
7910 #endif
7911
7912                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7913                    probably.  Fixes 950302-1.f.  */
7914
7915                 if (TREE_CODE (low) != INTEGER_CST)
7916                   low = variable_size (low);
7917
7918                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7919                    does this, which is why dumb0.c would work.  */
7920
7921                 if (high && TREE_CODE (high) != INTEGER_CST)
7922                   high = variable_size (high);
7923
7924                 type
7925                   = build_array_type
7926                     (type,
7927                      build_range_type (ffecom_integer_type_node,
7928                                        low, high));
7929                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7930               }
7931
7932             if (type == error_mark_node)
7933               {
7934                 t = error_mark_node;
7935                 break;
7936               }
7937
7938             if ((ffesymbol_sfdummyparent (s) == NULL)
7939                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7940               {
7941                 type = build_pointer_type (type);
7942                 addr = TRUE;
7943               }
7944
7945             t = build_decl (PARM_DECL, t, type);
7946 #if BUILT_FOR_270
7947             DECL_ARTIFICIAL (t) = 1;
7948 #endif
7949
7950             /* If this arg is present in every entry point's list of
7951                dummy args, then we're done.  */
7952
7953             if (ffesymbol_numentries (s)
7954                 == (ffecom_num_entrypoints_ + 1))
7955               break;
7956
7957 #if 1
7958
7959             /* If variable_size in stor-layout has been called during
7960                the above, then get_pending_sizes should have the
7961                yet-to-be-evaluated saved expressions pending.
7962                Make the whole lot of them get emitted, conditionally
7963                on whether the array decl ("t" above) is not NULL.  */
7964
7965             {
7966               tree sizes = get_pending_sizes ();
7967               tree tem;
7968
7969               for (tem = sizes;
7970                    tem != old_sizes;
7971                    tem = TREE_CHAIN (tem))
7972                 {
7973                   tree temv = TREE_VALUE (tem);
7974
7975                   if (sizes == tem)
7976                     sizes = temv;
7977                   else
7978                     sizes
7979                       = ffecom_2 (COMPOUND_EXPR,
7980                                   TREE_TYPE (sizes),
7981                                   temv,
7982                                   sizes);
7983                 }
7984
7985               if (sizes != tem)
7986                 {
7987                   sizes
7988                     = ffecom_3 (COND_EXPR,
7989                                 TREE_TYPE (sizes),
7990                                 ffecom_2 (NE_EXPR,
7991                                           integer_type_node,
7992                                           t,
7993                                           null_pointer_node),
7994                                 sizes,
7995                                 convert (TREE_TYPE (sizes),
7996                                          integer_zero_node));
7997                   sizes = ffecom_save_tree (sizes);
7998
7999                   sizes
8000                     = tree_cons (NULL_TREE, sizes, tem);
8001                 }
8002
8003               if (sizes)
8004                 put_pending_sizes (sizes);
8005             }
8006
8007 #else
8008 #if 0
8009             if (adjustable
8010                 && (ffesymbol_numentries (s)
8011                     != ffecom_num_entrypoints_ + 1))
8012               DECL_SOMETHING (t)
8013                 = ffecom_2 (NE_EXPR, integer_type_node,
8014                             t,
8015                             null_pointer_node);
8016 #else
8017 #if 0
8018             if (adjustable
8019                 && (ffesymbol_numentries (s)
8020                     != ffecom_num_entrypoints_ + 1))
8021               {
8022                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8023                 ffebad_here (0, ffesymbol_where_line (s),
8024                              ffesymbol_where_column (s));
8025                 ffebad_string (ffesymbol_text (s));
8026                 ffebad_finish ();
8027               }
8028 #endif
8029 #endif
8030 #endif
8031           }
8032           break;
8033
8034         case FFEINFO_whereCOMMON:
8035           {
8036             ffesymbol cs;
8037             ffeglobal cg;
8038             tree ct;
8039             ffestorag st = ffesymbol_storage (s);
8040             tree type;
8041
8042             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8043             if (st != NULL)     /* Else not laid out. */
8044               {
8045                 ffecom_transform_common_ (cs);
8046                 st = ffesymbol_storage (s);
8047               }
8048
8049             type = ffecom_type_localvar_ (s, bt, kt);
8050
8051             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8052             if ((cg == NULL)
8053                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8054               ct = NULL_TREE;
8055             else
8056               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8057
8058             if ((ct == NULL_TREE)
8059                 || (st == NULL)
8060                 || (type == error_mark_node))
8061               t = error_mark_node;
8062             else
8063               {
8064                 ffetargetOffset offset;
8065                 ffestorag cst;
8066
8067                 cst = ffestorag_parent (st);
8068                 assert (cst == ffesymbol_storage (cs));
8069
8070                 offset = ffestorag_modulo (cst)
8071                   + ffestorag_offset (st)
8072                   - ffestorag_offset (cst);
8073
8074                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8075
8076                 /* (t_type *) (((char *) &ct) + offset) */
8077
8078                 t = convert (string_type_node,  /* (char *) */
8079                              ffecom_1 (ADDR_EXPR,
8080                                        build_pointer_type (TREE_TYPE (ct)),
8081                                        ct));
8082                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8083                               t,
8084                               build_int_2 (offset, 0));
8085                 t = convert (build_pointer_type (type),
8086                              t);
8087                 TREE_CONSTANT (t) = 1;
8088
8089                 addr = TRUE;
8090               }
8091           }
8092           break;
8093
8094         case FFEINFO_whereIMMEDIATE:
8095         case FFEINFO_whereGLOBAL:
8096         case FFEINFO_whereFLEETING:
8097         case FFEINFO_whereFLEETING_CADDR:
8098         case FFEINFO_whereFLEETING_IADDR:
8099         case FFEINFO_whereINTRINSIC:
8100         case FFEINFO_whereCONSTANT_SUBOBJECT:
8101         default:
8102           assert ("ENTITY where unheard of" == NULL);
8103           /* Fall through. */
8104         case FFEINFO_whereANY:
8105           t = error_mark_node;
8106           break;
8107         }
8108       break;
8109
8110     case FFEINFO_kindFUNCTION:
8111       switch (ffeinfo_where (ffesymbol_info (s)))
8112         {
8113         case FFEINFO_whereLOCAL:        /* Me. */
8114           assert (!ffecom_transform_only_dummies_);
8115           t = current_function_decl;
8116           break;
8117
8118         case FFEINFO_whereGLOBAL:
8119           assert (!ffecom_transform_only_dummies_);
8120
8121           if (((g = ffesymbol_global (s)) != NULL)
8122               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8123                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8124               && (ffeglobal_hook (g) != NULL_TREE)
8125               && ffe_is_globals ())
8126             {
8127               t = ffeglobal_hook (g);
8128               break;
8129             }
8130
8131           if (ffesymbol_is_f2c (s)
8132               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8133             t = ffecom_tree_fun_type[bt][kt];
8134           else
8135             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8136
8137           t = build_decl (FUNCTION_DECL,
8138                           ffecom_get_external_identifier_ (s),
8139                           t);
8140           DECL_EXTERNAL (t) = 1;
8141           TREE_PUBLIC (t) = 1;
8142
8143           t = start_decl (t, FALSE);
8144           finish_decl (t, NULL_TREE, FALSE);
8145
8146           if ((g != NULL)
8147               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8148                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8149             ffeglobal_set_hook (g, t);
8150
8151           ffecom_save_tree_forever (t);
8152
8153           break;
8154
8155         case FFEINFO_whereDUMMY:
8156           assert (ffecom_transform_only_dummies_);
8157
8158           if (ffesymbol_is_f2c (s)
8159               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8160             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8161           else
8162             t = build_pointer_type
8163               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8164
8165           t = build_decl (PARM_DECL,
8166                           ffecom_get_identifier_ (ffesymbol_text (s)),
8167                           t);
8168 #if BUILT_FOR_270
8169           DECL_ARTIFICIAL (t) = 1;
8170 #endif
8171           addr = TRUE;
8172           break;
8173
8174         case FFEINFO_whereCONSTANT:     /* Statement function. */
8175           assert (!ffecom_transform_only_dummies_);
8176           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8177           break;
8178
8179         case FFEINFO_whereINTRINSIC:
8180           assert (!ffecom_transform_only_dummies_);
8181           break;                /* Let actual references generate their
8182                                    decls. */
8183
8184         default:
8185           assert ("FUNCTION where unheard of" == NULL);
8186           /* Fall through. */
8187         case FFEINFO_whereANY:
8188           t = error_mark_node;
8189           break;
8190         }
8191       break;
8192
8193     case FFEINFO_kindSUBROUTINE:
8194       switch (ffeinfo_where (ffesymbol_info (s)))
8195         {
8196         case FFEINFO_whereLOCAL:        /* Me. */
8197           assert (!ffecom_transform_only_dummies_);
8198           t = current_function_decl;
8199           break;
8200
8201         case FFEINFO_whereGLOBAL:
8202           assert (!ffecom_transform_only_dummies_);
8203
8204           if (((g = ffesymbol_global (s)) != NULL)
8205               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8206                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8207               && (ffeglobal_hook (g) != NULL_TREE)
8208               && ffe_is_globals ())
8209             {
8210               t = ffeglobal_hook (g);
8211               break;
8212             }
8213
8214           t = build_decl (FUNCTION_DECL,
8215                           ffecom_get_external_identifier_ (s),
8216                           ffecom_tree_subr_type);
8217           DECL_EXTERNAL (t) = 1;
8218           TREE_PUBLIC (t) = 1;
8219
8220           t = start_decl (t, FALSE);
8221           finish_decl (t, NULL_TREE, FALSE);
8222
8223           if ((g != NULL)
8224               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8225                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8226             ffeglobal_set_hook (g, t);
8227
8228           ffecom_save_tree_forever (t);
8229
8230           break;
8231
8232         case FFEINFO_whereDUMMY:
8233           assert (ffecom_transform_only_dummies_);
8234
8235           t = build_decl (PARM_DECL,
8236                           ffecom_get_identifier_ (ffesymbol_text (s)),
8237                           ffecom_tree_ptr_to_subr_type);
8238 #if BUILT_FOR_270
8239           DECL_ARTIFICIAL (t) = 1;
8240 #endif
8241           addr = TRUE;
8242           break;
8243
8244         case FFEINFO_whereINTRINSIC:
8245           assert (!ffecom_transform_only_dummies_);
8246           break;                /* Let actual references generate their
8247                                    decls. */
8248
8249         default:
8250           assert ("SUBROUTINE where unheard of" == NULL);
8251           /* Fall through. */
8252         case FFEINFO_whereANY:
8253           t = error_mark_node;
8254           break;
8255         }
8256       break;
8257
8258     case FFEINFO_kindPROGRAM:
8259       switch (ffeinfo_where (ffesymbol_info (s)))
8260         {
8261         case FFEINFO_whereLOCAL:        /* Me. */
8262           assert (!ffecom_transform_only_dummies_);
8263           t = current_function_decl;
8264           break;
8265
8266         case FFEINFO_whereCOMMON:
8267         case FFEINFO_whereDUMMY:
8268         case FFEINFO_whereGLOBAL:
8269         case FFEINFO_whereRESULT:
8270         case FFEINFO_whereFLEETING:
8271         case FFEINFO_whereFLEETING_CADDR:
8272         case FFEINFO_whereFLEETING_IADDR:
8273         case FFEINFO_whereIMMEDIATE:
8274         case FFEINFO_whereINTRINSIC:
8275         case FFEINFO_whereCONSTANT:
8276         case FFEINFO_whereCONSTANT_SUBOBJECT:
8277         default:
8278           assert ("PROGRAM where unheard of" == NULL);
8279           /* Fall through. */
8280         case FFEINFO_whereANY:
8281           t = error_mark_node;
8282           break;
8283         }
8284       break;
8285
8286     case FFEINFO_kindBLOCKDATA:
8287       switch (ffeinfo_where (ffesymbol_info (s)))
8288         {
8289         case FFEINFO_whereLOCAL:        /* Me. */
8290           assert (!ffecom_transform_only_dummies_);
8291           t = current_function_decl;
8292           break;
8293
8294         case FFEINFO_whereGLOBAL:
8295           assert (!ffecom_transform_only_dummies_);
8296
8297           t = build_decl (FUNCTION_DECL,
8298                           ffecom_get_external_identifier_ (s),
8299                           ffecom_tree_blockdata_type);
8300           DECL_EXTERNAL (t) = 1;
8301           TREE_PUBLIC (t) = 1;
8302
8303           t = start_decl (t, FALSE);
8304           finish_decl (t, NULL_TREE, FALSE);
8305
8306           ffecom_save_tree_forever (t);
8307
8308           break;
8309
8310         case FFEINFO_whereCOMMON:
8311         case FFEINFO_whereDUMMY:
8312         case FFEINFO_whereRESULT:
8313         case FFEINFO_whereFLEETING:
8314         case FFEINFO_whereFLEETING_CADDR:
8315         case FFEINFO_whereFLEETING_IADDR:
8316         case FFEINFO_whereIMMEDIATE:
8317         case FFEINFO_whereINTRINSIC:
8318         case FFEINFO_whereCONSTANT:
8319         case FFEINFO_whereCONSTANT_SUBOBJECT:
8320         default:
8321           assert ("BLOCKDATA where unheard of" == NULL);
8322           /* Fall through. */
8323         case FFEINFO_whereANY:
8324           t = error_mark_node;
8325           break;
8326         }
8327       break;
8328
8329     case FFEINFO_kindCOMMON:
8330       switch (ffeinfo_where (ffesymbol_info (s)))
8331         {
8332         case FFEINFO_whereLOCAL:
8333           assert (!ffecom_transform_only_dummies_);
8334           ffecom_transform_common_ (s);
8335           break;
8336
8337         case FFEINFO_whereNONE:
8338         case FFEINFO_whereCOMMON:
8339         case FFEINFO_whereDUMMY:
8340         case FFEINFO_whereGLOBAL:
8341         case FFEINFO_whereRESULT:
8342         case FFEINFO_whereFLEETING:
8343         case FFEINFO_whereFLEETING_CADDR:
8344         case FFEINFO_whereFLEETING_IADDR:
8345         case FFEINFO_whereIMMEDIATE:
8346         case FFEINFO_whereINTRINSIC:
8347         case FFEINFO_whereCONSTANT:
8348         case FFEINFO_whereCONSTANT_SUBOBJECT:
8349         default:
8350           assert ("COMMON where unheard of" == NULL);
8351           /* Fall through. */
8352         case FFEINFO_whereANY:
8353           t = error_mark_node;
8354           break;
8355         }
8356       break;
8357
8358     case FFEINFO_kindCONSTRUCT:
8359       switch (ffeinfo_where (ffesymbol_info (s)))
8360         {
8361         case FFEINFO_whereLOCAL:
8362           assert (!ffecom_transform_only_dummies_);
8363           break;
8364
8365         case FFEINFO_whereNONE:
8366         case FFEINFO_whereCOMMON:
8367         case FFEINFO_whereDUMMY:
8368         case FFEINFO_whereGLOBAL:
8369         case FFEINFO_whereRESULT:
8370         case FFEINFO_whereFLEETING:
8371         case FFEINFO_whereFLEETING_CADDR:
8372         case FFEINFO_whereFLEETING_IADDR:
8373         case FFEINFO_whereIMMEDIATE:
8374         case FFEINFO_whereINTRINSIC:
8375         case FFEINFO_whereCONSTANT:
8376         case FFEINFO_whereCONSTANT_SUBOBJECT:
8377         default:
8378           assert ("CONSTRUCT where unheard of" == NULL);
8379           /* Fall through. */
8380         case FFEINFO_whereANY:
8381           t = error_mark_node;
8382           break;
8383         }
8384       break;
8385
8386     case FFEINFO_kindNAMELIST:
8387       switch (ffeinfo_where (ffesymbol_info (s)))
8388         {
8389         case FFEINFO_whereLOCAL:
8390           assert (!ffecom_transform_only_dummies_);
8391           t = ffecom_transform_namelist_ (s);
8392           break;
8393
8394         case FFEINFO_whereNONE:
8395         case FFEINFO_whereCOMMON:
8396         case FFEINFO_whereDUMMY:
8397         case FFEINFO_whereGLOBAL:
8398         case FFEINFO_whereRESULT:
8399         case FFEINFO_whereFLEETING:
8400         case FFEINFO_whereFLEETING_CADDR:
8401         case FFEINFO_whereFLEETING_IADDR:
8402         case FFEINFO_whereIMMEDIATE:
8403         case FFEINFO_whereINTRINSIC:
8404         case FFEINFO_whereCONSTANT:
8405         case FFEINFO_whereCONSTANT_SUBOBJECT:
8406         default:
8407           assert ("NAMELIST where unheard of" == NULL);
8408           /* Fall through. */
8409         case FFEINFO_whereANY:
8410           t = error_mark_node;
8411           break;
8412         }
8413       break;
8414
8415     default:
8416       assert ("kind unheard of" == NULL);
8417       /* Fall through. */
8418     case FFEINFO_kindANY:
8419       t = error_mark_node;
8420       break;
8421     }
8422
8423   ffesymbol_hook (s).decl_tree = t;
8424   ffesymbol_hook (s).length_tree = tlen;
8425   ffesymbol_hook (s).addr = addr;
8426
8427   lineno = old_lineno;
8428   input_filename = old_input_filename;
8429
8430   return s;
8431 }
8432
8433 #endif
8434 /* Transform into ASSIGNable symbol.
8435
8436    Symbol has already been transformed, but for whatever reason, the
8437    resulting decl_tree has been deemed not usable for an ASSIGN target.
8438    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8439    another local symbol of type void * and stuff that in the assign_tree
8440    argument.  The F77/F90 standards allow this implementation.  */
8441
8442 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8443 static ffesymbol
8444 ffecom_sym_transform_assign_ (ffesymbol s)
8445 {
8446   tree t;                       /* Transformed thingy. */
8447   int old_lineno = lineno;
8448   const char *old_input_filename = input_filename;
8449
8450   if (ffesymbol_sfdummyparent (s) == NULL)
8451     {
8452       input_filename = ffesymbol_where_filename (s);
8453       lineno = ffesymbol_where_filelinenum (s);
8454     }
8455   else
8456     {
8457       ffesymbol sf = ffesymbol_sfdummyparent (s);
8458
8459       input_filename = ffesymbol_where_filename (sf);
8460       lineno = ffesymbol_where_filelinenum (sf);
8461     }
8462
8463   assert (!ffecom_transform_only_dummies_);
8464
8465   t = build_decl (VAR_DECL,
8466                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8467                                                    ffesymbol_text (s)),
8468                   TREE_TYPE (null_pointer_node));
8469
8470   switch (ffesymbol_where (s))
8471     {
8472     case FFEINFO_whereLOCAL:
8473       /* Unlike for regular vars, SAVE status is easy to determine for
8474          ASSIGNed vars, since there's no initialization, there's no
8475          effective storage association (so "SAVE J" does not apply to
8476          K even given "EQUIVALENCE (J,K)"), there's no size issue
8477          to worry about, etc.  */
8478       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8479           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8480           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8481         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8482       else
8483         TREE_STATIC (t) = 0;    /* No need to make static. */
8484       break;
8485
8486     case FFEINFO_whereCOMMON:
8487       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8488       break;
8489
8490     case FFEINFO_whereDUMMY:
8491       /* Note that twinning a DUMMY means the caller won't see
8492          the ASSIGNed value.  But both F77 and F90 allow implementations
8493          to do this, i.e. disallow Fortran code that would try and
8494          take advantage of actually putting a label into a variable
8495          via a dummy argument (or any other storage association, for
8496          that matter).  */
8497       TREE_STATIC (t) = 0;
8498       break;
8499
8500     default:
8501       TREE_STATIC (t) = 0;
8502       break;
8503     }
8504
8505   t = start_decl (t, FALSE);
8506   finish_decl (t, NULL_TREE, FALSE);
8507
8508   ffesymbol_hook (s).assign_tree = t;
8509
8510   lineno = old_lineno;
8511   input_filename = old_input_filename;
8512
8513   return s;
8514 }
8515
8516 #endif
8517 /* Implement COMMON area in back end.
8518
8519    Because COMMON-based variables can be referenced in the dimension
8520    expressions of dummy (adjustable) arrays, and because dummies
8521    (in the gcc back end) need to be put in the outer binding level
8522    of a function (which has two binding levels, the outer holding
8523    the dummies and the inner holding the other vars), special care
8524    must be taken to handle COMMON areas.
8525
8526    The current strategy is basically to always tell the back end about
8527    the COMMON area as a top-level external reference to just a block
8528    of storage of the master type of that area (e.g. integer, real,
8529    character, whatever -- not a structure).  As a distinct action,
8530    if initial values are provided, tell the back end about the area
8531    as a top-level non-external (initialized) area and remember not to
8532    allow further initialization or expansion of the area.  Meanwhile,
8533    if no initialization happens at all, tell the back end about
8534    the largest size we've seen declared so the space does get reserved.
8535    (This function doesn't handle all that stuff, but it does some
8536    of the important things.)
8537
8538    Meanwhile, for COMMON variables themselves, just keep creating
8539    references like *((float *) (&common_area + offset)) each time
8540    we reference the variable.  In other words, don't make a VAR_DECL
8541    or any kind of component reference (like we used to do before 0.4),
8542    though we might do that as well just for debugging purposes (and
8543    stuff the rtl with the appropriate offset expression).  */
8544
8545 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8546 static void
8547 ffecom_transform_common_ (ffesymbol s)
8548 {
8549   ffestorag st = ffesymbol_storage (s);
8550   ffeglobal g = ffesymbol_global (s);
8551   tree cbt;
8552   tree cbtype;
8553   tree init;
8554   tree high;
8555   bool is_init = ffestorag_is_init (st);
8556
8557   assert (st != NULL);
8558
8559   if ((g == NULL)
8560       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8561     return;
8562
8563   /* First update the size of the area in global terms.  */
8564
8565   ffeglobal_size_common (s, ffestorag_size (st));
8566
8567   if (!ffeglobal_common_init (g))
8568     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8569
8570   cbt = ffeglobal_hook (g);
8571
8572   /* If we already have declared this common block for a previous program
8573      unit, and either we already initialized it or we don't have new
8574      initialization for it, just return what we have without changing it.  */
8575
8576   if ((cbt != NULL_TREE)
8577       && (!is_init
8578           || !DECL_EXTERNAL (cbt)))
8579     {
8580       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8581       return;
8582     }
8583
8584   /* Process inits.  */
8585
8586   if (is_init)
8587     {
8588       if (ffestorag_init (st) != NULL)
8589         {
8590           ffebld sexp;
8591
8592           /* Set the padding for the expression, so ffecom_expr
8593              knows to insert that many zeros.  */
8594           switch (ffebld_op (sexp = ffestorag_init (st)))
8595             {
8596             case FFEBLD_opCONTER:
8597               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8598               break;
8599
8600             case FFEBLD_opARRTER:
8601               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8602               break;
8603
8604             case FFEBLD_opACCTER:
8605               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8606               break;
8607
8608             default:
8609               assert ("bad op for cmn init (pad)" == NULL);
8610               break;
8611             }
8612
8613           init = ffecom_expr (sexp);
8614           if (init == error_mark_node)
8615             {                   /* Hopefully the back end complained! */
8616               init = NULL_TREE;
8617               if (cbt != NULL_TREE)
8618                 return;
8619             }
8620         }
8621       else
8622         init = error_mark_node;
8623     }
8624   else
8625     init = NULL_TREE;
8626
8627   /* cbtype must be permanently allocated!  */
8628
8629   /* Allocate the MAX of the areas so far, seen filewide.  */
8630   high = build_int_2 ((ffeglobal_common_size (g)
8631                        + ffeglobal_common_pad (g)) - 1, 0);
8632   TREE_TYPE (high) = ffecom_integer_type_node;
8633
8634   if (init)
8635     cbtype = build_array_type (char_type_node,
8636                                build_range_type (integer_type_node,
8637                                                  integer_zero_node,
8638                                                  high));
8639   else
8640     cbtype = build_array_type (char_type_node, NULL_TREE);
8641
8642   if (cbt == NULL_TREE)
8643     {
8644       cbt
8645         = build_decl (VAR_DECL,
8646                       ffecom_get_external_identifier_ (s),
8647                       cbtype);
8648       TREE_STATIC (cbt) = 1;
8649       TREE_PUBLIC (cbt) = 1;
8650     }
8651   else
8652     {
8653       assert (is_init);
8654       TREE_TYPE (cbt) = cbtype;
8655     }
8656   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8657   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8658
8659   cbt = start_decl (cbt, TRUE);
8660   if (ffeglobal_hook (g) != NULL)
8661     assert (cbt == ffeglobal_hook (g));
8662
8663   assert (!init || !DECL_EXTERNAL (cbt));
8664
8665   /* Make sure that any type can live in COMMON and be referenced
8666      without getting a bus error.  We could pick the most restrictive
8667      alignment of all entities actually placed in the COMMON, but
8668      this seems easy enough.  */
8669
8670   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8671   DECL_USER_ALIGN (cbt) = 0;
8672
8673   if (is_init && (ffestorag_init (st) == NULL))
8674     init = ffecom_init_zero_ (cbt);
8675
8676   finish_decl (cbt, init, TRUE);
8677
8678   if (is_init)
8679     ffestorag_set_init (st, ffebld_new_any ());
8680
8681   if (init)
8682     {
8683       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8684       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8685       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8686                                      (ffeglobal_common_size (g)
8687                                       + ffeglobal_common_pad (g))));
8688     }
8689
8690   ffeglobal_set_hook (g, cbt);
8691
8692   ffestorag_set_hook (st, cbt);
8693
8694   ffecom_save_tree_forever (cbt);
8695 }
8696
8697 #endif
8698 /* Make master area for local EQUIVALENCE.  */
8699
8700 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8701 static void
8702 ffecom_transform_equiv_ (ffestorag eqst)
8703 {
8704   tree eqt;
8705   tree eqtype;
8706   tree init;
8707   tree high;
8708   bool is_init = ffestorag_is_init (eqst);
8709
8710   assert (eqst != NULL);
8711
8712   eqt = ffestorag_hook (eqst);
8713
8714   if (eqt != NULL_TREE)
8715     return;
8716
8717   /* Process inits.  */
8718
8719   if (is_init)
8720     {
8721       if (ffestorag_init (eqst) != NULL)
8722         {
8723           ffebld sexp;
8724
8725           /* Set the padding for the expression, so ffecom_expr
8726              knows to insert that many zeros.  */
8727           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8728             {
8729             case FFEBLD_opCONTER:
8730               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8731               break;
8732
8733             case FFEBLD_opARRTER:
8734               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8735               break;
8736
8737             case FFEBLD_opACCTER:
8738               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8739               break;
8740
8741             default:
8742               assert ("bad op for eqv init (pad)" == NULL);
8743               break;
8744             }
8745
8746           init = ffecom_expr (sexp);
8747           if (init == error_mark_node)
8748             init = NULL_TREE;   /* Hopefully the back end complained! */
8749         }
8750       else
8751         init = error_mark_node;
8752     }
8753   else if (ffe_is_init_local_zero ())
8754     init = error_mark_node;
8755   else
8756     init = NULL_TREE;
8757
8758   ffecom_member_namelisted_ = FALSE;
8759   ffestorag_drive (ffestorag_list_equivs (eqst),
8760                    &ffecom_member_phase1_,
8761                    eqst);
8762
8763   high = build_int_2 ((ffestorag_size (eqst)
8764                        + ffestorag_modulo (eqst)) - 1, 0);
8765   TREE_TYPE (high) = ffecom_integer_type_node;
8766
8767   eqtype = build_array_type (char_type_node,
8768                              build_range_type (ffecom_integer_type_node,
8769                                                ffecom_integer_zero_node,
8770                                                high));
8771
8772   eqt = build_decl (VAR_DECL,
8773                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8774                                                     ffesymbol_text
8775                                                     (ffestorag_symbol (eqst))),
8776                     eqtype);
8777   DECL_EXTERNAL (eqt) = 0;
8778   if (is_init
8779       || ffecom_member_namelisted_
8780 #ifdef FFECOM_sizeMAXSTACKITEM
8781       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8782 #endif
8783       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8784           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8785           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8786     TREE_STATIC (eqt) = 1;
8787   else
8788     TREE_STATIC (eqt) = 0;
8789   TREE_PUBLIC (eqt) = 0;
8790   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8791   DECL_CONTEXT (eqt) = current_function_decl;
8792   if (init)
8793     DECL_INITIAL (eqt) = error_mark_node;
8794   else
8795     DECL_INITIAL (eqt) = NULL_TREE;
8796
8797   eqt = start_decl (eqt, FALSE);
8798
8799   /* Make sure that any type can live in EQUIVALENCE and be referenced
8800      without getting a bus error.  We could pick the most restrictive
8801      alignment of all entities actually placed in the EQUIVALENCE, but
8802      this seems easy enough.  */
8803
8804   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8805   DECL_USER_ALIGN (eqt) = 0;
8806
8807   if ((!is_init && ffe_is_init_local_zero ())
8808       || (is_init && (ffestorag_init (eqst) == NULL)))
8809     init = ffecom_init_zero_ (eqt);
8810
8811   finish_decl (eqt, init, FALSE);
8812
8813   if (is_init)
8814     ffestorag_set_init (eqst, ffebld_new_any ());
8815
8816   {
8817     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8818     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8819                                    (ffestorag_size (eqst)
8820                                     + ffestorag_modulo (eqst))));
8821   }
8822
8823   ffestorag_set_hook (eqst, eqt);
8824
8825   ffestorag_drive (ffestorag_list_equivs (eqst),
8826                    &ffecom_member_phase2_,
8827                    eqst);
8828 }
8829
8830 #endif
8831 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8832
8833 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8834 static tree
8835 ffecom_transform_namelist_ (ffesymbol s)
8836 {
8837   tree nmlt;
8838   tree nmltype = ffecom_type_namelist_ ();
8839   tree nmlinits;
8840   tree nameinit;
8841   tree varsinit;
8842   tree nvarsinit;
8843   tree field;
8844   tree high;
8845   int i;
8846   static int mynumber = 0;
8847
8848   nmlt = build_decl (VAR_DECL,
8849                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8850                                                      mynumber++),
8851                      nmltype);
8852   TREE_STATIC (nmlt) = 1;
8853   DECL_INITIAL (nmlt) = error_mark_node;
8854
8855   nmlt = start_decl (nmlt, FALSE);
8856
8857   /* Process inits.  */
8858
8859   i = strlen (ffesymbol_text (s));
8860
8861   high = build_int_2 (i, 0);
8862   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8863
8864   nameinit = ffecom_build_f2c_string_ (i + 1,
8865                                        ffesymbol_text (s));
8866   TREE_TYPE (nameinit)
8867     = build_type_variant
8868     (build_array_type
8869      (char_type_node,
8870       build_range_type (ffecom_f2c_ftnlen_type_node,
8871                         ffecom_f2c_ftnlen_one_node,
8872                         high)),
8873      1, 0);
8874   TREE_CONSTANT (nameinit) = 1;
8875   TREE_STATIC (nameinit) = 1;
8876   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8877                        nameinit);
8878
8879   varsinit = ffecom_vardesc_array_ (s);
8880   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8881                        varsinit);
8882   TREE_CONSTANT (varsinit) = 1;
8883   TREE_STATIC (varsinit) = 1;
8884
8885   {
8886     ffebld b;
8887
8888     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8889       ++i;
8890   }
8891   nvarsinit = build_int_2 (i, 0);
8892   TREE_TYPE (nvarsinit) = integer_type_node;
8893   TREE_CONSTANT (nvarsinit) = 1;
8894   TREE_STATIC (nvarsinit) = 1;
8895
8896   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8897   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8898                                            varsinit);
8899   TREE_CHAIN (TREE_CHAIN (nmlinits))
8900     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8901
8902   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8903   TREE_CONSTANT (nmlinits) = 1;
8904   TREE_STATIC (nmlinits) = 1;
8905
8906   finish_decl (nmlt, nmlinits, FALSE);
8907
8908   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8909
8910   return nmlt;
8911 }
8912
8913 #endif
8914
8915 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8916    analyzed on the assumption it is calculating a pointer to be
8917    indirected through.  It must return the proper decl and offset,
8918    taking into account different units of measurements for offsets.  */
8919
8920 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8921 static void
8922 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8923                            tree t)
8924 {
8925   switch (TREE_CODE (t))
8926     {
8927     case NOP_EXPR:
8928     case CONVERT_EXPR:
8929     case NON_LVALUE_EXPR:
8930       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8931       break;
8932
8933     case PLUS_EXPR:
8934       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8935       if ((*decl == NULL_TREE)
8936           || (*decl == error_mark_node))
8937         break;
8938
8939       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8940         {
8941           /* An offset into COMMON.  */
8942           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8943                                  *offset, TREE_OPERAND (t, 1)));
8944           /* Convert offset (presumably in bytes) into canonical units
8945              (presumably bits).  */
8946           *offset = size_binop (MULT_EXPR,
8947                                 convert (bitsizetype, *offset),
8948                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8949           break;
8950         }
8951       /* Not a COMMON reference, so an unrecognized pattern.  */
8952       *decl = error_mark_node;
8953       break;
8954
8955     case PARM_DECL:
8956       *decl = t;
8957       *offset = bitsize_zero_node;
8958       break;
8959
8960     case ADDR_EXPR:
8961       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8962         {
8963           /* A reference to COMMON.  */
8964           *decl = TREE_OPERAND (t, 0);
8965           *offset = bitsize_zero_node;
8966           break;
8967         }
8968       /* Fall through.  */
8969     default:
8970       /* Not a COMMON reference, so an unrecognized pattern.  */
8971       *decl = error_mark_node;
8972       break;
8973     }
8974 }
8975 #endif
8976
8977 /* Given a tree that is possibly intended for use as an lvalue, return
8978    information representing a canonical view of that tree as a decl, an
8979    offset into that decl, and a size for the lvalue.
8980
8981    If there's no applicable decl, NULL_TREE is returned for the decl,
8982    and the other fields are left undefined.
8983
8984    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8985    is returned for the decl, and the other fields are left undefined.
8986
8987    Otherwise, the decl returned currently is either a VAR_DECL or a
8988    PARM_DECL.
8989
8990    The offset returned is always valid, but of course not necessarily
8991    a constant, and not necessarily converted into the appropriate
8992    type, leaving that up to the caller (so as to avoid that overhead
8993    if the decls being looked at are different anyway).
8994
8995    If the size cannot be determined (e.g. an adjustable array),
8996    an ERROR_MARK node is returned for the size.  Otherwise, the
8997    size returned is valid, not necessarily a constant, and not
8998    necessarily converted into the appropriate type as with the
8999    offset.
9000
9001    Note that the offset and size expressions are expressed in the
9002    base storage units (usually bits) rather than in the units of
9003    the type of the decl, because two decls with different types
9004    might overlap but with apparently non-overlapping array offsets,
9005    whereas converting the array offsets to consistant offsets will
9006    reveal the overlap.  */
9007
9008 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9009 static void
9010 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9011                            tree *size, tree t)
9012 {
9013   /* The default path is to report a nonexistant decl.  */
9014   *decl = NULL_TREE;
9015
9016   if (t == NULL_TREE)
9017     return;
9018
9019   switch (TREE_CODE (t))
9020     {
9021     case ERROR_MARK:
9022     case IDENTIFIER_NODE:
9023     case INTEGER_CST:
9024     case REAL_CST:
9025     case COMPLEX_CST:
9026     case STRING_CST:
9027     case CONST_DECL:
9028     case PLUS_EXPR:
9029     case MINUS_EXPR:
9030     case MULT_EXPR:
9031     case TRUNC_DIV_EXPR:
9032     case CEIL_DIV_EXPR:
9033     case FLOOR_DIV_EXPR:
9034     case ROUND_DIV_EXPR:
9035     case TRUNC_MOD_EXPR:
9036     case CEIL_MOD_EXPR:
9037     case FLOOR_MOD_EXPR:
9038     case ROUND_MOD_EXPR:
9039     case RDIV_EXPR:
9040     case EXACT_DIV_EXPR:
9041     case FIX_TRUNC_EXPR:
9042     case FIX_CEIL_EXPR:
9043     case FIX_FLOOR_EXPR:
9044     case FIX_ROUND_EXPR:
9045     case FLOAT_EXPR:
9046     case EXPON_EXPR:
9047     case NEGATE_EXPR:
9048     case MIN_EXPR:
9049     case MAX_EXPR:
9050     case ABS_EXPR:
9051     case FFS_EXPR:
9052     case LSHIFT_EXPR:
9053     case RSHIFT_EXPR:
9054     case LROTATE_EXPR:
9055     case RROTATE_EXPR:
9056     case BIT_IOR_EXPR:
9057     case BIT_XOR_EXPR:
9058     case BIT_AND_EXPR:
9059     case BIT_ANDTC_EXPR:
9060     case BIT_NOT_EXPR:
9061     case TRUTH_ANDIF_EXPR:
9062     case TRUTH_ORIF_EXPR:
9063     case TRUTH_AND_EXPR:
9064     case TRUTH_OR_EXPR:
9065     case TRUTH_XOR_EXPR:
9066     case TRUTH_NOT_EXPR:
9067     case LT_EXPR:
9068     case LE_EXPR:
9069     case GT_EXPR:
9070     case GE_EXPR:
9071     case EQ_EXPR:
9072     case NE_EXPR:
9073     case COMPLEX_EXPR:
9074     case CONJ_EXPR:
9075     case REALPART_EXPR:
9076     case IMAGPART_EXPR:
9077     case LABEL_EXPR:
9078     case COMPONENT_REF:
9079     case COMPOUND_EXPR:
9080     case ADDR_EXPR:
9081       return;
9082
9083     case VAR_DECL:
9084     case PARM_DECL:
9085       *decl = t;
9086       *offset = bitsize_zero_node;
9087       *size = TYPE_SIZE (TREE_TYPE (t));
9088       return;
9089
9090     case ARRAY_REF:
9091       {
9092         tree array = TREE_OPERAND (t, 0);
9093         tree element = TREE_OPERAND (t, 1);
9094         tree init_offset;
9095
9096         if ((array == NULL_TREE)
9097             || (element == NULL_TREE))
9098           {
9099             *decl = error_mark_node;
9100             return;
9101           }
9102
9103         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9104                                    array);
9105         if ((*decl == NULL_TREE)
9106             || (*decl == error_mark_node))
9107           return;
9108
9109         /* Calculate ((element - base) * NBBY) + init_offset.  */
9110         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9111                                element,
9112                                TYPE_MIN_VALUE (TYPE_DOMAIN
9113                                                (TREE_TYPE (array)))));
9114
9115         *offset = size_binop (MULT_EXPR,
9116                               convert (bitsizetype, *offset),
9117                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9118
9119         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9120
9121         *size = TYPE_SIZE (TREE_TYPE (t));
9122         return;
9123       }
9124
9125     case INDIRECT_REF:
9126
9127       /* Most of this code is to handle references to COMMON.  And so
9128          far that is useful only for calling library functions, since
9129          external (user) functions might reference common areas.  But
9130          even calling an external function, it's worthwhile to decode
9131          COMMON references because if not storing into COMMON, we don't
9132          want COMMON-based arguments to gratuitously force use of a
9133          temporary.  */
9134
9135       *size = TYPE_SIZE (TREE_TYPE (t));
9136
9137       ffecom_tree_canonize_ptr_ (decl, offset,
9138                                  TREE_OPERAND (t, 0));
9139
9140       return;
9141
9142     case CONVERT_EXPR:
9143     case NOP_EXPR:
9144     case MODIFY_EXPR:
9145     case NON_LVALUE_EXPR:
9146     case RESULT_DECL:
9147     case FIELD_DECL:
9148     case COND_EXPR:             /* More cases than we can handle. */
9149     case SAVE_EXPR:
9150     case REFERENCE_EXPR:
9151     case PREDECREMENT_EXPR:
9152     case PREINCREMENT_EXPR:
9153     case POSTDECREMENT_EXPR:
9154     case POSTINCREMENT_EXPR:
9155     case CALL_EXPR:
9156     default:
9157       *decl = error_mark_node;
9158       return;
9159     }
9160 }
9161 #endif
9162
9163 /* Do divide operation appropriate to type of operands.  */
9164
9165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9166 static tree
9167 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9168                      tree dest_tree, ffebld dest, bool *dest_used,
9169                      tree hook)
9170 {
9171   if ((left == error_mark_node)
9172       || (right == error_mark_node))
9173     return error_mark_node;
9174
9175   switch (TREE_CODE (tree_type))
9176     {
9177     case INTEGER_TYPE:
9178       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9179                        left,
9180                        right);
9181
9182     case COMPLEX_TYPE:
9183       if (! optimize_size)
9184         return ffecom_2 (RDIV_EXPR, tree_type,
9185                          left,
9186                          right);
9187       {
9188         ffecomGfrt ix;
9189
9190         if (TREE_TYPE (tree_type)
9191             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9192           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9193         else
9194           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9195
9196         left = ffecom_1 (ADDR_EXPR,
9197                          build_pointer_type (TREE_TYPE (left)),
9198                          left);
9199         left = build_tree_list (NULL_TREE, left);
9200         right = ffecom_1 (ADDR_EXPR,
9201                           build_pointer_type (TREE_TYPE (right)),
9202                           right);
9203         right = build_tree_list (NULL_TREE, right);
9204         TREE_CHAIN (left) = right;
9205
9206         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9207                              ffecom_gfrt_kindtype (ix),
9208                              ffe_is_f2c_library (),
9209                              tree_type,
9210                              left,
9211                              dest_tree, dest, dest_used,
9212                              NULL_TREE, TRUE, hook);
9213       }
9214       break;
9215
9216     case RECORD_TYPE:
9217       {
9218         ffecomGfrt ix;
9219
9220         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9221             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9222           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9223         else
9224           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9225
9226         left = ffecom_1 (ADDR_EXPR,
9227                          build_pointer_type (TREE_TYPE (left)),
9228                          left);
9229         left = build_tree_list (NULL_TREE, left);
9230         right = ffecom_1 (ADDR_EXPR,
9231                           build_pointer_type (TREE_TYPE (right)),
9232                           right);
9233         right = build_tree_list (NULL_TREE, right);
9234         TREE_CHAIN (left) = right;
9235
9236         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9237                              ffecom_gfrt_kindtype (ix),
9238                              ffe_is_f2c_library (),
9239                              tree_type,
9240                              left,
9241                              dest_tree, dest, dest_used,
9242                              NULL_TREE, TRUE, hook);
9243       }
9244       break;
9245
9246     default:
9247       return ffecom_2 (RDIV_EXPR, tree_type,
9248                        left,
9249                        right);
9250     }
9251 }
9252
9253 #endif
9254 /* Build type info for non-dummy variable.  */
9255
9256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9257 static tree
9258 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9259                        ffeinfoKindtype kt)
9260 {
9261   tree type;
9262   ffebld dl;
9263   ffebld dim;
9264   tree lowt;
9265   tree hight;
9266
9267   type = ffecom_tree_type[bt][kt];
9268   if (bt == FFEINFO_basictypeCHARACTER)
9269     {
9270       hight = build_int_2 (ffesymbol_size (s), 0);
9271       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9272
9273       type
9274         = build_array_type
9275           (type,
9276            build_range_type (ffecom_f2c_ftnlen_type_node,
9277                              ffecom_f2c_ftnlen_one_node,
9278                              hight));
9279       type = ffecom_check_size_overflow_ (s, type, FALSE);
9280     }
9281
9282   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9283     {
9284       if (type == error_mark_node)
9285         break;
9286
9287       dim = ffebld_head (dl);
9288       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9289
9290       if (ffebld_left (dim) == NULL)
9291         lowt = integer_one_node;
9292       else
9293         lowt = ffecom_expr (ffebld_left (dim));
9294
9295       if (TREE_CODE (lowt) != INTEGER_CST)
9296         lowt = variable_size (lowt);
9297
9298       assert (ffebld_right (dim) != NULL);
9299       hight = ffecom_expr (ffebld_right (dim));
9300
9301       if (TREE_CODE (hight) != INTEGER_CST)
9302         hight = variable_size (hight);
9303
9304       type = build_array_type (type,
9305                                build_range_type (ffecom_integer_type_node,
9306                                                  lowt, hight));
9307       type = ffecom_check_size_overflow_ (s, type, FALSE);
9308     }
9309
9310   return type;
9311 }
9312
9313 #endif
9314 /* Build Namelist type.  */
9315
9316 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9317 static tree
9318 ffecom_type_namelist_ ()
9319 {
9320   static tree type = NULL_TREE;
9321
9322   if (type == NULL_TREE)
9323     {
9324       static tree namefield, varsfield, nvarsfield;
9325       tree vardesctype;
9326
9327       vardesctype = ffecom_type_vardesc_ ();
9328
9329       type = make_node (RECORD_TYPE);
9330
9331       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9332
9333       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9334                                      string_type_node);
9335       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9336       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9337                                       integer_type_node);
9338
9339       TYPE_FIELDS (type) = namefield;
9340       layout_type (type);
9341
9342       ggc_add_tree_root (&type, 1);
9343     }
9344
9345   return type;
9346 }
9347
9348 #endif
9349
9350 /* Build Vardesc type.  */
9351
9352 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9353 static tree
9354 ffecom_type_vardesc_ ()
9355 {
9356   static tree type = NULL_TREE;
9357   static tree namefield, addrfield, dimsfield, typefield;
9358
9359   if (type == NULL_TREE)
9360     {
9361       type = make_node (RECORD_TYPE);
9362
9363       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9364                                      string_type_node);
9365       addrfield = ffecom_decl_field (type, namefield, "addr",
9366                                      string_type_node);
9367       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9368                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9369       typefield = ffecom_decl_field (type, dimsfield, "type",
9370                                      integer_type_node);
9371
9372       TYPE_FIELDS (type) = namefield;
9373       layout_type (type);
9374
9375       ggc_add_tree_root (&type, 1);
9376     }
9377
9378   return type;
9379 }
9380
9381 #endif
9382
9383 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9384 static tree
9385 ffecom_vardesc_ (ffebld expr)
9386 {
9387   ffesymbol s;
9388
9389   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9390   s = ffebld_symter (expr);
9391
9392   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9393     {
9394       int i;
9395       tree vardesctype = ffecom_type_vardesc_ ();
9396       tree var;
9397       tree nameinit;
9398       tree dimsinit;
9399       tree addrinit;
9400       tree typeinit;
9401       tree field;
9402       tree varinits;
9403       static int mynumber = 0;
9404
9405       var = build_decl (VAR_DECL,
9406                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9407                                                         mynumber++),
9408                         vardesctype);
9409       TREE_STATIC (var) = 1;
9410       DECL_INITIAL (var) = error_mark_node;
9411
9412       var = start_decl (var, FALSE);
9413
9414       /* Process inits.  */
9415
9416       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9417                                            + 1,
9418                                            ffesymbol_text (s));
9419       TREE_TYPE (nameinit)
9420         = build_type_variant
9421         (build_array_type
9422          (char_type_node,
9423           build_range_type (integer_type_node,
9424                             integer_one_node,
9425                             build_int_2 (i, 0))),
9426          1, 0);
9427       TREE_CONSTANT (nameinit) = 1;
9428       TREE_STATIC (nameinit) = 1;
9429       nameinit = ffecom_1 (ADDR_EXPR,
9430                            build_pointer_type (TREE_TYPE (nameinit)),
9431                            nameinit);
9432
9433       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9434
9435       dimsinit = ffecom_vardesc_dims_ (s);
9436
9437       if (typeinit == NULL_TREE)
9438         {
9439           ffeinfoBasictype bt = ffesymbol_basictype (s);
9440           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9441           int tc = ffecom_f2c_typecode (bt, kt);
9442
9443           assert (tc != -1);
9444           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9445         }
9446       else
9447         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9448
9449       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9450                                   nameinit);
9451       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9452                                                addrinit);
9453       TREE_CHAIN (TREE_CHAIN (varinits))
9454         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9455       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9456         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9457
9458       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9459       TREE_CONSTANT (varinits) = 1;
9460       TREE_STATIC (varinits) = 1;
9461
9462       finish_decl (var, varinits, FALSE);
9463
9464       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9465
9466       ffesymbol_hook (s).vardesc_tree = var;
9467     }
9468
9469   return ffesymbol_hook (s).vardesc_tree;
9470 }
9471
9472 #endif
9473 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9474 static tree
9475 ffecom_vardesc_array_ (ffesymbol s)
9476 {
9477   ffebld b;
9478   tree list;
9479   tree item = NULL_TREE;
9480   tree var;
9481   int i;
9482   static int mynumber = 0;
9483
9484   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9485        b != NULL;
9486        b = ffebld_trail (b), ++i)
9487     {
9488       tree t;
9489
9490       t = ffecom_vardesc_ (ffebld_head (b));
9491
9492       if (list == NULL_TREE)
9493         list = item = build_tree_list (NULL_TREE, t);
9494       else
9495         {
9496           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9497           item = TREE_CHAIN (item);
9498         }
9499     }
9500
9501   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9502                            build_range_type (integer_type_node,
9503                                              integer_one_node,
9504                                              build_int_2 (i, 0)));
9505   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9506   TREE_CONSTANT (list) = 1;
9507   TREE_STATIC (list) = 1;
9508
9509   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9510   var = build_decl (VAR_DECL, var, item);
9511   TREE_STATIC (var) = 1;
9512   DECL_INITIAL (var) = error_mark_node;
9513   var = start_decl (var, FALSE);
9514   finish_decl (var, list, FALSE);
9515
9516   return var;
9517 }
9518
9519 #endif
9520 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9521 static tree
9522 ffecom_vardesc_dims_ (ffesymbol s)
9523 {
9524   if (ffesymbol_dims (s) == NULL)
9525     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9526                     integer_zero_node);
9527
9528   {
9529     ffebld b;
9530     ffebld e;
9531     tree list;
9532     tree backlist;
9533     tree item = NULL_TREE;
9534     tree var;
9535     tree numdim;
9536     tree numelem;
9537     tree baseoff = NULL_TREE;
9538     static int mynumber = 0;
9539
9540     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9541     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9542
9543     numelem = ffecom_expr (ffesymbol_arraysize (s));
9544     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9545
9546     list = NULL_TREE;
9547     backlist = NULL_TREE;
9548     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9549          b != NULL;
9550          b = ffebld_trail (b), e = ffebld_trail (e))
9551       {
9552         tree t;
9553         tree low;
9554         tree back;
9555
9556         if (ffebld_trail (b) == NULL)
9557           t = NULL_TREE;
9558         else
9559           {
9560             t = convert (ffecom_f2c_ftnlen_type_node,
9561                          ffecom_expr (ffebld_head (e)));
9562
9563             if (list == NULL_TREE)
9564               list = item = build_tree_list (NULL_TREE, t);
9565             else
9566               {
9567                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9568                 item = TREE_CHAIN (item);
9569               }
9570           }
9571
9572         if (ffebld_left (ffebld_head (b)) == NULL)
9573           low = ffecom_integer_one_node;
9574         else
9575           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9576         low = convert (ffecom_f2c_ftnlen_type_node, low);
9577
9578         back = build_tree_list (low, t);
9579         TREE_CHAIN (back) = backlist;
9580         backlist = back;
9581       }
9582
9583     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9584       {
9585         if (TREE_VALUE (item) == NULL_TREE)
9586           baseoff = TREE_PURPOSE (item);
9587         else
9588           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9589                               TREE_PURPOSE (item),
9590                               ffecom_2 (MULT_EXPR,
9591                                         ffecom_f2c_ftnlen_type_node,
9592                                         TREE_VALUE (item),
9593                                         baseoff));
9594       }
9595
9596     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9597
9598     baseoff = build_tree_list (NULL_TREE, baseoff);
9599     TREE_CHAIN (baseoff) = list;
9600
9601     numelem = build_tree_list (NULL_TREE, numelem);
9602     TREE_CHAIN (numelem) = baseoff;
9603
9604     numdim = build_tree_list (NULL_TREE, numdim);
9605     TREE_CHAIN (numdim) = numelem;
9606
9607     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9608                              build_range_type (integer_type_node,
9609                                                integer_zero_node,
9610                                                build_int_2
9611                                                ((int) ffesymbol_rank (s)
9612                                                 + 2, 0)));
9613     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9614     TREE_CONSTANT (list) = 1;
9615     TREE_STATIC (list) = 1;
9616
9617     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9618     var = build_decl (VAR_DECL, var, item);
9619     TREE_STATIC (var) = 1;
9620     DECL_INITIAL (var) = error_mark_node;
9621     var = start_decl (var, FALSE);
9622     finish_decl (var, list, FALSE);
9623
9624     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9625
9626     return var;
9627   }
9628 }
9629
9630 #endif
9631 /* Essentially does a "fold (build1 (code, type, node))" while checking
9632    for certain housekeeping things.
9633
9634    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9635    ffecom_1_fn instead.  */
9636
9637 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9638 tree
9639 ffecom_1 (enum tree_code code, tree type, tree node)
9640 {
9641   tree item;
9642
9643   if ((node == error_mark_node)
9644       || (type == error_mark_node))
9645     return error_mark_node;
9646
9647   if (code == ADDR_EXPR)
9648     {
9649       if (!mark_addressable (node))
9650         assert ("can't mark_addressable this node!" == NULL);
9651     }
9652
9653   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9654     {
9655       tree realtype;
9656
9657     case REALPART_EXPR:
9658       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9659       break;
9660
9661     case IMAGPART_EXPR:
9662       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9663       break;
9664
9665
9666     case NEGATE_EXPR:
9667       if (TREE_CODE (type) != RECORD_TYPE)
9668         {
9669           item = build1 (code, type, node);
9670           break;
9671         }
9672       node = ffecom_stabilize_aggregate_ (node);
9673       realtype = TREE_TYPE (TYPE_FIELDS (type));
9674       item =
9675         ffecom_2 (COMPLEX_EXPR, type,
9676                   ffecom_1 (NEGATE_EXPR, realtype,
9677                             ffecom_1 (REALPART_EXPR, realtype,
9678                                       node)),
9679                   ffecom_1 (NEGATE_EXPR, realtype,
9680                             ffecom_1 (IMAGPART_EXPR, realtype,
9681                                       node)));
9682       break;
9683
9684     default:
9685       item = build1 (code, type, node);
9686       break;
9687     }
9688
9689   if (TREE_SIDE_EFFECTS (node))
9690     TREE_SIDE_EFFECTS (item) = 1;
9691   if ((code == ADDR_EXPR) && staticp (node))
9692     TREE_CONSTANT (item) = 1;
9693   return fold (item);
9694 }
9695 #endif
9696
9697 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9698    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9699    does not set TREE_ADDRESSABLE (because calling an inline
9700    function does not mean the function needs to be separately
9701    compiled).  */
9702
9703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9704 tree
9705 ffecom_1_fn (tree node)
9706 {
9707   tree item;
9708   tree type;
9709
9710   if (node == error_mark_node)
9711     return error_mark_node;
9712
9713   type = build_type_variant (TREE_TYPE (node),
9714                              TREE_READONLY (node),
9715                              TREE_THIS_VOLATILE (node));
9716   item = build1 (ADDR_EXPR,
9717                  build_pointer_type (type), node);
9718   if (TREE_SIDE_EFFECTS (node))
9719     TREE_SIDE_EFFECTS (item) = 1;
9720   if (staticp (node))
9721     TREE_CONSTANT (item) = 1;
9722   return fold (item);
9723 }
9724 #endif
9725
9726 /* Essentially does a "fold (build (code, type, node1, node2))" while
9727    checking for certain housekeeping things.  */
9728
9729 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9730 tree
9731 ffecom_2 (enum tree_code code, tree type, tree node1,
9732           tree node2)
9733 {
9734   tree item;
9735
9736   if ((node1 == error_mark_node)
9737       || (node2 == error_mark_node)
9738       || (type == error_mark_node))
9739     return error_mark_node;
9740
9741   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9742     {
9743       tree a, b, c, d, realtype;
9744
9745     case CONJ_EXPR:
9746       assert ("no CONJ_EXPR support yet" == NULL);
9747       return error_mark_node;
9748
9749     case COMPLEX_EXPR:
9750       item = build_tree_list (TYPE_FIELDS (type), node1);
9751       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9752       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9753       break;
9754
9755     case PLUS_EXPR:
9756       if (TREE_CODE (type) != RECORD_TYPE)
9757         {
9758           item = build (code, type, node1, node2);
9759           break;
9760         }
9761       node1 = ffecom_stabilize_aggregate_ (node1);
9762       node2 = ffecom_stabilize_aggregate_ (node2);
9763       realtype = TREE_TYPE (TYPE_FIELDS (type));
9764       item =
9765         ffecom_2 (COMPLEX_EXPR, type,
9766                   ffecom_2 (PLUS_EXPR, realtype,
9767                             ffecom_1 (REALPART_EXPR, realtype,
9768                                       node1),
9769                             ffecom_1 (REALPART_EXPR, realtype,
9770                                       node2)),
9771                   ffecom_2 (PLUS_EXPR, realtype,
9772                             ffecom_1 (IMAGPART_EXPR, realtype,
9773                                       node1),
9774                             ffecom_1 (IMAGPART_EXPR, realtype,
9775                                       node2)));
9776       break;
9777
9778     case MINUS_EXPR:
9779       if (TREE_CODE (type) != RECORD_TYPE)
9780         {
9781           item = build (code, type, node1, node2);
9782           break;
9783         }
9784       node1 = ffecom_stabilize_aggregate_ (node1);
9785       node2 = ffecom_stabilize_aggregate_ (node2);
9786       realtype = TREE_TYPE (TYPE_FIELDS (type));
9787       item =
9788         ffecom_2 (COMPLEX_EXPR, type,
9789                   ffecom_2 (MINUS_EXPR, realtype,
9790                             ffecom_1 (REALPART_EXPR, realtype,
9791                                       node1),
9792                             ffecom_1 (REALPART_EXPR, realtype,
9793                                       node2)),
9794                   ffecom_2 (MINUS_EXPR, realtype,
9795                             ffecom_1 (IMAGPART_EXPR, realtype,
9796                                       node1),
9797                             ffecom_1 (IMAGPART_EXPR, realtype,
9798                                       node2)));
9799       break;
9800
9801     case MULT_EXPR:
9802       if (TREE_CODE (type) != RECORD_TYPE)
9803         {
9804           item = build (code, type, node1, node2);
9805           break;
9806         }
9807       node1 = ffecom_stabilize_aggregate_ (node1);
9808       node2 = ffecom_stabilize_aggregate_ (node2);
9809       realtype = TREE_TYPE (TYPE_FIELDS (type));
9810       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9811                                node1));
9812       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9813                                node1));
9814       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9815                                node2));
9816       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9817                                node2));
9818       item =
9819         ffecom_2 (COMPLEX_EXPR, type,
9820                   ffecom_2 (MINUS_EXPR, realtype,
9821                             ffecom_2 (MULT_EXPR, realtype,
9822                                       a,
9823                                       c),
9824                             ffecom_2 (MULT_EXPR, realtype,
9825                                       b,
9826                                       d)),
9827                   ffecom_2 (PLUS_EXPR, realtype,
9828                             ffecom_2 (MULT_EXPR, realtype,
9829                                       a,
9830                                       d),
9831                             ffecom_2 (MULT_EXPR, realtype,
9832                                       c,
9833                                       b)));
9834       break;
9835
9836     case EQ_EXPR:
9837       if ((TREE_CODE (node1) != RECORD_TYPE)
9838           && (TREE_CODE (node2) != RECORD_TYPE))
9839         {
9840           item = build (code, type, node1, node2);
9841           break;
9842         }
9843       assert (TREE_CODE (node1) == RECORD_TYPE);
9844       assert (TREE_CODE (node2) == RECORD_TYPE);
9845       node1 = ffecom_stabilize_aggregate_ (node1);
9846       node2 = ffecom_stabilize_aggregate_ (node2);
9847       realtype = TREE_TYPE (TYPE_FIELDS (type));
9848       item =
9849         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9850                   ffecom_2 (code, type,
9851                             ffecom_1 (REALPART_EXPR, realtype,
9852                                       node1),
9853                             ffecom_1 (REALPART_EXPR, realtype,
9854                                       node2)),
9855                   ffecom_2 (code, type,
9856                             ffecom_1 (IMAGPART_EXPR, realtype,
9857                                       node1),
9858                             ffecom_1 (IMAGPART_EXPR, realtype,
9859                                       node2)));
9860       break;
9861
9862     case NE_EXPR:
9863       if ((TREE_CODE (node1) != RECORD_TYPE)
9864           && (TREE_CODE (node2) != RECORD_TYPE))
9865         {
9866           item = build (code, type, node1, node2);
9867           break;
9868         }
9869       assert (TREE_CODE (node1) == RECORD_TYPE);
9870       assert (TREE_CODE (node2) == RECORD_TYPE);
9871       node1 = ffecom_stabilize_aggregate_ (node1);
9872       node2 = ffecom_stabilize_aggregate_ (node2);
9873       realtype = TREE_TYPE (TYPE_FIELDS (type));
9874       item =
9875         ffecom_2 (TRUTH_ORIF_EXPR, type,
9876                   ffecom_2 (code, type,
9877                             ffecom_1 (REALPART_EXPR, realtype,
9878                                       node1),
9879                             ffecom_1 (REALPART_EXPR, realtype,
9880                                       node2)),
9881                   ffecom_2 (code, type,
9882                             ffecom_1 (IMAGPART_EXPR, realtype,
9883                                       node1),
9884                             ffecom_1 (IMAGPART_EXPR, realtype,
9885                                       node2)));
9886       break;
9887
9888     default:
9889       item = build (code, type, node1, node2);
9890       break;
9891     }
9892
9893   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9894     TREE_SIDE_EFFECTS (item) = 1;
9895   return fold (item);
9896 }
9897
9898 #endif
9899 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9900
9901    ffesymbol s;  // the ENTRY point itself
9902    if (ffecom_2pass_advise_entrypoint(s))
9903        // the ENTRY point has been accepted
9904
9905    Does whatever compiler needs to do when it learns about the entrypoint,
9906    like determine the return type of the master function, count the
9907    number of entrypoints, etc.  Returns FALSE if the return type is
9908    not compatible with the return type(s) of other entrypoint(s).
9909
9910    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9911    later (after _finish_progunit) be called with the same entrypoint(s)
9912    as passed to this fn for which TRUE was returned.
9913
9914    03-Jan-92  JCB  2.0
9915       Return FALSE if the return type conflicts with previous entrypoints.  */
9916
9917 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9918 bool
9919 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9920 {
9921   ffebld list;                  /* opITEM. */
9922   ffebld mlist;                 /* opITEM. */
9923   ffebld plist;                 /* opITEM. */
9924   ffebld arg;                   /* ffebld_head(opITEM). */
9925   ffebld item;                  /* opITEM. */
9926   ffesymbol s;                  /* ffebld_symter(arg). */
9927   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9928   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9929   ffetargetCharacterSize size = ffesymbol_size (entry);
9930   bool ok;
9931
9932   if (ffecom_num_entrypoints_ == 0)
9933     {                           /* First entrypoint, make list of main
9934                                    arglist's dummies. */
9935       assert (ffecom_primary_entry_ != NULL);
9936
9937       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9938       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9939       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9940
9941       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9942            list != NULL;
9943            list = ffebld_trail (list))
9944         {
9945           arg = ffebld_head (list);
9946           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9947             continue;           /* Alternate return or some such thing. */
9948           item = ffebld_new_item (arg, NULL);
9949           if (plist == NULL)
9950             ffecom_master_arglist_ = item;
9951           else
9952             ffebld_set_trail (plist, item);
9953           plist = item;
9954         }
9955     }
9956
9957   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9958      apparently redundantly (it's done below to UNIONize the arglists) so
9959      that we don't complain about RETURN 1 if an offending ENTRY is the only
9960      one with an alternate return.  */
9961
9962   if (!ffecom_is_altreturning_)
9963     {
9964       for (list = ffesymbol_dummyargs (entry);
9965            list != NULL;
9966            list = ffebld_trail (list))
9967         {
9968           arg = ffebld_head (list);
9969           if (ffebld_op (arg) == FFEBLD_opSTAR)
9970             {
9971               ffecom_is_altreturning_ = TRUE;
9972               break;
9973             }
9974         }
9975     }
9976
9977   /* Now check type compatibility. */
9978
9979   switch (ffecom_master_bt_)
9980     {
9981     case FFEINFO_basictypeNONE:
9982       ok = (bt != FFEINFO_basictypeCHARACTER);
9983       break;
9984
9985     case FFEINFO_basictypeCHARACTER:
9986       ok
9987         = (bt == FFEINFO_basictypeCHARACTER)
9988         && (kt == ffecom_master_kt_)
9989         && (size == ffecom_master_size_);
9990       break;
9991
9992     case FFEINFO_basictypeANY:
9993       return FALSE;             /* Just don't bother. */
9994
9995     default:
9996       if (bt == FFEINFO_basictypeCHARACTER)
9997         {
9998           ok = FALSE;
9999           break;
10000         }
10001       ok = TRUE;
10002       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10003         {
10004           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10005           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10006         }
10007       break;
10008     }
10009
10010   if (!ok)
10011     {
10012       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10013       ffest_ffebad_here_current_stmt (0);
10014       ffebad_finish ();
10015       return FALSE;             /* Can't handle entrypoint. */
10016     }
10017
10018   /* Entrypoint type compatible with previous types. */
10019
10020   ++ffecom_num_entrypoints_;
10021
10022   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10023
10024   for (list = ffesymbol_dummyargs (entry);
10025        list != NULL;
10026        list = ffebld_trail (list))
10027     {
10028       arg = ffebld_head (list);
10029       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10030         continue;               /* Alternate return or some such thing. */
10031       s = ffebld_symter (arg);
10032       for (plist = NULL, mlist = ffecom_master_arglist_;
10033            mlist != NULL;
10034            plist = mlist, mlist = ffebld_trail (mlist))
10035         {                       /* plist points to previous item for easy
10036                                    appending of arg. */
10037           if (ffebld_symter (ffebld_head (mlist)) == s)
10038             break;              /* Already have this arg in the master list. */
10039         }
10040       if (mlist != NULL)
10041         continue;               /* Already have this arg in the master list. */
10042
10043       /* Append this arg to the master list. */
10044
10045       item = ffebld_new_item (arg, NULL);
10046       if (plist == NULL)
10047         ffecom_master_arglist_ = item;
10048       else
10049         ffebld_set_trail (plist, item);
10050     }
10051
10052   return TRUE;
10053 }
10054
10055 #endif
10056 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10057
10058    ffesymbol s;  // the ENTRY point itself
10059    ffecom_2pass_do_entrypoint(s);
10060
10061    Does whatever compiler needs to do to make the entrypoint actually
10062    happen.  Must be called for each entrypoint after
10063    ffecom_finish_progunit is called.  */
10064
10065 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10066 void
10067 ffecom_2pass_do_entrypoint (ffesymbol entry)
10068 {
10069   static int mfn_num = 0;
10070   static int ent_num;
10071
10072   if (mfn_num != ffecom_num_fns_)
10073     {                           /* First entrypoint for this program unit. */
10074       ent_num = 1;
10075       mfn_num = ffecom_num_fns_;
10076       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10077     }
10078   else
10079     ++ent_num;
10080
10081   --ffecom_num_entrypoints_;
10082
10083   ffecom_do_entry_ (entry, ent_num);
10084 }
10085
10086 #endif
10087
10088 /* Essentially does a "fold (build (code, type, node1, node2))" while
10089    checking for certain housekeeping things.  Always sets
10090    TREE_SIDE_EFFECTS.  */
10091
10092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10093 tree
10094 ffecom_2s (enum tree_code code, tree type, tree node1,
10095            tree node2)
10096 {
10097   tree item;
10098
10099   if ((node1 == error_mark_node)
10100       || (node2 == error_mark_node)
10101       || (type == error_mark_node))
10102     return error_mark_node;
10103
10104   item = build (code, type, node1, node2);
10105   TREE_SIDE_EFFECTS (item) = 1;
10106   return fold (item);
10107 }
10108
10109 #endif
10110 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10111    checking for certain housekeeping things.  */
10112
10113 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10114 tree
10115 ffecom_3 (enum tree_code code, tree type, tree node1,
10116           tree node2, tree node3)
10117 {
10118   tree item;
10119
10120   if ((node1 == error_mark_node)
10121       || (node2 == error_mark_node)
10122       || (node3 == error_mark_node)
10123       || (type == error_mark_node))
10124     return error_mark_node;
10125
10126   item = build (code, type, node1, node2, node3);
10127   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10128       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10129     TREE_SIDE_EFFECTS (item) = 1;
10130   return fold (item);
10131 }
10132
10133 #endif
10134 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10135    checking for certain housekeeping things.  Always sets
10136    TREE_SIDE_EFFECTS.  */
10137
10138 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10139 tree
10140 ffecom_3s (enum tree_code code, tree type, tree node1,
10141            tree node2, tree node3)
10142 {
10143   tree item;
10144
10145   if ((node1 == error_mark_node)
10146       || (node2 == error_mark_node)
10147       || (node3 == error_mark_node)
10148       || (type == error_mark_node))
10149     return error_mark_node;
10150
10151   item = build (code, type, node1, node2, node3);
10152   TREE_SIDE_EFFECTS (item) = 1;
10153   return fold (item);
10154 }
10155
10156 #endif
10157
10158 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10159
10160    See use by ffecom_list_expr.
10161
10162    If expression is NULL, returns an integer zero tree.  If it is not
10163    a CHARACTER expression, returns whatever ffecom_expr
10164    returns and sets the length return value to NULL_TREE.  Otherwise
10165    generates code to evaluate the character expression, returns the proper
10166    pointer to the result, but does NOT set the length return value to a tree
10167    that specifies the length of the result.  (In other words, the length
10168    variable is always set to NULL_TREE, because a length is never passed.)
10169
10170    21-Dec-91  JCB  1.1
10171       Don't set returned length, since nobody needs it (yet; someday if
10172       we allow CHARACTER*(*) dummies to statement functions, we'll need
10173       it).  */
10174
10175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10176 tree
10177 ffecom_arg_expr (ffebld expr, tree *length)
10178 {
10179   tree ign;
10180
10181   *length = NULL_TREE;
10182
10183   if (expr == NULL)
10184     return integer_zero_node;
10185
10186   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10187     return ffecom_expr (expr);
10188
10189   return ffecom_arg_ptr_to_expr (expr, &ign);
10190 }
10191
10192 #endif
10193 /* Transform expression into constant argument-pointer-to-expression tree.
10194
10195    If the expression can be transformed into a argument-pointer-to-expression
10196    tree that is constant, that is done, and the tree returned.  Else
10197    NULL_TREE is returned.
10198
10199    That way, a caller can attempt to provide compile-time initialization
10200    of a variable and, if that fails, *then* choose to start a new block
10201    and resort to using temporaries, as appropriate.  */
10202
10203 tree
10204 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10205 {
10206   if (! expr)
10207     return integer_zero_node;
10208
10209   if (ffebld_op (expr) == FFEBLD_opANY)
10210     {
10211       if (length)
10212         *length = error_mark_node;
10213       return error_mark_node;
10214     }
10215
10216   if (ffebld_arity (expr) == 0
10217       && (ffebld_op (expr) != FFEBLD_opSYMTER
10218           || ffebld_where (expr) == FFEINFO_whereCOMMON
10219           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10220           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10221     {
10222       tree t;
10223
10224       t = ffecom_arg_ptr_to_expr (expr, length);
10225       assert (TREE_CONSTANT (t));
10226       assert (! length || TREE_CONSTANT (*length));
10227       return t;
10228     }
10229
10230   if (length
10231       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10232     *length = build_int_2 (ffebld_size (expr), 0);
10233   else if (length)
10234     *length = NULL_TREE;
10235   return NULL_TREE;
10236 }
10237
10238 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10239
10240    See use by ffecom_list_ptr_to_expr.
10241
10242    If expression is NULL, returns an integer zero tree.  If it is not
10243    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10244    returns and sets the length return value to NULL_TREE.  Otherwise
10245    generates code to evaluate the character expression, returns the proper
10246    pointer to the result, AND sets the length return value to a tree that
10247    specifies the length of the result.
10248
10249    If the length argument is NULL, this is a slightly special
10250    case of building a FORMAT expression, that is, an expression that
10251    will be used at run time without regard to length.  For the current
10252    implementation, which uses the libf2c library, this means it is nice
10253    to append a null byte to the end of the expression, where feasible,
10254    to make sure any diagnostic about the FORMAT string terminates at
10255    some useful point.
10256
10257    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10258    length argument.  This might even be seen as a feature, if a null
10259    byte can always be appended.  */
10260
10261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10262 tree
10263 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10264 {
10265   tree item;
10266   tree ign_length;
10267   ffecomConcatList_ catlist;
10268
10269   if (length != NULL)
10270     *length = NULL_TREE;
10271
10272   if (expr == NULL)
10273     return integer_zero_node;
10274
10275   switch (ffebld_op (expr))
10276     {
10277     case FFEBLD_opPERCENT_VAL:
10278       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10279         return ffecom_expr (ffebld_left (expr));
10280       {
10281         tree temp_exp;
10282         tree temp_length;
10283
10284         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10285         if (temp_exp == error_mark_node)
10286           return error_mark_node;
10287
10288         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10289                          temp_exp);
10290       }
10291
10292     case FFEBLD_opPERCENT_REF:
10293       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10294         return ffecom_ptr_to_expr (ffebld_left (expr));
10295       if (length != NULL)
10296         {
10297           ign_length = NULL_TREE;
10298           length = &ign_length;
10299         }
10300       expr = ffebld_left (expr);
10301       break;
10302
10303     case FFEBLD_opPERCENT_DESCR:
10304       switch (ffeinfo_basictype (ffebld_info (expr)))
10305         {
10306 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10307         case FFEINFO_basictypeHOLLERITH:
10308 #endif
10309         case FFEINFO_basictypeCHARACTER:
10310           break;                /* Passed by descriptor anyway. */
10311
10312         default:
10313           item = ffecom_ptr_to_expr (expr);
10314           if (item != error_mark_node)
10315             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10316           break;
10317         }
10318       break;
10319
10320     default:
10321       break;
10322     }
10323
10324 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10325   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10326       && (length != NULL))
10327     {                           /* Pass Hollerith by descriptor. */
10328       ffetargetHollerith h;
10329
10330       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10331       h = ffebld_cu_val_hollerith (ffebld_constant_union
10332                                    (ffebld_conter (expr)));
10333       *length
10334         = build_int_2 (h.length, 0);
10335       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10336     }
10337 #endif
10338
10339   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10340     return ffecom_ptr_to_expr (expr);
10341
10342   assert (ffeinfo_kindtype (ffebld_info (expr))
10343           == FFEINFO_kindtypeCHARACTER1);
10344
10345   while (ffebld_op (expr) == FFEBLD_opPAREN)
10346     expr = ffebld_left (expr);
10347
10348   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10349   switch (ffecom_concat_list_count_ (catlist))
10350     {
10351     case 0:                     /* Shouldn't happen, but in case it does... */
10352       if (length != NULL)
10353         {
10354           *length = ffecom_f2c_ftnlen_zero_node;
10355           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10356         }
10357       ffecom_concat_list_kill_ (catlist);
10358       return null_pointer_node;
10359
10360     case 1:                     /* The (fairly) easy case. */
10361       if (length == NULL)
10362         ffecom_char_args_with_null_ (&item, &ign_length,
10363                                      ffecom_concat_list_expr_ (catlist, 0));
10364       else
10365         ffecom_char_args_ (&item, length,
10366                            ffecom_concat_list_expr_ (catlist, 0));
10367       ffecom_concat_list_kill_ (catlist);
10368       assert (item != NULL_TREE);
10369       return item;
10370
10371     default:                    /* Must actually concatenate things. */
10372       break;
10373     }
10374
10375   {
10376     int count = ffecom_concat_list_count_ (catlist);
10377     int i;
10378     tree lengths;
10379     tree items;
10380     tree length_array;
10381     tree item_array;
10382     tree citem;
10383     tree clength;
10384     tree temporary;
10385     tree num;
10386     tree known_length;
10387     ffetargetCharacterSize sz;
10388
10389     sz = ffecom_concat_list_maxlen_ (catlist);
10390     /* ~~Kludge! */
10391     assert (sz != FFETARGET_charactersizeNONE);
10392
10393 #ifdef HOHO
10394     length_array
10395       = lengths
10396       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10397                              FFETARGET_charactersizeNONE, count, TRUE);
10398     item_array
10399       = items
10400       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10401                              FFETARGET_charactersizeNONE, count, TRUE);
10402     temporary = ffecom_push_tempvar (char_type_node,
10403                                      sz, -1, TRUE);
10404 #else
10405     {
10406       tree hook;
10407
10408       hook = ffebld_nonter_hook (expr);
10409       assert (hook);
10410       assert (TREE_CODE (hook) == TREE_VEC);
10411       assert (TREE_VEC_LENGTH (hook) == 3);
10412       length_array = lengths = TREE_VEC_ELT (hook, 0);
10413       item_array = items = TREE_VEC_ELT (hook, 1);
10414       temporary = TREE_VEC_ELT (hook, 2);
10415     }
10416 #endif
10417
10418     known_length = ffecom_f2c_ftnlen_zero_node;
10419
10420     for (i = 0; i < count; ++i)
10421       {
10422         if ((i == count)
10423             && (length == NULL))
10424           ffecom_char_args_with_null_ (&citem, &clength,
10425                                        ffecom_concat_list_expr_ (catlist, i));
10426         else
10427           ffecom_char_args_ (&citem, &clength,
10428                              ffecom_concat_list_expr_ (catlist, i));
10429         if ((citem == error_mark_node)
10430             || (clength == error_mark_node))
10431           {
10432             ffecom_concat_list_kill_ (catlist);
10433             *length = error_mark_node;
10434             return error_mark_node;
10435           }
10436
10437         items
10438           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10439                       ffecom_modify (void_type_node,
10440                                      ffecom_2 (ARRAY_REF,
10441                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10442                                                item_array,
10443                                                build_int_2 (i, 0)),
10444                                      citem),
10445                       items);
10446         clength = ffecom_save_tree (clength);
10447         if (length != NULL)
10448           known_length
10449             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10450                         known_length,
10451                         clength);
10452         lengths
10453           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10454                       ffecom_modify (void_type_node,
10455                                      ffecom_2 (ARRAY_REF,
10456                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10457                                                length_array,
10458                                                build_int_2 (i, 0)),
10459                                      clength),
10460                       lengths);
10461       }
10462
10463     temporary = ffecom_1 (ADDR_EXPR,
10464                           build_pointer_type (TREE_TYPE (temporary)),
10465                           temporary);
10466
10467     item = build_tree_list (NULL_TREE, temporary);
10468     TREE_CHAIN (item)
10469       = build_tree_list (NULL_TREE,
10470                          ffecom_1 (ADDR_EXPR,
10471                                    build_pointer_type (TREE_TYPE (items)),
10472                                    items));
10473     TREE_CHAIN (TREE_CHAIN (item))
10474       = build_tree_list (NULL_TREE,
10475                          ffecom_1 (ADDR_EXPR,
10476                                    build_pointer_type (TREE_TYPE (lengths)),
10477                                    lengths));
10478     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10479       = build_tree_list
10480         (NULL_TREE,
10481          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10482                    convert (ffecom_f2c_ftnlen_type_node,
10483                             build_int_2 (count, 0))));
10484     num = build_int_2 (sz, 0);
10485     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10486     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10487       = build_tree_list (NULL_TREE, num);
10488
10489     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10490     TREE_SIDE_EFFECTS (item) = 1;
10491     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10492                      item,
10493                      temporary);
10494
10495     if (length != NULL)
10496       *length = known_length;
10497   }
10498
10499   ffecom_concat_list_kill_ (catlist);
10500   assert (item != NULL_TREE);
10501   return item;
10502 }
10503
10504 #endif
10505 /* Generate call to run-time function.
10506
10507    The first arg is the GNU Fortran Run-Time function index, the second
10508    arg is the list of arguments to pass to it.  Returned is the expression
10509    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10510    result (which may be void).  */
10511
10512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10513 tree
10514 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10515 {
10516   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10517                        ffecom_gfrt_kindtype (ix),
10518                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10519                        NULL_TREE, args, NULL_TREE, NULL,
10520                        NULL, NULL_TREE, TRUE, hook);
10521 }
10522 #endif
10523
10524 /* Transform constant-union to tree.  */
10525
10526 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10527 tree
10528 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10529                       ffeinfoKindtype kt, tree tree_type)
10530 {
10531   tree item;
10532
10533   switch (bt)
10534     {
10535     case FFEINFO_basictypeINTEGER:
10536       {
10537         int val;
10538
10539         switch (kt)
10540           {
10541 #if FFETARGET_okINTEGER1
10542           case FFEINFO_kindtypeINTEGER1:
10543             val = ffebld_cu_val_integer1 (*cu);
10544             break;
10545 #endif
10546
10547 #if FFETARGET_okINTEGER2
10548           case FFEINFO_kindtypeINTEGER2:
10549             val = ffebld_cu_val_integer2 (*cu);
10550             break;
10551 #endif
10552
10553 #if FFETARGET_okINTEGER3
10554           case FFEINFO_kindtypeINTEGER3:
10555             val = ffebld_cu_val_integer3 (*cu);
10556             break;
10557 #endif
10558
10559 #if FFETARGET_okINTEGER4
10560           case FFEINFO_kindtypeINTEGER4:
10561             val = ffebld_cu_val_integer4 (*cu);
10562             break;
10563 #endif
10564
10565           default:
10566             assert ("bad INTEGER constant kind type" == NULL);
10567             /* Fall through. */
10568           case FFEINFO_kindtypeANY:
10569             return error_mark_node;
10570           }
10571         item = build_int_2 (val, (val < 0) ? -1 : 0);
10572         TREE_TYPE (item) = tree_type;
10573       }
10574       break;
10575
10576     case FFEINFO_basictypeLOGICAL:
10577       {
10578         int val;
10579
10580         switch (kt)
10581           {
10582 #if FFETARGET_okLOGICAL1
10583           case FFEINFO_kindtypeLOGICAL1:
10584             val = ffebld_cu_val_logical1 (*cu);
10585             break;
10586 #endif
10587
10588 #if FFETARGET_okLOGICAL2
10589           case FFEINFO_kindtypeLOGICAL2:
10590             val = ffebld_cu_val_logical2 (*cu);
10591             break;
10592 #endif
10593
10594 #if FFETARGET_okLOGICAL3
10595           case FFEINFO_kindtypeLOGICAL3:
10596             val = ffebld_cu_val_logical3 (*cu);
10597             break;
10598 #endif
10599
10600 #if FFETARGET_okLOGICAL4
10601           case FFEINFO_kindtypeLOGICAL4:
10602             val = ffebld_cu_val_logical4 (*cu);
10603             break;
10604 #endif
10605
10606           default:
10607             assert ("bad LOGICAL constant kind type" == NULL);
10608             /* Fall through. */
10609           case FFEINFO_kindtypeANY:
10610             return error_mark_node;
10611           }
10612         item = build_int_2 (val, (val < 0) ? -1 : 0);
10613         TREE_TYPE (item) = tree_type;
10614       }
10615       break;
10616
10617     case FFEINFO_basictypeREAL:
10618       {
10619         REAL_VALUE_TYPE val;
10620
10621         switch (kt)
10622           {
10623 #if FFETARGET_okREAL1
10624           case FFEINFO_kindtypeREAL1:
10625             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10626             break;
10627 #endif
10628
10629 #if FFETARGET_okREAL2
10630           case FFEINFO_kindtypeREAL2:
10631             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10632             break;
10633 #endif
10634
10635 #if FFETARGET_okREAL3
10636           case FFEINFO_kindtypeREAL3:
10637             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10638             break;
10639 #endif
10640
10641 #if FFETARGET_okREAL4
10642           case FFEINFO_kindtypeREAL4:
10643             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10644             break;
10645 #endif
10646
10647           default:
10648             assert ("bad REAL constant kind type" == NULL);
10649             /* Fall through. */
10650           case FFEINFO_kindtypeANY:
10651             return error_mark_node;
10652           }
10653         item = build_real (tree_type, val);
10654       }
10655       break;
10656
10657     case FFEINFO_basictypeCOMPLEX:
10658       {
10659         REAL_VALUE_TYPE real;
10660         REAL_VALUE_TYPE imag;
10661         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10662
10663         switch (kt)
10664           {
10665 #if FFETARGET_okCOMPLEX1
10666           case FFEINFO_kindtypeREAL1:
10667             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10668             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10669             break;
10670 #endif
10671
10672 #if FFETARGET_okCOMPLEX2
10673           case FFEINFO_kindtypeREAL2:
10674             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10675             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10676             break;
10677 #endif
10678
10679 #if FFETARGET_okCOMPLEX3
10680           case FFEINFO_kindtypeREAL3:
10681             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10682             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10683             break;
10684 #endif
10685
10686 #if FFETARGET_okCOMPLEX4
10687           case FFEINFO_kindtypeREAL4:
10688             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10689             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10690             break;
10691 #endif
10692
10693           default:
10694             assert ("bad REAL constant kind type" == NULL);
10695             /* Fall through. */
10696           case FFEINFO_kindtypeANY:
10697             return error_mark_node;
10698           }
10699         item = ffecom_build_complex_constant_ (tree_type,
10700                                                build_real (el_type, real),
10701                                                build_real (el_type, imag));
10702       }
10703       break;
10704
10705     case FFEINFO_basictypeCHARACTER:
10706       {                         /* Happens only in DATA and similar contexts. */
10707         ffetargetCharacter1 val;
10708
10709         switch (kt)
10710           {
10711 #if FFETARGET_okCHARACTER1
10712           case FFEINFO_kindtypeLOGICAL1:
10713             val = ffebld_cu_val_character1 (*cu);
10714             break;
10715 #endif
10716
10717           default:
10718             assert ("bad CHARACTER constant kind type" == NULL);
10719             /* Fall through. */
10720           case FFEINFO_kindtypeANY:
10721             return error_mark_node;
10722           }
10723         item = build_string (ffetarget_length_character1 (val),
10724                              ffetarget_text_character1 (val));
10725         TREE_TYPE (item)
10726           = build_type_variant (build_array_type (char_type_node,
10727                                                   build_range_type
10728                                                   (integer_type_node,
10729                                                    integer_one_node,
10730                                                    build_int_2
10731                                                 (ffetarget_length_character1
10732                                                  (val), 0))),
10733                                 1, 0);
10734       }
10735       break;
10736
10737     case FFEINFO_basictypeHOLLERITH:
10738       {
10739         ffetargetHollerith h;
10740
10741         h = ffebld_cu_val_hollerith (*cu);
10742
10743         /* If not at least as wide as default INTEGER, widen it.  */
10744         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10745           item = build_string (h.length, h.text);
10746         else
10747           {
10748             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10749
10750             memcpy (str, h.text, h.length);
10751             memset (&str[h.length], ' ',
10752                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10753                     - h.length);
10754             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10755                                  str);
10756           }
10757         TREE_TYPE (item)
10758           = build_type_variant (build_array_type (char_type_node,
10759                                                   build_range_type
10760                                                   (integer_type_node,
10761                                                    integer_one_node,
10762                                                    build_int_2
10763                                                    (h.length, 0))),
10764                                 1, 0);
10765       }
10766       break;
10767
10768     case FFEINFO_basictypeTYPELESS:
10769       {
10770         ffetargetInteger1 ival;
10771         ffetargetTypeless tless;
10772         ffebad error;
10773
10774         tless = ffebld_cu_val_typeless (*cu);
10775         error = ffetarget_convert_integer1_typeless (&ival, tless);
10776         assert (error == FFEBAD);
10777
10778         item = build_int_2 ((int) ival, 0);
10779       }
10780       break;
10781
10782     default:
10783       assert ("not yet on constant type" == NULL);
10784       /* Fall through. */
10785     case FFEINFO_basictypeANY:
10786       return error_mark_node;
10787     }
10788
10789   TREE_CONSTANT (item) = 1;
10790
10791   return item;
10792 }
10793
10794 #endif
10795
10796 /* Transform expression into constant tree.
10797
10798    If the expression can be transformed into a tree that is constant,
10799    that is done, and the tree returned.  Else NULL_TREE is returned.
10800
10801    That way, a caller can attempt to provide compile-time initialization
10802    of a variable and, if that fails, *then* choose to start a new block
10803    and resort to using temporaries, as appropriate.  */
10804
10805 tree
10806 ffecom_const_expr (ffebld expr)
10807 {
10808   if (! expr)
10809     return integer_zero_node;
10810
10811   if (ffebld_op (expr) == FFEBLD_opANY)
10812     return error_mark_node;
10813
10814   if (ffebld_arity (expr) == 0
10815       && (ffebld_op (expr) != FFEBLD_opSYMTER
10816 #if NEWCOMMON
10817           /* ~~Enable once common/equivalence is handled properly?  */
10818           || ffebld_where (expr) == FFEINFO_whereCOMMON
10819 #endif
10820           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10821           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10822     {
10823       tree t;
10824
10825       t = ffecom_expr (expr);
10826       assert (TREE_CONSTANT (t));
10827       return t;
10828     }
10829
10830   return NULL_TREE;
10831 }
10832
10833 /* Handy way to make a field in a struct/union.  */
10834
10835 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10836 tree
10837 ffecom_decl_field (tree context, tree prevfield,
10838                    const char *name, tree type)
10839 {
10840   tree field;
10841
10842   field = build_decl (FIELD_DECL, get_identifier (name), type);
10843   DECL_CONTEXT (field) = context;
10844   DECL_ALIGN (field) = 0;
10845   DECL_USER_ALIGN (field) = 0;
10846   if (prevfield != NULL_TREE)
10847     TREE_CHAIN (prevfield) = field;
10848
10849   return field;
10850 }
10851
10852 #endif
10853
10854 void
10855 ffecom_close_include (FILE *f)
10856 {
10857 #if FFECOM_GCC_INCLUDE
10858   ffecom_close_include_ (f);
10859 #endif
10860 }
10861
10862 int
10863 ffecom_decode_include_option (char *spec)
10864 {
10865 #if FFECOM_GCC_INCLUDE
10866   return ffecom_decode_include_option_ (spec);
10867 #else
10868   return 1;
10869 #endif
10870 }
10871
10872 /* End a compound statement (block).  */
10873
10874 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10875 tree
10876 ffecom_end_compstmt (void)
10877 {
10878   return bison_rule_compstmt_ ();
10879 }
10880 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10881
10882 /* ffecom_end_transition -- Perform end transition on all symbols
10883
10884    ffecom_end_transition();
10885
10886    Calls ffecom_sym_end_transition for each global and local symbol.  */
10887
10888 void
10889 ffecom_end_transition ()
10890 {
10891 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10892   ffebld item;
10893 #endif
10894
10895   if (ffe_is_ffedebug ())
10896     fprintf (dmpout, "; end_stmt_transition\n");
10897
10898 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10899   ffecom_list_blockdata_ = NULL;
10900   ffecom_list_common_ = NULL;
10901 #endif
10902
10903   ffesymbol_drive (ffecom_sym_end_transition);
10904   if (ffe_is_ffedebug ())
10905     {
10906       ffestorag_report ();
10907 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10908       ffesymbol_report_all ();
10909 #endif
10910     }
10911
10912 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10913   ffecom_start_progunit_ ();
10914
10915   for (item = ffecom_list_blockdata_;
10916        item != NULL;
10917        item = ffebld_trail (item))
10918     {
10919       ffebld callee;
10920       ffesymbol s;
10921       tree dt;
10922       tree t;
10923       tree var;
10924       static int number = 0;
10925
10926       callee = ffebld_head (item);
10927       s = ffebld_symter (callee);
10928       t = ffesymbol_hook (s).decl_tree;
10929       if (t == NULL_TREE)
10930         {
10931           s = ffecom_sym_transform_ (s);
10932           t = ffesymbol_hook (s).decl_tree;
10933         }
10934
10935       dt = build_pointer_type (TREE_TYPE (t));
10936
10937       var = build_decl (VAR_DECL,
10938                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10939                                                         number++),
10940                         dt);
10941       DECL_EXTERNAL (var) = 0;
10942       TREE_STATIC (var) = 1;
10943       TREE_PUBLIC (var) = 0;
10944       DECL_INITIAL (var) = error_mark_node;
10945       TREE_USED (var) = 1;
10946
10947       var = start_decl (var, FALSE);
10948
10949       t = ffecom_1 (ADDR_EXPR, dt, t);
10950
10951       finish_decl (var, t, FALSE);
10952     }
10953
10954   /* This handles any COMMON areas that weren't referenced but have, for
10955      example, important initial data.  */
10956
10957   for (item = ffecom_list_common_;
10958        item != NULL;
10959        item = ffebld_trail (item))
10960     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10961
10962   ffecom_list_common_ = NULL;
10963 #endif
10964 }
10965
10966 /* ffecom_exec_transition -- Perform exec transition on all symbols
10967
10968    ffecom_exec_transition();
10969
10970    Calls ffecom_sym_exec_transition for each global and local symbol.
10971    Make sure error updating not inhibited.  */
10972
10973 void
10974 ffecom_exec_transition ()
10975 {
10976   bool inhibited;
10977
10978   if (ffe_is_ffedebug ())
10979     fprintf (dmpout, "; exec_stmt_transition\n");
10980
10981   inhibited = ffebad_inhibit ();
10982   ffebad_set_inhibit (FALSE);
10983
10984   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10985   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10986   if (ffe_is_ffedebug ())
10987     {
10988       ffestorag_report ();
10989 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10990       ffesymbol_report_all ();
10991 #endif
10992     }
10993
10994   if (inhibited)
10995     ffebad_set_inhibit (TRUE);
10996 }
10997
10998 /* Handle assignment statement.
10999
11000    Convert dest and source using ffecom_expr, then join them
11001    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11002
11003 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11004 void
11005 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11006 {
11007   tree dest_tree;
11008   tree dest_length;
11009   tree source_tree;
11010   tree expr_tree;
11011
11012   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11013     {
11014       bool dest_used;
11015       tree assign_temp;
11016
11017       /* This attempts to replicate the test below, but must not be
11018          true when the test below is false.  (Always err on the side
11019          of creating unused temporaries, to avoid ICEs.)  */
11020       if (ffebld_op (dest) != FFEBLD_opSYMTER
11021           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11022               && (TREE_CODE (dest_tree) != VAR_DECL
11023                   || TREE_ADDRESSABLE (dest_tree))))
11024         {
11025           ffecom_prepare_expr_ (source, dest);
11026           dest_used = TRUE;
11027         }
11028       else
11029         {
11030           ffecom_prepare_expr_ (source, NULL);
11031           dest_used = FALSE;
11032         }
11033
11034       ffecom_prepare_expr_w (NULL_TREE, dest);
11035
11036       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11037          create a temporary through which the assignment is to take place,
11038          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11039       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11040           && ffecom_possible_partial_overlap_ (dest, source))
11041         {
11042           assign_temp = ffecom_make_tempvar ("complex_let",
11043                                              ffecom_tree_type
11044                                              [ffebld_basictype (dest)]
11045                                              [ffebld_kindtype (dest)],
11046                                              FFETARGET_charactersizeNONE,
11047                                              -1);
11048         }
11049       else
11050         assign_temp = NULL_TREE;
11051
11052       ffecom_prepare_end ();
11053
11054       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11055       if (dest_tree == error_mark_node)
11056         return;
11057
11058       if ((TREE_CODE (dest_tree) != VAR_DECL)
11059           || TREE_ADDRESSABLE (dest_tree))
11060         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11061                                     FALSE, FALSE);
11062       else
11063         {
11064           assert (! dest_used);
11065           dest_used = FALSE;
11066           source_tree = ffecom_expr (source);
11067         }
11068       if (source_tree == error_mark_node)
11069         return;
11070
11071       if (dest_used)
11072         expr_tree = source_tree;
11073       else if (assign_temp)
11074         {
11075 #ifdef MOVE_EXPR
11076           /* The back end understands a conceptual move (evaluate source;
11077              store into dest), so use that, in case it can determine
11078              that it is going to use, say, two registers as temporaries
11079              anyway.  So don't use the temp (and someday avoid generating
11080              it, once this code starts triggering regularly).  */
11081           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11082                                  dest_tree,
11083                                  source_tree);
11084 #else
11085           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11086                                  assign_temp,
11087                                  source_tree);
11088           expand_expr_stmt (expr_tree);
11089           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11090                                  dest_tree,
11091                                  assign_temp);
11092 #endif
11093         }
11094       else
11095         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11096                                dest_tree,
11097                                source_tree);
11098
11099       expand_expr_stmt (expr_tree);
11100       return;
11101     }
11102
11103   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11104   ffecom_prepare_expr_w (NULL_TREE, dest);
11105
11106   ffecom_prepare_end ();
11107
11108   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11109   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11110                     source);
11111 }
11112
11113 #endif
11114 /* ffecom_expr -- Transform expr into gcc tree
11115
11116    tree t;
11117    ffebld expr;  // FFE expression.
11118    tree = ffecom_expr(expr);
11119
11120    Recursive descent on expr while making corresponding tree nodes and
11121    attaching type info and such.  */
11122
11123 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11124 tree
11125 ffecom_expr (ffebld expr)
11126 {
11127   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11128 }
11129
11130 #endif
11131 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11132
11133 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11134 tree
11135 ffecom_expr_assign (ffebld expr)
11136 {
11137   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11138 }
11139
11140 #endif
11141 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11142
11143 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11144 tree
11145 ffecom_expr_assign_w (ffebld expr)
11146 {
11147   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11148 }
11149
11150 #endif
11151 /* Transform expr for use as into read/write tree and stabilize the
11152    reference.  Not for use on CHARACTER expressions.
11153
11154    Recursive descent on expr while making corresponding tree nodes and
11155    attaching type info and such.  */
11156
11157 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11158 tree
11159 ffecom_expr_rw (tree type, ffebld expr)
11160 {
11161   assert (expr != NULL);
11162   /* Different target types not yet supported.  */
11163   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11164
11165   return stabilize_reference (ffecom_expr (expr));
11166 }
11167
11168 #endif
11169 /* Transform expr for use as into write tree and stabilize the
11170    reference.  Not for use on CHARACTER expressions.
11171
11172    Recursive descent on expr while making corresponding tree nodes and
11173    attaching type info and such.  */
11174
11175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11176 tree
11177 ffecom_expr_w (tree type, ffebld expr)
11178 {
11179   assert (expr != NULL);
11180   /* Different target types not yet supported.  */
11181   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11182
11183   return stabilize_reference (ffecom_expr (expr));
11184 }
11185
11186 #endif
11187 /* Do global stuff.  */
11188
11189 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11190 void
11191 ffecom_finish_compile ()
11192 {
11193   assert (ffecom_outer_function_decl_ == NULL_TREE);
11194   assert (current_function_decl == NULL_TREE);
11195
11196   ffeglobal_drive (ffecom_finish_global_);
11197 }
11198
11199 #endif
11200 /* Public entry point for front end to access finish_decl.  */
11201
11202 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11203 void
11204 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11205 {
11206   assert (!is_top_level);
11207   finish_decl (decl, init, FALSE);
11208 }
11209
11210 #endif
11211 /* Finish a program unit.  */
11212
11213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11214 void
11215 ffecom_finish_progunit ()
11216 {
11217   ffecom_end_compstmt ();
11218
11219   ffecom_previous_function_decl_ = current_function_decl;
11220   ffecom_which_entrypoint_decl_ = NULL_TREE;
11221
11222   finish_function (0);
11223 }
11224
11225 #endif
11226
11227 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11228
11229 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11230 tree
11231 ffecom_get_invented_identifier (const char *pattern, ...)
11232 {
11233   tree decl;
11234   char *nam;
11235   va_list ap;
11236
11237   va_start (ap, pattern);
11238   if (vasprintf (&nam, pattern, ap) == 0)
11239     abort ();
11240   va_end (ap);
11241   decl = get_identifier (nam);
11242   free (nam);
11243   IDENTIFIER_INVENTED (decl) = 1;
11244   return decl;
11245 }
11246
11247 ffeinfoBasictype
11248 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11249 {
11250   assert (gfrt < FFECOM_gfrt);
11251
11252   switch (ffecom_gfrt_type_[gfrt])
11253     {
11254     case FFECOM_rttypeVOID_:
11255     case FFECOM_rttypeVOIDSTAR_:
11256       return FFEINFO_basictypeNONE;
11257
11258     case FFECOM_rttypeFTNINT_:
11259       return FFEINFO_basictypeINTEGER;
11260
11261     case FFECOM_rttypeINTEGER_:
11262       return FFEINFO_basictypeINTEGER;
11263
11264     case FFECOM_rttypeLONGINT_:
11265       return FFEINFO_basictypeINTEGER;
11266
11267     case FFECOM_rttypeLOGICAL_:
11268       return FFEINFO_basictypeLOGICAL;
11269
11270     case FFECOM_rttypeREAL_F2C_:
11271     case FFECOM_rttypeREAL_GNU_:
11272       return FFEINFO_basictypeREAL;
11273
11274     case FFECOM_rttypeCOMPLEX_F2C_:
11275     case FFECOM_rttypeCOMPLEX_GNU_:
11276       return FFEINFO_basictypeCOMPLEX;
11277
11278     case FFECOM_rttypeDOUBLE_:
11279     case FFECOM_rttypeDOUBLEREAL_:
11280       return FFEINFO_basictypeREAL;
11281
11282     case FFECOM_rttypeDBLCMPLX_F2C_:
11283     case FFECOM_rttypeDBLCMPLX_GNU_:
11284       return FFEINFO_basictypeCOMPLEX;
11285
11286     case FFECOM_rttypeCHARACTER_:
11287       return FFEINFO_basictypeCHARACTER;
11288
11289     default:
11290       return FFEINFO_basictypeANY;
11291     }
11292 }
11293
11294 ffeinfoKindtype
11295 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11296 {
11297   assert (gfrt < FFECOM_gfrt);
11298
11299   switch (ffecom_gfrt_type_[gfrt])
11300     {
11301     case FFECOM_rttypeVOID_:
11302     case FFECOM_rttypeVOIDSTAR_:
11303       return FFEINFO_kindtypeNONE;
11304
11305     case FFECOM_rttypeFTNINT_:
11306       return FFEINFO_kindtypeINTEGER1;
11307
11308     case FFECOM_rttypeINTEGER_:
11309       return FFEINFO_kindtypeINTEGER1;
11310
11311     case FFECOM_rttypeLONGINT_:
11312       return FFEINFO_kindtypeINTEGER4;
11313
11314     case FFECOM_rttypeLOGICAL_:
11315       return FFEINFO_kindtypeLOGICAL1;
11316
11317     case FFECOM_rttypeREAL_F2C_:
11318     case FFECOM_rttypeREAL_GNU_:
11319       return FFEINFO_kindtypeREAL1;
11320
11321     case FFECOM_rttypeCOMPLEX_F2C_:
11322     case FFECOM_rttypeCOMPLEX_GNU_:
11323       return FFEINFO_kindtypeREAL1;
11324
11325     case FFECOM_rttypeDOUBLE_:
11326     case FFECOM_rttypeDOUBLEREAL_:
11327       return FFEINFO_kindtypeREAL2;
11328
11329     case FFECOM_rttypeDBLCMPLX_F2C_:
11330     case FFECOM_rttypeDBLCMPLX_GNU_:
11331       return FFEINFO_kindtypeREAL2;
11332
11333     case FFECOM_rttypeCHARACTER_:
11334       return FFEINFO_kindtypeCHARACTER1;
11335
11336     default:
11337       return FFEINFO_kindtypeANY;
11338     }
11339 }
11340
11341 void
11342 ffecom_init_0 ()
11343 {
11344   tree endlink;
11345   int i;
11346   int j;
11347   tree t;
11348   tree field;
11349   ffetype type;
11350   ffetype base_type;
11351   tree double_ftype_double;
11352   tree float_ftype_float;
11353   tree ldouble_ftype_ldouble;
11354   tree ffecom_tree_ptr_to_fun_type_void;
11355
11356   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11357      whether the compiler environment is buggy in known ways, some of which
11358      would, if not explicitly checked here, result in subtle bugs in g77.  */
11359
11360   if (ffe_is_do_internal_checks ())
11361     {
11362       static char names[][12]
11363         =
11364       {"bar", "bletch", "foo", "foobar"};
11365       char *name;
11366       unsigned long ul;
11367       double fl;
11368
11369       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11370                       (int (*)(const void *, const void *)) strcmp);
11371       if (name != (char *) &names[2])
11372         {
11373           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11374                   == NULL);
11375           abort ();
11376         }
11377
11378       ul = strtoul ("123456789", NULL, 10);
11379       if (ul != 123456789L)
11380         {
11381           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11382  in proj.h" == NULL);
11383           abort ();
11384         }
11385
11386       fl = atof ("56.789");
11387       if ((fl < 56.788) || (fl > 56.79))
11388         {
11389           assert ("atof not type double, fix your #include <stdio.h>"
11390                   == NULL);
11391           abort ();
11392         }
11393     }
11394
11395 #if FFECOM_GCC_INCLUDE
11396   ffecom_initialize_char_syntax_ ();
11397 #endif
11398
11399   ffecom_outer_function_decl_ = NULL_TREE;
11400   current_function_decl = NULL_TREE;
11401   named_labels = NULL_TREE;
11402   current_binding_level = NULL_BINDING_LEVEL;
11403   free_binding_level = NULL_BINDING_LEVEL;
11404   /* Make the binding_level structure for global names.  */
11405   pushlevel (0);
11406   global_binding_level = current_binding_level;
11407   current_binding_level->prep_state = 2;
11408
11409   build_common_tree_nodes (1);
11410
11411   /* Define `int' and `char' first so that dbx will output them first.  */
11412   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11413                         integer_type_node));
11414   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11415                         char_type_node));
11416   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11417                         long_integer_type_node));
11418   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11419                         unsigned_type_node));
11420   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11421                         long_unsigned_type_node));
11422   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11423                         long_long_integer_type_node));
11424   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11425                         long_long_unsigned_type_node));
11426   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11427                         short_integer_type_node));
11428   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11429                         short_unsigned_type_node));
11430
11431   /* Set the sizetype before we make other types.  This *should* be the
11432      first type we create.  */
11433
11434   set_sizetype
11435     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11436   ffecom_typesize_pointer_
11437     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11438
11439   build_common_tree_nodes_2 (0);
11440
11441   /* Define both `signed char' and `unsigned char'.  */
11442   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11443                         signed_char_type_node));
11444
11445   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11446                         unsigned_char_type_node));
11447
11448   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11449                         float_type_node));
11450   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11451                         double_type_node));
11452   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11453                         long_double_type_node));
11454
11455   /* For now, override what build_common_tree_nodes has done.  */
11456   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11457   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11458   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11459   complex_long_double_type_node
11460     = ffecom_make_complex_type_ (long_double_type_node);
11461
11462   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11463                         complex_integer_type_node));
11464   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11465                         complex_float_type_node));
11466   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11467                         complex_double_type_node));
11468   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11469                         complex_long_double_type_node));
11470
11471   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11472                         void_type_node));
11473   /* We are not going to have real types in C with less than byte alignment,
11474      so we might as well not have any types that claim to have it.  */
11475   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11476   TYPE_USER_ALIGN (void_type_node) = 0;
11477
11478   string_type_node = build_pointer_type (char_type_node);
11479
11480   ffecom_tree_fun_type_void
11481     = build_function_type (void_type_node, NULL_TREE);
11482
11483   ffecom_tree_ptr_to_fun_type_void
11484     = build_pointer_type (ffecom_tree_fun_type_void);
11485
11486   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11487
11488   float_ftype_float
11489     = build_function_type (float_type_node,
11490                            tree_cons (NULL_TREE, float_type_node, endlink));
11491
11492   double_ftype_double
11493     = build_function_type (double_type_node,
11494                            tree_cons (NULL_TREE, double_type_node, endlink));
11495
11496   ldouble_ftype_ldouble
11497     = build_function_type (long_double_type_node,
11498                            tree_cons (NULL_TREE, long_double_type_node,
11499                                       endlink));
11500
11501   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11502     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11503       {
11504         ffecom_tree_type[i][j] = NULL_TREE;
11505         ffecom_tree_fun_type[i][j] = NULL_TREE;
11506         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11507         ffecom_f2c_typecode_[i][j] = -1;
11508       }
11509
11510   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11511      to size FLOAT_TYPE_SIZE because they have to be the same size as
11512      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11513      Compiler options and other such stuff that change the ways these
11514      types are set should not affect this particular setup.  */
11515
11516   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11517     = t = make_signed_type (FLOAT_TYPE_SIZE);
11518   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11519                         t));
11520   type = ffetype_new ();
11521   base_type = type;
11522   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11523                     type);
11524   ffetype_set_ams (type,
11525                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11526                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11527   ffetype_set_star (base_type,
11528                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11529                     type);
11530   ffetype_set_kind (base_type, 1, type);
11531   ffecom_typesize_integer1_ = ffetype_size (type);
11532   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11533
11534   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11535     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11536   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11537                         t));
11538
11539   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11540     = t = make_signed_type (CHAR_TYPE_SIZE);
11541   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11542                         t));
11543   type = ffetype_new ();
11544   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11545                     type);
11546   ffetype_set_ams (type,
11547                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11548                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11549   ffetype_set_star (base_type,
11550                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11551                     type);
11552   ffetype_set_kind (base_type, 3, type);
11553   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11554
11555   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11556     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11557   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11558                         t));
11559
11560   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11561     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11562   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11563                         t));
11564   type = ffetype_new ();
11565   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11566                     type);
11567   ffetype_set_ams (type,
11568                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11569                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11570   ffetype_set_star (base_type,
11571                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11572                     type);
11573   ffetype_set_kind (base_type, 6, type);
11574   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11575
11576   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11577     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11578   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11579                         t));
11580
11581   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11582     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11583   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11584                         t));
11585   type = ffetype_new ();
11586   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11587                     type);
11588   ffetype_set_ams (type,
11589                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11590                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11591   ffetype_set_star (base_type,
11592                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11593                     type);
11594   ffetype_set_kind (base_type, 2, type);
11595   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11596
11597   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11598     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11599   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11600                         t));
11601
11602 #if 0
11603   if (ffe_is_do_internal_checks ()
11604       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11605       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11606       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11607       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11608     {
11609       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11610                LONG_TYPE_SIZE);
11611     }
11612 #endif
11613
11614   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11615     = t = make_signed_type (FLOAT_TYPE_SIZE);
11616   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11617                         t));
11618   type = ffetype_new ();
11619   base_type = type;
11620   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11621                     type);
11622   ffetype_set_ams (type,
11623                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11624                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11625   ffetype_set_star (base_type,
11626                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11627                     type);
11628   ffetype_set_kind (base_type, 1, type);
11629   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11630
11631   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11632     = t = make_signed_type (CHAR_TYPE_SIZE);
11633   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11634                         t));
11635   type = ffetype_new ();
11636   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11637                     type);
11638   ffetype_set_ams (type,
11639                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11640                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11641   ffetype_set_star (base_type,
11642                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11643                     type);
11644   ffetype_set_kind (base_type, 3, type);
11645   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11646
11647   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11648     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11649   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11650                         t));
11651   type = ffetype_new ();
11652   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11653                     type);
11654   ffetype_set_ams (type,
11655                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11656                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11657   ffetype_set_star (base_type,
11658                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11659                     type);
11660   ffetype_set_kind (base_type, 6, type);
11661   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11662
11663   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11664     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11665   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11666                         t));
11667   type = ffetype_new ();
11668   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11669                     type);
11670   ffetype_set_ams (type,
11671                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11672                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11673   ffetype_set_star (base_type,
11674                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11675                     type);
11676   ffetype_set_kind (base_type, 2, type);
11677   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11678
11679   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11680     = t = make_node (REAL_TYPE);
11681   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11682   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11683                         t));
11684   layout_type (t);
11685   type = ffetype_new ();
11686   base_type = type;
11687   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11688                     type);
11689   ffetype_set_ams (type,
11690                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11691                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11692   ffetype_set_star (base_type,
11693                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11694                     type);
11695   ffetype_set_kind (base_type, 1, type);
11696   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11697     = FFETARGET_f2cTYREAL;
11698   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11699
11700   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11701     = t = make_node (REAL_TYPE);
11702   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11703   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11704                         t));
11705   layout_type (t);
11706   type = ffetype_new ();
11707   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11708                     type);
11709   ffetype_set_ams (type,
11710                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11711                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11712   ffetype_set_star (base_type,
11713                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11714                     type);
11715   ffetype_set_kind (base_type, 2, type);
11716   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11717     = FFETARGET_f2cTYDREAL;
11718   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11719
11720   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11721     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11722   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11723                         t));
11724   type = ffetype_new ();
11725   base_type = type;
11726   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11727                     type);
11728   ffetype_set_ams (type,
11729                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11730                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11731   ffetype_set_star (base_type,
11732                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11733                     type);
11734   ffetype_set_kind (base_type, 1, type);
11735   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11736     = FFETARGET_f2cTYCOMPLEX;
11737   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11738
11739   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11740     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11741   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11742                         t));
11743   type = ffetype_new ();
11744   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11745                     type);
11746   ffetype_set_ams (type,
11747                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11748                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11749   ffetype_set_star (base_type,
11750                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11751                     type);
11752   ffetype_set_kind (base_type, 2,
11753                     type);
11754   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11755     = FFETARGET_f2cTYDCOMPLEX;
11756   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11757
11758   /* Make function and ptr-to-function types for non-CHARACTER types. */
11759
11760   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11761     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11762       {
11763         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11764           {
11765             if (i == FFEINFO_basictypeINTEGER)
11766               {
11767                 /* Figure out the smallest INTEGER type that can hold
11768                    a pointer on this machine. */
11769                 if (GET_MODE_SIZE (TYPE_MODE (t))
11770                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11771                   {
11772                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11773                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11774                             > GET_MODE_SIZE (TYPE_MODE (t))))
11775                       ffecom_pointer_kind_ = j;
11776                   }
11777               }
11778             else if (i == FFEINFO_basictypeCOMPLEX)
11779               t = void_type_node;
11780             /* For f2c compatibility, REAL functions are really
11781                implemented as DOUBLE PRECISION.  */
11782             else if ((i == FFEINFO_basictypeREAL)
11783                      && (j == FFEINFO_kindtypeREAL1))
11784               t = ffecom_tree_type
11785                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11786
11787             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11788                                                                   NULL_TREE);
11789             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11790           }
11791       }
11792
11793   /* Set up pointer types.  */
11794
11795   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11796     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11797   else if (0 && ffe_is_do_internal_checks ())
11798     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11799   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11800                                   FFEINFO_kindtypeINTEGERDEFAULT),
11801                     7,
11802                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11803                                   ffecom_pointer_kind_));
11804
11805   if (ffe_is_ugly_assign ())
11806     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11807   else
11808     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11809   if (0 && ffe_is_do_internal_checks ())
11810     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11811
11812   ffecom_integer_type_node
11813     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11814   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11815                                       integer_zero_node);
11816   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11817                                      integer_one_node);
11818
11819   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11820      Turns out that by TYLONG, runtime/libI77/lio.h really means
11821      "whatever size an ftnint is".  For consistency and sanity,
11822      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11823      all are INTEGER, which we also make out of whatever back-end
11824      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11825      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11826      accommodate machines like the Alpha.  Note that this suggests
11827      f2c and libf2c are missing a distinction perhaps needed on
11828      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11829
11830   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11831                             FFETARGET_f2cTYLONG);
11832   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11833                             FFETARGET_f2cTYSHORT);
11834   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11835                             FFETARGET_f2cTYINT1);
11836   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11837                             FFETARGET_f2cTYQUAD);
11838   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11839                             FFETARGET_f2cTYLOGICAL);
11840   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11841                             FFETARGET_f2cTYLOGICAL2);
11842   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11843                             FFETARGET_f2cTYLOGICAL1);
11844   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11845   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11846                             FFETARGET_f2cTYQUAD);
11847
11848   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11849      loop.  CHARACTER items are built as arrays of unsigned char.  */
11850
11851   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11852     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11853   type = ffetype_new ();
11854   base_type = type;
11855   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11856                     FFEINFO_kindtypeCHARACTER1,
11857                     type);
11858   ffetype_set_ams (type,
11859                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11860                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11861   ffetype_set_kind (base_type, 1, type);
11862   assert (ffetype_size (type)
11863           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11864
11865   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11866     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11867   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11868     [FFEINFO_kindtypeCHARACTER1]
11869     = ffecom_tree_ptr_to_fun_type_void;
11870   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11871     = FFETARGET_f2cTYCHAR;
11872
11873   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11874     = 0;
11875
11876   /* Make multi-return-value type and fields. */
11877
11878   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11879
11880   field = NULL_TREE;
11881
11882   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11883     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11884       {
11885         char name[30];
11886
11887         if (ffecom_tree_type[i][j] == NULL_TREE)
11888           continue;             /* Not supported. */
11889         sprintf (&name[0], "bt_%s_kt_%s",
11890                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11891                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11892         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11893                                                  get_identifier (name),
11894                                                  ffecom_tree_type[i][j]);
11895         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11896           = ffecom_multi_type_node_;
11897         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11898         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11899         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11900         field = ffecom_multi_fields_[i][j];
11901       }
11902
11903   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11904   layout_type (ffecom_multi_type_node_);
11905
11906   /* Subroutines usually return integer because they might have alternate
11907      returns. */
11908
11909   ffecom_tree_subr_type
11910     = build_function_type (integer_type_node, NULL_TREE);
11911   ffecom_tree_ptr_to_subr_type
11912     = build_pointer_type (ffecom_tree_subr_type);
11913   ffecom_tree_blockdata_type
11914     = build_function_type (void_type_node, NULL_TREE);
11915
11916   builtin_function ("__builtin_sqrtf", float_ftype_float,
11917                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11918   builtin_function ("__builtin_fsqrt", double_ftype_double,
11919                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11920   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11921                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11922   builtin_function ("__builtin_sinf", float_ftype_float,
11923                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11924   builtin_function ("__builtin_sin", double_ftype_double,
11925                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11926   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11927                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11928   builtin_function ("__builtin_cosf", float_ftype_float,
11929                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11930   builtin_function ("__builtin_cos", double_ftype_double,
11931                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11932   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11933                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11934
11935 #if BUILT_FOR_270
11936   pedantic_lvalues = FALSE;
11937 #endif
11938
11939   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11940                          FFECOM_f2cINTEGER,
11941                          "integer");
11942   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11943                          FFECOM_f2cADDRESS,
11944                          "address");
11945   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11946                          FFECOM_f2cREAL,
11947                          "real");
11948   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11949                          FFECOM_f2cDOUBLEREAL,
11950                          "doublereal");
11951   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11952                          FFECOM_f2cCOMPLEX,
11953                          "complex");
11954   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11955                          FFECOM_f2cDOUBLECOMPLEX,
11956                          "doublecomplex");
11957   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11958                          FFECOM_f2cLONGINT,
11959                          "longint");
11960   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11961                          FFECOM_f2cLOGICAL,
11962                          "logical");
11963   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11964                          FFECOM_f2cFLAG,
11965                          "flag");
11966   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11967                          FFECOM_f2cFTNLEN,
11968                          "ftnlen");
11969   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11970                          FFECOM_f2cFTNINT,
11971                          "ftnint");
11972
11973   ffecom_f2c_ftnlen_zero_node
11974     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11975
11976   ffecom_f2c_ftnlen_one_node
11977     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11978
11979   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11980   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11981
11982   ffecom_f2c_ptr_to_ftnlen_type_node
11983     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11984
11985   ffecom_f2c_ptr_to_ftnint_type_node
11986     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11987
11988   ffecom_f2c_ptr_to_integer_type_node
11989     = build_pointer_type (ffecom_f2c_integer_type_node);
11990
11991   ffecom_f2c_ptr_to_real_type_node
11992     = build_pointer_type (ffecom_f2c_real_type_node);
11993
11994   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11995   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11996   {
11997     REAL_VALUE_TYPE point_5;
11998
11999 #ifdef REAL_ARITHMETIC
12000     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12001 #else
12002     point_5 = .5;
12003 #endif
12004     ffecom_float_half_ = build_real (float_type_node, point_5);
12005     ffecom_double_half_ = build_real (double_type_node, point_5);
12006   }
12007
12008   /* Do "extern int xargc;".  */
12009
12010   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12011                                    get_identifier ("f__xargc"),
12012                                    integer_type_node);
12013   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12014   TREE_STATIC (ffecom_tree_xargc_) = 1;
12015   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12016   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12017   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12018
12019 #if 0   /* This is being fixed, and seems to be working now. */
12020   if ((FLOAT_TYPE_SIZE != 32)
12021       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12022     {
12023       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12024                (int) FLOAT_TYPE_SIZE);
12025       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12026           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12027       warning ("properly unless they all are 32 bits wide.");
12028       warning ("Please keep this in mind before you report bugs.  g77 should");
12029       warning ("support non-32-bit machines better as of version 0.6.");
12030     }
12031 #endif
12032
12033 #if 0   /* Code in ste.c that would crash has been commented out. */
12034   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12035       < TYPE_PRECISION (string_type_node))
12036     /* I/O will probably crash.  */
12037     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12038              TYPE_PRECISION (string_type_node),
12039              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12040 #endif
12041
12042 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12043   if (TYPE_PRECISION (ffecom_integer_type_node)
12044       < TYPE_PRECISION (string_type_node))
12045     /* ASSIGN 10 TO I will crash.  */
12046     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12047  ASSIGN statement might fail",
12048              TYPE_PRECISION (string_type_node),
12049              TYPE_PRECISION (ffecom_integer_type_node));
12050 #endif
12051 }
12052
12053 #endif
12054 /* ffecom_init_2 -- Initialize
12055
12056    ffecom_init_2();  */
12057
12058 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12059 void
12060 ffecom_init_2 ()
12061 {
12062   assert (ffecom_outer_function_decl_ == NULL_TREE);
12063   assert (current_function_decl == NULL_TREE);
12064   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12065
12066   ffecom_master_arglist_ = NULL;
12067   ++ffecom_num_fns_;
12068   ffecom_primary_entry_ = NULL;
12069   ffecom_is_altreturning_ = FALSE;
12070   ffecom_func_result_ = NULL_TREE;
12071   ffecom_multi_retval_ = NULL_TREE;
12072 }
12073
12074 #endif
12075 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12076
12077    tree t;
12078    ffebld expr;  // FFE opITEM list.
12079    tree = ffecom_list_expr(expr);
12080
12081    List of actual args is transformed into corresponding gcc backend list.  */
12082
12083 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12084 tree
12085 ffecom_list_expr (ffebld expr)
12086 {
12087   tree list;
12088   tree *plist = &list;
12089   tree trail = NULL_TREE;       /* Append char length args here. */
12090   tree *ptrail = &trail;
12091   tree length;
12092
12093   while (expr != NULL)
12094     {
12095       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12096
12097       if (texpr == error_mark_node)
12098         return error_mark_node;
12099
12100       *plist = build_tree_list (NULL_TREE, texpr);
12101       plist = &TREE_CHAIN (*plist);
12102       expr = ffebld_trail (expr);
12103       if (length != NULL_TREE)
12104         {
12105           *ptrail = build_tree_list (NULL_TREE, length);
12106           ptrail = &TREE_CHAIN (*ptrail);
12107         }
12108     }
12109
12110   *plist = trail;
12111
12112   return list;
12113 }
12114
12115 #endif
12116 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12117
12118    tree t;
12119    ffebld expr;  // FFE opITEM list.
12120    tree = ffecom_list_ptr_to_expr(expr);
12121
12122    List of actual args is transformed into corresponding gcc backend list for
12123    use in calling an external procedure (vs. a statement function).  */
12124
12125 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12126 tree
12127 ffecom_list_ptr_to_expr (ffebld expr)
12128 {
12129   tree list;
12130   tree *plist = &list;
12131   tree trail = NULL_TREE;       /* Append char length args here. */
12132   tree *ptrail = &trail;
12133   tree length;
12134
12135   while (expr != NULL)
12136     {
12137       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12138
12139       if (texpr == error_mark_node)
12140         return error_mark_node;
12141
12142       *plist = build_tree_list (NULL_TREE, texpr);
12143       plist = &TREE_CHAIN (*plist);
12144       expr = ffebld_trail (expr);
12145       if (length != NULL_TREE)
12146         {
12147           *ptrail = build_tree_list (NULL_TREE, length);
12148           ptrail = &TREE_CHAIN (*ptrail);
12149         }
12150     }
12151
12152   *plist = trail;
12153
12154   return list;
12155 }
12156
12157 #endif
12158 /* Obtain gcc's LABEL_DECL tree for label.  */
12159
12160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12161 tree
12162 ffecom_lookup_label (ffelab label)
12163 {
12164   tree glabel;
12165
12166   if (ffelab_hook (label) == NULL_TREE)
12167     {
12168       char labelname[16];
12169
12170       switch (ffelab_type (label))
12171         {
12172         case FFELAB_typeLOOPEND:
12173         case FFELAB_typeNOTLOOP:
12174         case FFELAB_typeENDIF:
12175           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12176           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12177                                void_type_node);
12178           DECL_CONTEXT (glabel) = current_function_decl;
12179           DECL_MODE (glabel) = VOIDmode;
12180           break;
12181
12182         case FFELAB_typeFORMAT:
12183           glabel = build_decl (VAR_DECL,
12184                                ffecom_get_invented_identifier
12185                                ("__g77_format_%d", (int) ffelab_value (label)),
12186                                build_type_variant (build_array_type
12187                                                    (char_type_node,
12188                                                     NULL_TREE),
12189                                                    1, 0));
12190           TREE_CONSTANT (glabel) = 1;
12191           TREE_STATIC (glabel) = 1;
12192           DECL_CONTEXT (glabel) = current_function_decl;
12193           DECL_INITIAL (glabel) = NULL;
12194           make_decl_rtl (glabel, NULL);
12195           expand_decl (glabel);
12196
12197           ffecom_save_tree_forever (glabel);
12198
12199           break;
12200
12201         case FFELAB_typeANY:
12202           glabel = error_mark_node;
12203           break;
12204
12205         default:
12206           assert ("bad label type" == NULL);
12207           glabel = NULL;
12208           break;
12209         }
12210       ffelab_set_hook (label, glabel);
12211     }
12212   else
12213     {
12214       glabel = ffelab_hook (label);
12215     }
12216
12217   return glabel;
12218 }
12219
12220 #endif
12221 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12222    a single source specification (as in the fourth argument of MVBITS).
12223    If the type is NULL_TREE, the type of lhs is used to make the type of
12224    the MODIFY_EXPR.  */
12225
12226 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12227 tree
12228 ffecom_modify (tree newtype, tree lhs,
12229                tree rhs)
12230 {
12231   if (lhs == error_mark_node || rhs == error_mark_node)
12232     return error_mark_node;
12233
12234   if (newtype == NULL_TREE)
12235     newtype = TREE_TYPE (lhs);
12236
12237   if (TREE_SIDE_EFFECTS (lhs))
12238     lhs = stabilize_reference (lhs);
12239
12240   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12241 }
12242
12243 #endif
12244
12245 /* Register source file name.  */
12246
12247 void
12248 ffecom_file (const char *name)
12249 {
12250 #if FFECOM_GCC_INCLUDE
12251   ffecom_file_ (name);
12252 #endif
12253 }
12254
12255 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12256
12257    ffestorag st;
12258    ffecom_notify_init_storage(st);
12259
12260    Gets called when all possible units in an aggregate storage area (a LOCAL
12261    with equivalences or a COMMON) have been initialized.  The initialization
12262    info either is in ffestorag_init or, if that is NULL,
12263    ffestorag_accretion:
12264
12265    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12266    even for an array if the array is one element in length!
12267
12268    ffestorag_accretion will contain an opACCTER.  It is much like an
12269    opARRTER except it has an ffebit object in it instead of just a size.
12270    The back end can use the info in the ffebit object, if it wants, to
12271    reduce the amount of actual initialization, but in any case it should
12272    kill the ffebit object when done.  Also, set accretion to NULL but
12273    init to a non-NULL value.
12274
12275    After performing initialization, DO NOT set init to NULL, because that'll
12276    tell the front end it is ok for more initialization to happen.  Instead,
12277    set init to an opANY expression or some such thing that you can use to
12278    tell that you've already initialized the object.
12279
12280    27-Oct-91  JCB  1.1
12281       Support two-pass FFE.  */
12282
12283 void
12284 ffecom_notify_init_storage (ffestorag st)
12285 {
12286   ffebld init;                  /* The initialization expression. */
12287 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12288   ffetargetOffset size;         /* The size of the entity. */
12289   ffetargetAlign pad;           /* Its initial padding. */
12290 #endif
12291
12292   if (ffestorag_init (st) == NULL)
12293     {
12294       init = ffestorag_accretion (st);
12295       assert (init != NULL);
12296       ffestorag_set_accretion (st, NULL);
12297       ffestorag_set_accretes (st, 0);
12298
12299 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12300       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12301       size = ffebld_accter_size (init);
12302       pad = ffebld_accter_pad (init);
12303       ffebit_kill (ffebld_accter_bits (init));
12304       ffebld_set_op (init, FFEBLD_opARRTER);
12305       ffebld_set_arrter (init, ffebld_accter (init));
12306       ffebld_arrter_set_size (init, size);
12307       ffebld_arrter_set_pad (init, size);
12308 #endif
12309
12310 #if FFECOM_TWOPASS
12311       ffestorag_set_init (st, init);
12312 #endif
12313     }
12314 #if FFECOM_ONEPASS
12315   else
12316     init = ffestorag_init (st);
12317 #endif
12318
12319 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12320   ffestorag_set_init (st, ffebld_new_any ());
12321
12322   if (ffebld_op (init) == FFEBLD_opANY)
12323     return;                     /* Oh, we already did this! */
12324
12325 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12326   {
12327     ffesymbol s;
12328
12329     if (ffestorag_symbol (st) != NULL)
12330       s = ffestorag_symbol (st);
12331     else
12332       s = ffestorag_typesymbol (st);
12333
12334     fprintf (dmpout, "= initialize_storage \"%s\" ",
12335              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12336     ffebld_dump (init);
12337     fputc ('\n', dmpout);
12338   }
12339 #endif
12340
12341 #endif /* if FFECOM_ONEPASS */
12342 }
12343
12344 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12345
12346    ffesymbol s;
12347    ffecom_notify_init_symbol(s);
12348
12349    Gets called when all possible units in a symbol (not placed in COMMON
12350    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12351    have been initialized.  The initialization info either is in
12352    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12353
12354    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12355    even for an array if the array is one element in length!
12356
12357    ffesymbol_accretion will contain an opACCTER.  It is much like an
12358    opARRTER except it has an ffebit object in it instead of just a size.
12359    The back end can use the info in the ffebit object, if it wants, to
12360    reduce the amount of actual initialization, but in any case it should
12361    kill the ffebit object when done.  Also, set accretion to NULL but
12362    init to a non-NULL value.
12363
12364    After performing initialization, DO NOT set init to NULL, because that'll
12365    tell the front end it is ok for more initialization to happen.  Instead,
12366    set init to an opANY expression or some such thing that you can use to
12367    tell that you've already initialized the object.
12368
12369    27-Oct-91  JCB  1.1
12370       Support two-pass FFE.  */
12371
12372 void
12373 ffecom_notify_init_symbol (ffesymbol s)
12374 {
12375   ffebld init;                  /* The initialization expression. */
12376 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12377   ffetargetOffset size;         /* The size of the entity. */
12378   ffetargetAlign pad;           /* Its initial padding. */
12379 #endif
12380
12381   if (ffesymbol_storage (s) == NULL)
12382     return;                     /* Do nothing until COMMON/EQUIVALENCE
12383                                    possibilities checked. */
12384
12385   if ((ffesymbol_init (s) == NULL)
12386       && ((init = ffesymbol_accretion (s)) != NULL))
12387     {
12388       ffesymbol_set_accretion (s, NULL);
12389       ffesymbol_set_accretes (s, 0);
12390
12391 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12392       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12393       size = ffebld_accter_size (init);
12394       pad = ffebld_accter_pad (init);
12395       ffebit_kill (ffebld_accter_bits (init));
12396       ffebld_set_op (init, FFEBLD_opARRTER);
12397       ffebld_set_arrter (init, ffebld_accter (init));
12398       ffebld_arrter_set_size (init, size);
12399       ffebld_arrter_set_pad (init, size);
12400 #endif
12401
12402 #if FFECOM_TWOPASS
12403       ffesymbol_set_init (s, init);
12404 #endif
12405     }
12406 #if FFECOM_ONEPASS
12407   else
12408     init = ffesymbol_init (s);
12409 #endif
12410
12411 #if FFECOM_ONEPASS
12412   ffesymbol_set_init (s, ffebld_new_any ());
12413
12414   if (ffebld_op (init) == FFEBLD_opANY)
12415     return;                     /* Oh, we already did this! */
12416
12417 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12418   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12419   ffebld_dump (init);
12420   fputc ('\n', dmpout);
12421 #endif
12422
12423 #endif /* if FFECOM_ONEPASS */
12424 }
12425
12426 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12427
12428    ffesymbol s;
12429    ffecom_notify_primary_entry(s);
12430
12431    Gets called when implicit or explicit PROGRAM statement seen or when
12432    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12433    global symbol that serves as the entry point.  */
12434
12435 void
12436 ffecom_notify_primary_entry (ffesymbol s)
12437 {
12438   ffecom_primary_entry_ = s;
12439   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12440
12441   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12442       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12443     ffecom_primary_entry_is_proc_ = TRUE;
12444   else
12445     ffecom_primary_entry_is_proc_ = FALSE;
12446
12447   if (!ffe_is_silent ())
12448     {
12449       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12450         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12451       else
12452         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12453     }
12454
12455 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12456   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12457     {
12458       ffebld list;
12459       ffebld arg;
12460
12461       for (list = ffesymbol_dummyargs (s);
12462            list != NULL;
12463            list = ffebld_trail (list))
12464         {
12465           arg = ffebld_head (list);
12466           if (ffebld_op (arg) == FFEBLD_opSTAR)
12467             {
12468               ffecom_is_altreturning_ = TRUE;
12469               break;
12470             }
12471         }
12472     }
12473 #endif
12474 }
12475
12476 FILE *
12477 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12478 {
12479 #if FFECOM_GCC_INCLUDE
12480   return ffecom_open_include_ (name, l, c);
12481 #else
12482   return fopen (name, "r");
12483 #endif
12484 }
12485
12486 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12487
12488    tree t;
12489    ffebld expr;  // FFE expression.
12490    tree = ffecom_ptr_to_expr(expr);
12491
12492    Like ffecom_expr, but sticks address-of in front of most things.  */
12493
12494 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12495 tree
12496 ffecom_ptr_to_expr (ffebld expr)
12497 {
12498   tree item;
12499   ffeinfoBasictype bt;
12500   ffeinfoKindtype kt;
12501   ffesymbol s;
12502
12503   assert (expr != NULL);
12504
12505   switch (ffebld_op (expr))
12506     {
12507     case FFEBLD_opSYMTER:
12508       s = ffebld_symter (expr);
12509       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12510         {
12511           ffecomGfrt ix;
12512
12513           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12514           assert (ix != FFECOM_gfrt);
12515           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12516             {
12517               ffecom_make_gfrt_ (ix);
12518               item = ffecom_gfrt_[ix];
12519             }
12520         }
12521       else
12522         {
12523           item = ffesymbol_hook (s).decl_tree;
12524           if (item == NULL_TREE)
12525             {
12526               s = ffecom_sym_transform_ (s);
12527               item = ffesymbol_hook (s).decl_tree;
12528             }
12529         }
12530       assert (item != NULL);
12531       if (item == error_mark_node)
12532         return item;
12533       if (!ffesymbol_hook (s).addr)
12534         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12535                          item);
12536       return item;
12537
12538     case FFEBLD_opARRAYREF:
12539       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12540
12541     case FFEBLD_opCONTER:
12542
12543       bt = ffeinfo_basictype (ffebld_info (expr));
12544       kt = ffeinfo_kindtype (ffebld_info (expr));
12545
12546       item = ffecom_constantunion (&ffebld_constant_union
12547                                    (ffebld_conter (expr)), bt, kt,
12548                                    ffecom_tree_type[bt][kt]);
12549       if (item == error_mark_node)
12550         return error_mark_node;
12551       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12552                        item);
12553       return item;
12554
12555     case FFEBLD_opANY:
12556       return error_mark_node;
12557
12558     default:
12559       bt = ffeinfo_basictype (ffebld_info (expr));
12560       kt = ffeinfo_kindtype (ffebld_info (expr));
12561
12562       item = ffecom_expr (expr);
12563       if (item == error_mark_node)
12564         return error_mark_node;
12565
12566       /* The back end currently optimizes a bit too zealously for us, in that
12567          we fail JCB001 if the following block of code is omitted.  It checks
12568          to see if the transformed expression is a symbol or array reference,
12569          and encloses it in a SAVE_EXPR if that is the case.  */
12570
12571       STRIP_NOPS (item);
12572       if ((TREE_CODE (item) == VAR_DECL)
12573           || (TREE_CODE (item) == PARM_DECL)
12574           || (TREE_CODE (item) == RESULT_DECL)
12575           || (TREE_CODE (item) == INDIRECT_REF)
12576           || (TREE_CODE (item) == ARRAY_REF)
12577           || (TREE_CODE (item) == COMPONENT_REF)
12578 #ifdef OFFSET_REF
12579           || (TREE_CODE (item) == OFFSET_REF)
12580 #endif
12581           || (TREE_CODE (item) == BUFFER_REF)
12582           || (TREE_CODE (item) == REALPART_EXPR)
12583           || (TREE_CODE (item) == IMAGPART_EXPR))
12584         {
12585           item = ffecom_save_tree (item);
12586         }
12587
12588       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12589                        item);
12590       return item;
12591     }
12592
12593   assert ("fall-through error" == NULL);
12594   return error_mark_node;
12595 }
12596
12597 #endif
12598 /* Obtain a temp var with given data type.
12599
12600    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12601    or >= 0 for a CHARACTER type.
12602
12603    elements is -1 for a scalar or > 0 for an array of type.  */
12604
12605 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12606 tree
12607 ffecom_make_tempvar (const char *commentary, tree type,
12608                      ffetargetCharacterSize size, int elements)
12609 {
12610   tree t;
12611   static int mynumber;
12612
12613   assert (current_binding_level->prep_state < 2);
12614
12615   if (type == error_mark_node)
12616     return error_mark_node;
12617
12618   if (size != FFETARGET_charactersizeNONE)
12619     type = build_array_type (type,
12620                              build_range_type (ffecom_f2c_ftnlen_type_node,
12621                                                ffecom_f2c_ftnlen_one_node,
12622                                                build_int_2 (size, 0)));
12623   if (elements != -1)
12624     type = build_array_type (type,
12625                              build_range_type (integer_type_node,
12626                                                integer_zero_node,
12627                                                build_int_2 (elements - 1,
12628                                                             0)));
12629   t = build_decl (VAR_DECL,
12630                   ffecom_get_invented_identifier ("__g77_%s_%d",
12631                                                   commentary,
12632                                                   mynumber++),
12633                   type);
12634
12635   t = start_decl (t, FALSE);
12636   finish_decl (t, NULL_TREE, FALSE);
12637
12638   return t;
12639 }
12640 #endif
12641
12642 /* Prepare argument pointer to expression.
12643
12644    Like ffecom_prepare_expr, except for expressions to be evaluated
12645    via ffecom_arg_ptr_to_expr.  */
12646
12647 void
12648 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12649 {
12650   /* ~~For now, it seems to be the same thing.  */
12651   ffecom_prepare_expr (expr);
12652   return;
12653 }
12654
12655 /* End of preparations.  */
12656
12657 bool
12658 ffecom_prepare_end (void)
12659 {
12660   int prep_state = current_binding_level->prep_state;
12661
12662   assert (prep_state < 2);
12663   current_binding_level->prep_state = 2;
12664
12665   return (prep_state == 1) ? TRUE : FALSE;
12666 }
12667
12668 /* Prepare expression.
12669
12670    This is called before any code is generated for the current block.
12671    It scans the expression, declares any temporaries that might be needed
12672    during evaluation of the expression, and stores those temporaries in
12673    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12674    specifies the destination that ffecom_expr_ will see, in case that
12675    helps avoid generating unused temporaries.
12676
12677    ~~Improve to avoid allocating unused temporaries by taking `dest'
12678    into account vis-a-vis aliasing requirements of complex/character
12679    functions.  */
12680
12681 void
12682 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12683 {
12684   ffeinfoBasictype bt;
12685   ffeinfoKindtype kt;
12686   ffetargetCharacterSize sz;
12687   tree tempvar = NULL_TREE;
12688
12689   assert (current_binding_level->prep_state < 2);
12690
12691   if (! expr)
12692     return;
12693
12694   bt = ffeinfo_basictype (ffebld_info (expr));
12695   kt = ffeinfo_kindtype (ffebld_info (expr));
12696   sz = ffeinfo_size (ffebld_info (expr));
12697
12698   /* Generate whatever temporaries are needed to represent the result
12699      of the expression.  */
12700
12701   if (bt == FFEINFO_basictypeCHARACTER)
12702     {
12703       while (ffebld_op (expr) == FFEBLD_opPAREN)
12704         expr = ffebld_left (expr);
12705     }
12706
12707   switch (ffebld_op (expr))
12708     {
12709     default:
12710       /* Don't make temps for SYMTER, CONTER, etc.  */
12711       if (ffebld_arity (expr) == 0)
12712         break;
12713
12714       switch (bt)
12715         {
12716         case FFEINFO_basictypeCOMPLEX:
12717           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12718             {
12719               ffesymbol s;
12720
12721               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12722                 break;
12723
12724               s = ffebld_symter (ffebld_left (expr));
12725               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12726                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12727                       && ! ffesymbol_is_f2c (s))
12728                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12729                       && ! ffe_is_f2c_library ()))
12730                 break;
12731             }
12732           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12733             {
12734               /* Requires special treatment.  There's no POW_CC function
12735                  in libg2c, so POW_ZZ is used, which means we always
12736                  need a double-complex temp, not a single-complex.  */
12737               kt = FFEINFO_kindtypeREAL2;
12738             }
12739           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12740             /* The other ops don't need temps for complex operands.  */
12741             break;
12742
12743           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12744              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12745           tempvar = ffecom_make_tempvar ("complex",
12746                                          ffecom_tree_type
12747                                          [FFEINFO_basictypeCOMPLEX][kt],
12748                                          FFETARGET_charactersizeNONE,
12749                                          -1);
12750           break;
12751
12752         case FFEINFO_basictypeCHARACTER:
12753           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12754             break;
12755
12756           if (sz == FFETARGET_charactersizeNONE)
12757             /* ~~Kludge alert!  This should someday be fixed. */
12758             sz = 24;
12759
12760           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12761           break;
12762
12763         default:
12764           break;
12765         }
12766       break;
12767
12768 #ifdef HAHA
12769     case FFEBLD_opPOWER:
12770       {
12771         tree rtype, ltype;
12772         tree rtmp, ltmp, result;
12773
12774         ltype = ffecom_type_expr (ffebld_left (expr));
12775         rtype = ffecom_type_expr (ffebld_right (expr));
12776
12777         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12778         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12779         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12780
12781         tempvar = make_tree_vec (3);
12782         TREE_VEC_ELT (tempvar, 0) = rtmp;
12783         TREE_VEC_ELT (tempvar, 1) = ltmp;
12784         TREE_VEC_ELT (tempvar, 2) = result;
12785       }
12786       break;
12787 #endif  /* HAHA */
12788
12789     case FFEBLD_opCONCATENATE:
12790       {
12791         /* This gets special handling, because only one set of temps
12792            is needed for a tree of these -- the tree is treated as
12793            a flattened list of concatenations when generating code.  */
12794
12795         ffecomConcatList_ catlist;
12796         tree ltmp, itmp, result;
12797         int count;
12798         int i;
12799
12800         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12801         count = ffecom_concat_list_count_ (catlist);
12802
12803         if (count >= 2)
12804           {
12805             ltmp
12806               = ffecom_make_tempvar ("concat_len",
12807                                      ffecom_f2c_ftnlen_type_node,
12808                                      FFETARGET_charactersizeNONE, count);
12809             itmp
12810               = ffecom_make_tempvar ("concat_item",
12811                                      ffecom_f2c_address_type_node,
12812                                      FFETARGET_charactersizeNONE, count);
12813             result
12814               = ffecom_make_tempvar ("concat_res",
12815                                      char_type_node,
12816                                      ffecom_concat_list_maxlen_ (catlist),
12817                                      -1);
12818
12819             tempvar = make_tree_vec (3);
12820             TREE_VEC_ELT (tempvar, 0) = ltmp;
12821             TREE_VEC_ELT (tempvar, 1) = itmp;
12822             TREE_VEC_ELT (tempvar, 2) = result;
12823           }
12824
12825         for (i = 0; i < count; ++i)
12826           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12827                                                                     i));
12828
12829         ffecom_concat_list_kill_ (catlist);
12830
12831         if (tempvar)
12832           {
12833             ffebld_nonter_set_hook (expr, tempvar);
12834             current_binding_level->prep_state = 1;
12835           }
12836       }
12837       return;
12838
12839     case FFEBLD_opCONVERT:
12840       if (bt == FFEINFO_basictypeCHARACTER
12841           && ((ffebld_size_known (ffebld_left (expr))
12842                == FFETARGET_charactersizeNONE)
12843               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12844         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12845       break;
12846     }
12847
12848   if (tempvar)
12849     {
12850       ffebld_nonter_set_hook (expr, tempvar);
12851       current_binding_level->prep_state = 1;
12852     }
12853
12854   /* Prepare subexpressions for this expr.  */
12855
12856   switch (ffebld_op (expr))
12857     {
12858     case FFEBLD_opPERCENT_LOC:
12859       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12860       break;
12861
12862     case FFEBLD_opPERCENT_VAL:
12863     case FFEBLD_opPERCENT_REF:
12864       ffecom_prepare_expr (ffebld_left (expr));
12865       break;
12866
12867     case FFEBLD_opPERCENT_DESCR:
12868       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12869       break;
12870
12871     case FFEBLD_opITEM:
12872       {
12873         ffebld item;
12874
12875         for (item = expr;
12876              item != NULL;
12877              item = ffebld_trail (item))
12878           if (ffebld_head (item) != NULL)
12879             ffecom_prepare_expr (ffebld_head (item));
12880       }
12881       break;
12882
12883     default:
12884       /* Need to handle character conversion specially.  */
12885       switch (ffebld_arity (expr))
12886         {
12887         case 2:
12888           ffecom_prepare_expr (ffebld_left (expr));
12889           ffecom_prepare_expr (ffebld_right (expr));
12890           break;
12891
12892         case 1:
12893           ffecom_prepare_expr (ffebld_left (expr));
12894           break;
12895
12896         default:
12897           break;
12898         }
12899     }
12900
12901   return;
12902 }
12903
12904 /* Prepare expression for reading and writing.
12905
12906    Like ffecom_prepare_expr, except for expressions to be evaluated
12907    via ffecom_expr_rw.  */
12908
12909 void
12910 ffecom_prepare_expr_rw (tree type, ffebld expr)
12911 {
12912   /* This is all we support for now.  */
12913   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12914
12915   /* ~~For now, it seems to be the same thing.  */
12916   ffecom_prepare_expr (expr);
12917   return;
12918 }
12919
12920 /* Prepare expression for writing.
12921
12922    Like ffecom_prepare_expr, except for expressions to be evaluated
12923    via ffecom_expr_w.  */
12924
12925 void
12926 ffecom_prepare_expr_w (tree type, ffebld expr)
12927 {
12928   /* This is all we support for now.  */
12929   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12930
12931   /* ~~For now, it seems to be the same thing.  */
12932   ffecom_prepare_expr (expr);
12933   return;
12934 }
12935
12936 /* Prepare expression for returning.
12937
12938    Like ffecom_prepare_expr, except for expressions to be evaluated
12939    via ffecom_return_expr.  */
12940
12941 void
12942 ffecom_prepare_return_expr (ffebld expr)
12943 {
12944   assert (current_binding_level->prep_state < 2);
12945
12946   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12947       && ffecom_is_altreturning_
12948       && expr != NULL)
12949     ffecom_prepare_expr (expr);
12950 }
12951
12952 /* Prepare pointer to expression.
12953
12954    Like ffecom_prepare_expr, except for expressions to be evaluated
12955    via ffecom_ptr_to_expr.  */
12956
12957 void
12958 ffecom_prepare_ptr_to_expr (ffebld expr)
12959 {
12960   /* ~~For now, it seems to be the same thing.  */
12961   ffecom_prepare_expr (expr);
12962   return;
12963 }
12964
12965 /* Transform expression into constant pointer-to-expression tree.
12966
12967    If the expression can be transformed into a pointer-to-expression tree
12968    that is constant, that is done, and the tree returned.  Else NULL_TREE
12969    is returned.
12970
12971    That way, a caller can attempt to provide compile-time initialization
12972    of a variable and, if that fails, *then* choose to start a new block
12973    and resort to using temporaries, as appropriate.  */
12974
12975 tree
12976 ffecom_ptr_to_const_expr (ffebld expr)
12977 {
12978   if (! expr)
12979     return integer_zero_node;
12980
12981   if (ffebld_op (expr) == FFEBLD_opANY)
12982     return error_mark_node;
12983
12984   if (ffebld_arity (expr) == 0
12985       && (ffebld_op (expr) != FFEBLD_opSYMTER
12986           || ffebld_where (expr) == FFEINFO_whereCOMMON
12987           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12988           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12989     {
12990       tree t;
12991
12992       t = ffecom_ptr_to_expr (expr);
12993       assert (TREE_CONSTANT (t));
12994       return t;
12995     }
12996
12997   return NULL_TREE;
12998 }
12999
13000 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13001
13002    tree rtn;  // NULL_TREE means use expand_null_return()
13003    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13004    rtn = ffecom_return_expr(expr);
13005
13006    Based on the program unit type and other info (like return function
13007    type, return master function type when alternate ENTRY points,
13008    whether subroutine has any alternate RETURN points, etc), returns the
13009    appropriate expression to be returned to the caller, or NULL_TREE
13010    meaning no return value or the caller expects it to be returned somewhere
13011    else (which is handled by other parts of this module).  */
13012
13013 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13014 tree
13015 ffecom_return_expr (ffebld expr)
13016 {
13017   tree rtn;
13018
13019   switch (ffecom_primary_entry_kind_)
13020     {
13021     case FFEINFO_kindPROGRAM:
13022     case FFEINFO_kindBLOCKDATA:
13023       rtn = NULL_TREE;
13024       break;
13025
13026     case FFEINFO_kindSUBROUTINE:
13027       if (!ffecom_is_altreturning_)
13028         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13029       else if (expr == NULL)
13030         rtn = integer_zero_node;
13031       else
13032         rtn = ffecom_expr (expr);
13033       break;
13034
13035     case FFEINFO_kindFUNCTION:
13036       if ((ffecom_multi_retval_ != NULL_TREE)
13037           || (ffesymbol_basictype (ffecom_primary_entry_)
13038               == FFEINFO_basictypeCHARACTER)
13039           || ((ffesymbol_basictype (ffecom_primary_entry_)
13040                == FFEINFO_basictypeCOMPLEX)
13041               && (ffecom_num_entrypoints_ == 0)
13042               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13043         {                       /* Value is returned by direct assignment
13044                                    into (implicit) dummy. */
13045           rtn = NULL_TREE;
13046           break;
13047         }
13048       rtn = ffecom_func_result_;
13049 #if 0
13050       /* Spurious error if RETURN happens before first reference!  So elide
13051          this code.  In particular, for debugging registry, rtn should always
13052          be non-null after all, but TREE_USED won't be set until we encounter
13053          a reference in the code.  Perfectly okay (but weird) code that,
13054          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13055          this diagnostic for no reason.  Have people use -O -Wuninitialized
13056          and leave it to the back end to find obviously weird cases.  */
13057
13058       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13059          situation; if the return value has never been referenced, it won't
13060          have a tree under 2pass mode. */
13061       if ((rtn == NULL_TREE)
13062           || !TREE_USED (rtn))
13063         {
13064           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13065           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13066                        ffesymbol_where_column (ffecom_primary_entry_));
13067           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13068                                          (ffecom_primary_entry_)));
13069           ffebad_finish ();
13070         }
13071 #endif
13072       break;
13073
13074     default:
13075       assert ("bad unit kind" == NULL);
13076     case FFEINFO_kindANY:
13077       rtn = error_mark_node;
13078       break;
13079     }
13080
13081   return rtn;
13082 }
13083
13084 #endif
13085 /* Do save_expr only if tree is not error_mark_node.  */
13086
13087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13088 tree
13089 ffecom_save_tree (tree t)
13090 {
13091   return save_expr (t);
13092 }
13093 #endif
13094
13095 /* Start a compound statement (block).  */
13096
13097 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13098 void
13099 ffecom_start_compstmt (void)
13100 {
13101   bison_rule_pushlevel_ ();
13102 }
13103 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13104
13105 /* Public entry point for front end to access start_decl.  */
13106
13107 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13108 tree
13109 ffecom_start_decl (tree decl, bool is_initialized)
13110 {
13111   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13112   return start_decl (decl, FALSE);
13113 }
13114
13115 #endif
13116 /* ffecom_sym_commit -- Symbol's state being committed to reality
13117
13118    ffesymbol s;
13119    ffecom_sym_commit(s);
13120
13121    Does whatever the backend needs when a symbol is committed after having
13122    been backtrackable for a period of time.  */
13123
13124 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13125 void
13126 ffecom_sym_commit (ffesymbol s UNUSED)
13127 {
13128   assert (!ffesymbol_retractable ());
13129 }
13130
13131 #endif
13132 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13133
13134    ffecom_sym_end_transition();
13135
13136    Does backend-specific stuff and also calls ffest_sym_end_transition
13137    to do the necessary FFE stuff.
13138
13139    Backtracking is never enabled when this fn is called, so don't worry
13140    about it.  */
13141
13142 ffesymbol
13143 ffecom_sym_end_transition (ffesymbol s)
13144 {
13145   ffestorag st;
13146
13147   assert (!ffesymbol_retractable ());
13148
13149   s = ffest_sym_end_transition (s);
13150
13151 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13152   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13153       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13154     {
13155       ffecom_list_blockdata_
13156         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13157                                               FFEINTRIN_specNONE,
13158                                               FFEINTRIN_impNONE),
13159                            ffecom_list_blockdata_);
13160     }
13161 #endif
13162
13163   /* This is where we finally notice that a symbol has partial initialization
13164      and finalize it. */
13165
13166   if (ffesymbol_accretion (s) != NULL)
13167     {
13168       assert (ffesymbol_init (s) == NULL);
13169       ffecom_notify_init_symbol (s);
13170     }
13171   else if (((st = ffesymbol_storage (s)) != NULL)
13172            && ((st = ffestorag_parent (st)) != NULL)
13173            && (ffestorag_accretion (st) != NULL))
13174     {
13175       assert (ffestorag_init (st) == NULL);
13176       ffecom_notify_init_storage (st);
13177     }
13178
13179 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13180   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13181       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13182       && (ffesymbol_storage (s) != NULL))
13183     {
13184       ffecom_list_common_
13185         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13186                                               FFEINTRIN_specNONE,
13187                                               FFEINTRIN_impNONE),
13188                            ffecom_list_common_);
13189     }
13190 #endif
13191
13192   return s;
13193 }
13194
13195 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13196
13197    ffecom_sym_exec_transition();
13198
13199    Does backend-specific stuff and also calls ffest_sym_exec_transition
13200    to do the necessary FFE stuff.
13201
13202    See the long-winded description in ffecom_sym_learned for info
13203    on handling the situation where backtracking is inhibited.  */
13204
13205 ffesymbol
13206 ffecom_sym_exec_transition (ffesymbol s)
13207 {
13208   s = ffest_sym_exec_transition (s);
13209
13210   return s;
13211 }
13212
13213 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13214
13215    ffesymbol s;
13216    s = ffecom_sym_learned(s);
13217
13218    Called when a new symbol is seen after the exec transition or when more
13219    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13220    it arrives here is that all its latest info is updated already, so its
13221    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13222    field filled in if its gone through here or exec_transition first, and
13223    so on.
13224
13225    The backend probably wants to check ffesymbol_retractable() to see if
13226    backtracking is in effect.  If so, the FFE's changes to the symbol may
13227    be retracted (undone) or committed (ratified), at which time the
13228    appropriate ffecom_sym_retract or _commit function will be called
13229    for that function.
13230
13231    If the backend has its own backtracking mechanism, great, use it so that
13232    committal is a simple operation.  Though it doesn't make much difference,
13233    I suppose: the reason for tentative symbol evolution in the FFE is to
13234    enable error detection in weird incorrect statements early and to disable
13235    incorrect error detection on a correct statement.  The backend is not
13236    likely to introduce any information that'll get involved in these
13237    considerations, so it is probably just fine that the implementation
13238    model for this fn and for _exec_transition is to not do anything
13239    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13240    and instead wait until ffecom_sym_commit is called (which it never
13241    will be as long as we're using ambiguity-detecting statement analysis in
13242    the FFE, which we are initially to shake out the code, but don't depend
13243    on this), otherwise go ahead and do whatever is needed.
13244
13245    In essence, then, when this fn and _exec_transition get called while
13246    backtracking is enabled, a general mechanism would be to flag which (or
13247    both) of these were called (and in what order? neat question as to what
13248    might happen that I'm too lame to think through right now) and then when
13249    _commit is called reproduce the original calling sequence, if any, for
13250    the two fns (at which point backtracking will, of course, be disabled).  */
13251
13252 ffesymbol
13253 ffecom_sym_learned (ffesymbol s)
13254 {
13255   ffestorag_exec_layout (s);
13256
13257   return s;
13258 }
13259
13260 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13261
13262    ffesymbol s;
13263    ffecom_sym_retract(s);
13264
13265    Does whatever the backend needs when a symbol is retracted after having
13266    been backtrackable for a period of time.  */
13267
13268 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13269 void
13270 ffecom_sym_retract (ffesymbol s UNUSED)
13271 {
13272   assert (!ffesymbol_retractable ());
13273
13274 #if 0                           /* GCC doesn't commit any backtrackable sins,
13275                                    so nothing needed here. */
13276   switch (ffesymbol_hook (s).state)
13277     {
13278     case 0:                     /* nothing happened yet. */
13279       break;
13280
13281     case 1:                     /* exec transition happened. */
13282       break;
13283
13284     case 2:                     /* learned happened. */
13285       break;
13286
13287     case 3:                     /* learned then exec. */
13288       break;
13289
13290     case 4:                     /* exec then learned. */
13291       break;
13292
13293     default:
13294       assert ("bad hook state" == NULL);
13295       break;
13296     }
13297 #endif
13298 }
13299
13300 #endif
13301 /* Create temporary gcc label.  */
13302
13303 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13304 tree
13305 ffecom_temp_label ()
13306 {
13307   tree glabel;
13308   static int mynumber = 0;
13309
13310   glabel = build_decl (LABEL_DECL,
13311                        ffecom_get_invented_identifier ("__g77_label_%d",
13312                                                        mynumber++),
13313                        void_type_node);
13314   DECL_CONTEXT (glabel) = current_function_decl;
13315   DECL_MODE (glabel) = VOIDmode;
13316
13317   return glabel;
13318 }
13319
13320 #endif
13321 /* Return an expression that is usable as an arg in a conditional context
13322    (IF, DO WHILE, .NOT., and so on).
13323
13324    Use the one provided for the back end as of >2.6.0.  */
13325
13326 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13327 tree
13328 ffecom_truth_value (tree expr)
13329 {
13330   return truthvalue_conversion (expr);
13331 }
13332
13333 #endif
13334 /* Return the inversion of a truth value (the inversion of what
13335    ffecom_truth_value builds).
13336
13337    Apparently invert_truthvalue, which is properly in the back end, is
13338    enough for now, so just use it.  */
13339
13340 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13341 tree
13342 ffecom_truth_value_invert (tree expr)
13343 {
13344   return invert_truthvalue (ffecom_truth_value (expr));
13345 }
13346
13347 #endif
13348
13349 /* Return the tree that is the type of the expression, as would be
13350    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13351    transforming the expression, generating temporaries, etc.  */
13352
13353 tree
13354 ffecom_type_expr (ffebld expr)
13355 {
13356   ffeinfoBasictype bt;
13357   ffeinfoKindtype kt;
13358   tree tree_type;
13359
13360   assert (expr != NULL);
13361
13362   bt = ffeinfo_basictype (ffebld_info (expr));
13363   kt = ffeinfo_kindtype (ffebld_info (expr));
13364   tree_type = ffecom_tree_type[bt][kt];
13365
13366   switch (ffebld_op (expr))
13367     {
13368     case FFEBLD_opCONTER:
13369     case FFEBLD_opSYMTER:
13370     case FFEBLD_opARRAYREF:
13371     case FFEBLD_opUPLUS:
13372     case FFEBLD_opPAREN:
13373     case FFEBLD_opUMINUS:
13374     case FFEBLD_opADD:
13375     case FFEBLD_opSUBTRACT:
13376     case FFEBLD_opMULTIPLY:
13377     case FFEBLD_opDIVIDE:
13378     case FFEBLD_opPOWER:
13379     case FFEBLD_opNOT:
13380     case FFEBLD_opFUNCREF:
13381     case FFEBLD_opSUBRREF:
13382     case FFEBLD_opAND:
13383     case FFEBLD_opOR:
13384     case FFEBLD_opXOR:
13385     case FFEBLD_opNEQV:
13386     case FFEBLD_opEQV:
13387     case FFEBLD_opCONVERT:
13388     case FFEBLD_opLT:
13389     case FFEBLD_opLE:
13390     case FFEBLD_opEQ:
13391     case FFEBLD_opNE:
13392     case FFEBLD_opGT:
13393     case FFEBLD_opGE:
13394     case FFEBLD_opPERCENT_LOC:
13395       return tree_type;
13396
13397     case FFEBLD_opACCTER:
13398     case FFEBLD_opARRTER:
13399     case FFEBLD_opITEM:
13400     case FFEBLD_opSTAR:
13401     case FFEBLD_opBOUNDS:
13402     case FFEBLD_opREPEAT:
13403     case FFEBLD_opLABTER:
13404     case FFEBLD_opLABTOK:
13405     case FFEBLD_opIMPDO:
13406     case FFEBLD_opCONCATENATE:
13407     case FFEBLD_opSUBSTR:
13408     default:
13409       assert ("bad op for ffecom_type_expr" == NULL);
13410       /* Fall through. */
13411     case FFEBLD_opANY:
13412       return error_mark_node;
13413     }
13414 }
13415
13416 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13417
13418    If the PARM_DECL already exists, return it, else create it.  It's an
13419    integer_type_node argument for the master function that implements a
13420    subroutine or function with more than one entrypoint and is bound at
13421    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13422    first ENTRY statement, and so on).  */
13423
13424 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13425 tree
13426 ffecom_which_entrypoint_decl ()
13427 {
13428   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13429
13430   return ffecom_which_entrypoint_decl_;
13431 }
13432
13433 #endif
13434 \f
13435 /* The following sections consists of private and public functions
13436    that have the same names and perform roughly the same functions
13437    as counterparts in the C front end.  Changes in the C front end
13438    might affect how things should be done here.  Only functions
13439    needed by the back end should be public here; the rest should
13440    be private (static in the C sense).  Functions needed by other
13441    g77 front-end modules should be accessed by them via public
13442    ffecom_* names, which should themselves call private versions
13443    in this section so the private versions are easy to recognize
13444    when upgrading to a new gcc and finding interesting changes
13445    in the front end.
13446
13447    Functions named after rule "foo:" in c-parse.y are named
13448    "bison_rule_foo_" so they are easy to find.  */
13449
13450 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13451
13452 static void
13453 bison_rule_pushlevel_ ()
13454 {
13455   emit_line_note (input_filename, lineno);
13456   pushlevel (0);
13457   clear_last_expr ();
13458   expand_start_bindings (0);
13459 }
13460
13461 static tree
13462 bison_rule_compstmt_ ()
13463 {
13464   tree t;
13465   int keep = kept_level_p ();
13466
13467   /* Make the temps go away.  */
13468   if (! keep)
13469     current_binding_level->names = NULL_TREE;
13470
13471   emit_line_note (input_filename, lineno);
13472   expand_end_bindings (getdecls (), keep, 0);
13473   t = poplevel (keep, 1, 0);
13474
13475   return t;
13476 }
13477
13478 /* Return a definition for a builtin function named NAME and whose data type
13479    is TYPE.  TYPE should be a function type with argument types.
13480    FUNCTION_CODE tells later passes how to compile calls to this function.
13481    See tree.h for its possible values.
13482
13483    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13484    the name to be called if we can't opencode the function.  */
13485
13486 tree
13487 builtin_function (const char *name, tree type, int function_code,
13488                   enum built_in_class class,
13489                   const char *library_name)
13490 {
13491   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13492   DECL_EXTERNAL (decl) = 1;
13493   TREE_PUBLIC (decl) = 1;
13494   if (library_name)
13495     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13496   make_decl_rtl (decl, NULL_PTR);
13497   pushdecl (decl);
13498   DECL_BUILT_IN_CLASS (decl) = class;
13499   DECL_FUNCTION_CODE (decl) = function_code;
13500
13501   return decl;
13502 }
13503
13504 /* Handle when a new declaration NEWDECL
13505    has the same name as an old one OLDDECL
13506    in the same binding contour.
13507    Prints an error message if appropriate.
13508
13509    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13510    Otherwise, return 0.  */
13511
13512 static int
13513 duplicate_decls (tree newdecl, tree olddecl)
13514 {
13515   int types_match = 1;
13516   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13517                            && DECL_INITIAL (newdecl) != 0);
13518   tree oldtype = TREE_TYPE (olddecl);
13519   tree newtype = TREE_TYPE (newdecl);
13520
13521   if (olddecl == newdecl)
13522     return 1;
13523
13524   if (TREE_CODE (newtype) == ERROR_MARK
13525       || TREE_CODE (oldtype) == ERROR_MARK)
13526     types_match = 0;
13527
13528   /* New decl is completely inconsistent with the old one =>
13529      tell caller to replace the old one.
13530      This is always an error except in the case of shadowing a builtin.  */
13531   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13532     return 0;
13533
13534   /* For real parm decl following a forward decl,
13535      return 1 so old decl will be reused.  */
13536   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13537       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13538     return 1;
13539
13540   /* The new declaration is the same kind of object as the old one.
13541      The declarations may partially match.  Print warnings if they don't
13542      match enough.  Ultimately, copy most of the information from the new
13543      decl to the old one, and keep using the old one.  */
13544
13545   if (TREE_CODE (olddecl) == FUNCTION_DECL
13546       && DECL_BUILT_IN (olddecl))
13547     {
13548       /* A function declaration for a built-in function.  */
13549       if (!TREE_PUBLIC (newdecl))
13550         return 0;
13551       else if (!types_match)
13552         {
13553           /* Accept the return type of the new declaration if same modes.  */
13554           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13555           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13556
13557           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13558             {
13559               /* Function types may be shared, so we can't just modify
13560                  the return type of olddecl's function type.  */
13561               tree newtype
13562                 = build_function_type (newreturntype,
13563                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13564
13565               types_match = 1;
13566               if (types_match)
13567                 TREE_TYPE (olddecl) = newtype;
13568             }
13569         }
13570       if (!types_match)
13571         return 0;
13572     }
13573   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13574            && DECL_SOURCE_LINE (olddecl) == 0)
13575     {
13576       /* A function declaration for a predeclared function
13577          that isn't actually built in.  */
13578       if (!TREE_PUBLIC (newdecl))
13579         return 0;
13580       else if (!types_match)
13581         {
13582           /* If the types don't match, preserve volatility indication.
13583              Later on, we will discard everything else about the
13584              default declaration.  */
13585           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13586         }
13587     }
13588
13589   /* Copy all the DECL_... slots specified in the new decl
13590      except for any that we copy here from the old type.
13591
13592      Past this point, we don't change OLDTYPE and NEWTYPE
13593      even if we change the types of NEWDECL and OLDDECL.  */
13594
13595   if (types_match)
13596     {
13597       /* Merge the data types specified in the two decls.  */
13598       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13599         TREE_TYPE (newdecl)
13600           = TREE_TYPE (olddecl)
13601             = TREE_TYPE (newdecl);
13602
13603       /* Lay the type out, unless already done.  */
13604       if (oldtype != TREE_TYPE (newdecl))
13605         {
13606           if (TREE_TYPE (newdecl) != error_mark_node)
13607             layout_type (TREE_TYPE (newdecl));
13608           if (TREE_CODE (newdecl) != FUNCTION_DECL
13609               && TREE_CODE (newdecl) != TYPE_DECL
13610               && TREE_CODE (newdecl) != CONST_DECL)
13611             layout_decl (newdecl, 0);
13612         }
13613       else
13614         {
13615           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13616           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13617           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13618           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13619             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13620               {
13621                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13622                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13623               }
13624         }
13625
13626       /* Keep the old rtl since we can safely use it.  */
13627       COPY_DECL_RTL (olddecl, newdecl);
13628
13629       /* Merge the type qualifiers.  */
13630       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13631           && !TREE_THIS_VOLATILE (newdecl))
13632         TREE_THIS_VOLATILE (olddecl) = 0;
13633       if (TREE_READONLY (newdecl))
13634         TREE_READONLY (olddecl) = 1;
13635       if (TREE_THIS_VOLATILE (newdecl))
13636         {
13637           TREE_THIS_VOLATILE (olddecl) = 1;
13638           if (TREE_CODE (newdecl) == VAR_DECL)
13639             make_var_volatile (newdecl);
13640         }
13641
13642       /* Keep source location of definition rather than declaration.
13643          Likewise, keep decl at outer scope.  */
13644       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13645           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13646         {
13647           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13648           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13649
13650           if (DECL_CONTEXT (olddecl) == 0
13651               && TREE_CODE (newdecl) != FUNCTION_DECL)
13652             DECL_CONTEXT (newdecl) = 0;
13653         }
13654
13655       /* Merge the unused-warning information.  */
13656       if (DECL_IN_SYSTEM_HEADER (olddecl))
13657         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13658       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13659         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13660
13661       /* Merge the initialization information.  */
13662       if (DECL_INITIAL (newdecl) == 0)
13663         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13664
13665       /* Merge the section attribute.
13666          We want to issue an error if the sections conflict but that must be
13667          done later in decl_attributes since we are called before attributes
13668          are assigned.  */
13669       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13670         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13671
13672 #if BUILT_FOR_270
13673       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13674         {
13675           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13676           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13677         }
13678 #endif
13679     }
13680   /* If cannot merge, then use the new type and qualifiers,
13681      and don't preserve the old rtl.  */
13682   else
13683     {
13684       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13685       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13686       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13687       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13688     }
13689
13690   /* Merge the storage class information.  */
13691   /* For functions, static overrides non-static.  */
13692   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13693     {
13694       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13695       /* This is since we don't automatically
13696          copy the attributes of NEWDECL into OLDDECL.  */
13697       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13698       /* If this clears `static', clear it in the identifier too.  */
13699       if (! TREE_PUBLIC (olddecl))
13700         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13701     }
13702   if (DECL_EXTERNAL (newdecl))
13703     {
13704       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13705       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13706       /* An extern decl does not override previous storage class.  */
13707       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13708     }
13709   else
13710     {
13711       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13712       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13713     }
13714
13715   /* If either decl says `inline', this fn is inline,
13716      unless its definition was passed already.  */
13717   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13718     DECL_INLINE (olddecl) = 1;
13719   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13720
13721   /* Get rid of any built-in function if new arg types don't match it
13722      or if we have a function definition.  */
13723   if (TREE_CODE (newdecl) == FUNCTION_DECL
13724       && DECL_BUILT_IN (olddecl)
13725       && (!types_match || new_is_definition))
13726     {
13727       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13728       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13729     }
13730
13731   /* If redeclaring a builtin function, and not a definition,
13732      it stays built in.
13733      Also preserve various other info from the definition.  */
13734   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13735     {
13736       if (DECL_BUILT_IN (olddecl))
13737         {
13738           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13739           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13740         }
13741
13742       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13743       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13744       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13745       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13746     }
13747
13748   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13749      But preserve olddecl's DECL_UID.  */
13750   {
13751     register unsigned olddecl_uid = DECL_UID (olddecl);
13752
13753     memcpy ((char *) olddecl + sizeof (struct tree_common),
13754             (char *) newdecl + sizeof (struct tree_common),
13755             sizeof (struct tree_decl) - sizeof (struct tree_common));
13756     DECL_UID (olddecl) = olddecl_uid;
13757   }
13758
13759   return 1;
13760 }
13761
13762 /* Finish processing of a declaration;
13763    install its initial value.
13764    If the length of an array type is not known before,
13765    it must be determined now, from the initial value, or it is an error.  */
13766
13767 static void
13768 finish_decl (tree decl, tree init, bool is_top_level)
13769 {
13770   register tree type = TREE_TYPE (decl);
13771   int was_incomplete = (DECL_SIZE (decl) == 0);
13772   bool at_top_level = (current_binding_level == global_binding_level);
13773   bool top_level = is_top_level || at_top_level;
13774
13775   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13776      level anyway.  */
13777   assert (!is_top_level || !at_top_level);
13778
13779   if (TREE_CODE (decl) == PARM_DECL)
13780     assert (init == NULL_TREE);
13781   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13782      overlaps DECL_ARG_TYPE.  */
13783   else if (init == NULL_TREE)
13784     assert (DECL_INITIAL (decl) == NULL_TREE);
13785   else
13786     assert (DECL_INITIAL (decl) == error_mark_node);
13787
13788   if (init != NULL_TREE)
13789     {
13790       if (TREE_CODE (decl) != TYPE_DECL)
13791         DECL_INITIAL (decl) = init;
13792       else
13793         {
13794           /* typedef foo = bar; store the type of bar as the type of foo.  */
13795           TREE_TYPE (decl) = TREE_TYPE (init);
13796           DECL_INITIAL (decl) = init = 0;
13797         }
13798     }
13799
13800   /* Deduce size of array from initialization, if not already known */
13801
13802   if (TREE_CODE (type) == ARRAY_TYPE
13803       && TYPE_DOMAIN (type) == 0
13804       && TREE_CODE (decl) != TYPE_DECL)
13805     {
13806       assert (top_level);
13807       assert (was_incomplete);
13808
13809       layout_decl (decl, 0);
13810     }
13811
13812   if (TREE_CODE (decl) == VAR_DECL)
13813     {
13814       if (DECL_SIZE (decl) == NULL_TREE
13815           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13816         layout_decl (decl, 0);
13817
13818       if (DECL_SIZE (decl) == NULL_TREE
13819           && (TREE_STATIC (decl)
13820               ?
13821       /* A static variable with an incomplete type is an error if it is
13822          initialized. Also if it is not file scope. Otherwise, let it
13823          through, but if it is not `extern' then it may cause an error
13824          message later.  */
13825               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13826               :
13827       /* An automatic variable with an incomplete type is an error.  */
13828               !DECL_EXTERNAL (decl)))
13829         {
13830           assert ("storage size not known" == NULL);
13831           abort ();
13832         }
13833
13834       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13835           && (DECL_SIZE (decl) != 0)
13836           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13837         {
13838           assert ("storage size not constant" == NULL);
13839           abort ();
13840         }
13841     }
13842
13843   /* Output the assembler code and/or RTL code for variables and functions,
13844      unless the type is an undefined structure or union. If not, it will get
13845      done when the type is completed.  */
13846
13847   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13848     {
13849       rest_of_decl_compilation (decl, NULL,
13850                                 DECL_CONTEXT (decl) == 0,
13851                                 0);
13852
13853       if (DECL_CONTEXT (decl) != 0)
13854         {
13855           /* Recompute the RTL of a local array now if it used to be an
13856              incomplete type.  */
13857           if (was_incomplete
13858               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13859             {
13860               /* If we used it already as memory, it must stay in memory.  */
13861               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13862               /* If it's still incomplete now, no init will save it.  */
13863               if (DECL_SIZE (decl) == 0)
13864                 DECL_INITIAL (decl) = 0;
13865               expand_decl (decl);
13866             }
13867           /* Compute and store the initial value.  */
13868           if (TREE_CODE (decl) != FUNCTION_DECL)
13869             expand_decl_init (decl);
13870         }
13871     }
13872   else if (TREE_CODE (decl) == TYPE_DECL)
13873     {
13874       rest_of_decl_compilation (decl, NULL_PTR,
13875                                 DECL_CONTEXT (decl) == 0,
13876                                 0);
13877     }
13878
13879   /* At the end of a declaration, throw away any variable type sizes of types
13880      defined inside that declaration.  There is no use computing them in the
13881      following function definition.  */
13882   if (current_binding_level == global_binding_level)
13883     get_pending_sizes ();
13884 }
13885
13886 /* Finish up a function declaration and compile that function
13887    all the way to assembler language output.  The free the storage
13888    for the function definition.
13889
13890    This is called after parsing the body of the function definition.
13891
13892    NESTED is nonzero if the function being finished is nested in another.  */
13893
13894 static void
13895 finish_function (int nested)
13896 {
13897   register tree fndecl = current_function_decl;
13898
13899   assert (fndecl != NULL_TREE);
13900   if (TREE_CODE (fndecl) != ERROR_MARK)
13901     {
13902       if (nested)
13903         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13904       else
13905         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13906     }
13907
13908 /*  TREE_READONLY (fndecl) = 1;
13909     This caused &foo to be of type ptr-to-const-function
13910     which then got a warning when stored in a ptr-to-function variable.  */
13911
13912   poplevel (1, 0, 1);
13913
13914   if (TREE_CODE (fndecl) != ERROR_MARK)
13915     {
13916       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13917
13918       /* Must mark the RESULT_DECL as being in this function.  */
13919
13920       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13921
13922       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13923       /* Generate rtl for function exit.  */
13924       expand_function_end (input_filename, lineno, 0);
13925
13926       /* If this is a nested function, protect the local variables in the stack
13927          above us from being collected while we're compiling this function.  */
13928       if (nested)
13929         ggc_push_context ();
13930
13931       /* Run the optimizers and output the assembler code for this function.  */
13932       rest_of_compilation (fndecl);
13933
13934       /* Undo the GC context switch.  */
13935       if (nested)
13936         ggc_pop_context ();
13937     }
13938
13939   if (TREE_CODE (fndecl) != ERROR_MARK
13940       && !nested
13941       && DECL_SAVED_INSNS (fndecl) == 0)
13942     {
13943       /* Stop pointing to the local nodes about to be freed.  */
13944       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13945          function definition.  */
13946       /* For a nested function, this is done in pop_f_function_context.  */
13947       /* If rest_of_compilation set this to 0, leave it 0.  */
13948       if (DECL_INITIAL (fndecl) != 0)
13949         DECL_INITIAL (fndecl) = error_mark_node;
13950       DECL_ARGUMENTS (fndecl) = 0;
13951     }
13952
13953   if (!nested)
13954     {
13955       /* Let the error reporting routines know that we're outside a function.
13956          For a nested function, this value is used in pop_c_function_context
13957          and then reset via pop_function_context.  */
13958       ffecom_outer_function_decl_ = current_function_decl = NULL;
13959     }
13960 }
13961
13962 /* Plug-in replacement for identifying the name of a decl and, for a
13963    function, what we call it in diagnostics.  For now, "program unit"
13964    should suffice, since it's a bit of a hassle to figure out which
13965    of several kinds of things it is.  Note that it could conceivably
13966    be a statement function, which probably isn't really a program unit
13967    per se, but if that comes up, it should be easy to check (being a
13968    nested function and all).  */
13969
13970 static const char *
13971 lang_printable_name (tree decl, int v)
13972 {
13973   /* Just to keep GCC quiet about the unused variable.
13974      In theory, differing values of V should produce different
13975      output.  */
13976   switch (v)
13977     {
13978     default:
13979       if (TREE_CODE (decl) == ERROR_MARK)
13980         return "erroneous code";
13981       return IDENTIFIER_POINTER (DECL_NAME (decl));
13982     }
13983 }
13984
13985 /* g77's function to print out name of current function that caused
13986    an error.  */
13987
13988 #if BUILT_FOR_270
13989 static void
13990 lang_print_error_function (const char *file)
13991 {
13992   static ffeglobal last_g = NULL;
13993   static ffesymbol last_s = NULL;
13994   ffeglobal g;
13995   ffesymbol s;
13996   const char *kind;
13997
13998   if ((ffecom_primary_entry_ == NULL)
13999       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14000     {
14001       g = NULL;
14002       s = NULL;
14003       kind = NULL;
14004     }
14005   else
14006     {
14007       g = ffesymbol_global (ffecom_primary_entry_);
14008       if (ffecom_nested_entry_ == NULL)
14009         {
14010           s = ffecom_primary_entry_;
14011           switch (ffesymbol_kind (s))
14012             {
14013             case FFEINFO_kindFUNCTION:
14014               kind = "function";
14015               break;
14016
14017             case FFEINFO_kindSUBROUTINE:
14018               kind = "subroutine";
14019               break;
14020
14021             case FFEINFO_kindPROGRAM:
14022               kind = "program";
14023               break;
14024
14025             case FFEINFO_kindBLOCKDATA:
14026               kind = "block-data";
14027               break;
14028
14029             default:
14030               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14031               break;
14032             }
14033         }
14034       else
14035         {
14036           s = ffecom_nested_entry_;
14037           kind = "statement function";
14038         }
14039     }
14040
14041   if ((last_g != g) || (last_s != s))
14042     {
14043       if (file)
14044         fprintf (stderr, "%s: ", file);
14045
14046       if (s == NULL)
14047         fprintf (stderr, "Outside of any program unit:\n");
14048       else
14049         {
14050           const char *name = ffesymbol_text (s);
14051
14052           fprintf (stderr, "In %s `%s':\n", kind, name);
14053         }
14054
14055       last_g = g;
14056       last_s = s;
14057     }
14058 }
14059 #endif
14060
14061 /* Similar to `lookup_name' but look only at current binding level.  */
14062
14063 static tree
14064 lookup_name_current_level (tree name)
14065 {
14066   register tree t;
14067
14068   if (current_binding_level == global_binding_level)
14069     return IDENTIFIER_GLOBAL_VALUE (name);
14070
14071   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14072     return 0;
14073
14074   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14075     if (DECL_NAME (t) == name)
14076       break;
14077
14078   return t;
14079 }
14080
14081 /* Create a new `struct binding_level'.  */
14082
14083 static struct binding_level *
14084 make_binding_level ()
14085 {
14086   /* NOSTRICT */
14087   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14088 }
14089
14090 /* Save and restore the variables in this file and elsewhere
14091    that keep track of the progress of compilation of the current function.
14092    Used for nested functions.  */
14093
14094 struct f_function
14095 {
14096   struct f_function *next;
14097   tree named_labels;
14098   tree shadowed_labels;
14099   struct binding_level *binding_level;
14100 };
14101
14102 struct f_function *f_function_chain;
14103
14104 /* Restore the variables used during compilation of a C function.  */
14105
14106 static void
14107 pop_f_function_context ()
14108 {
14109   struct f_function *p = f_function_chain;
14110   tree link;
14111
14112   /* Bring back all the labels that were shadowed.  */
14113   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14114     if (DECL_NAME (TREE_VALUE (link)) != 0)
14115       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14116         = TREE_VALUE (link);
14117
14118   if (current_function_decl != error_mark_node
14119       && DECL_SAVED_INSNS (current_function_decl) == 0)
14120     {
14121       /* Stop pointing to the local nodes about to be freed.  */
14122       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14123          function definition.  */
14124       DECL_INITIAL (current_function_decl) = error_mark_node;
14125       DECL_ARGUMENTS (current_function_decl) = 0;
14126     }
14127
14128   pop_function_context ();
14129
14130   f_function_chain = p->next;
14131
14132   named_labels = p->named_labels;
14133   shadowed_labels = p->shadowed_labels;
14134   current_binding_level = p->binding_level;
14135
14136   free (p);
14137 }
14138
14139 /* Save and reinitialize the variables
14140    used during compilation of a C function.  */
14141
14142 static void
14143 push_f_function_context ()
14144 {
14145   struct f_function *p
14146   = (struct f_function *) xmalloc (sizeof (struct f_function));
14147
14148   push_function_context ();
14149
14150   p->next = f_function_chain;
14151   f_function_chain = p;
14152
14153   p->named_labels = named_labels;
14154   p->shadowed_labels = shadowed_labels;
14155   p->binding_level = current_binding_level;
14156 }
14157
14158 static void
14159 push_parm_decl (tree parm)
14160 {
14161   int old_immediate_size_expand = immediate_size_expand;
14162
14163   /* Don't try computing parm sizes now -- wait till fn is called.  */
14164
14165   immediate_size_expand = 0;
14166
14167   /* Fill in arg stuff.  */
14168
14169   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14170   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14171   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14172
14173   parm = pushdecl (parm);
14174
14175   immediate_size_expand = old_immediate_size_expand;
14176
14177   finish_decl (parm, NULL_TREE, FALSE);
14178 }
14179
14180 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14181
14182 static tree
14183 pushdecl_top_level (x)
14184      tree x;
14185 {
14186   register tree t;
14187   register struct binding_level *b = current_binding_level;
14188   register tree f = current_function_decl;
14189
14190   current_binding_level = global_binding_level;
14191   current_function_decl = NULL_TREE;
14192   t = pushdecl (x);
14193   current_binding_level = b;
14194   current_function_decl = f;
14195   return t;
14196 }
14197
14198 /* Store the list of declarations of the current level.
14199    This is done for the parameter declarations of a function being defined,
14200    after they are modified in the light of any missing parameters.  */
14201
14202 static tree
14203 storedecls (decls)
14204      tree decls;
14205 {
14206   return current_binding_level->names = decls;
14207 }
14208
14209 /* Store the parameter declarations into the current function declaration.
14210    This is called after parsing the parameter declarations, before
14211    digesting the body of the function.
14212
14213    For an old-style definition, modify the function's type
14214    to specify at least the number of arguments.  */
14215
14216 static void
14217 store_parm_decls (int is_main_program UNUSED)
14218 {
14219   register tree fndecl = current_function_decl;
14220
14221   if (fndecl == error_mark_node)
14222     return;
14223
14224   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14225   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14226
14227   /* Initialize the RTL code for the function.  */
14228
14229   init_function_start (fndecl, input_filename, lineno);
14230
14231   /* Set up parameters and prepare for return, for the function.  */
14232
14233   expand_function_start (fndecl, 0);
14234 }
14235
14236 static tree
14237 start_decl (tree decl, bool is_top_level)
14238 {
14239   register tree tem;
14240   bool at_top_level = (current_binding_level == global_binding_level);
14241   bool top_level = is_top_level || at_top_level;
14242
14243   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14244      level anyway.  */
14245   assert (!is_top_level || !at_top_level);
14246
14247   if (DECL_INITIAL (decl) != NULL_TREE)
14248     {
14249       assert (DECL_INITIAL (decl) == error_mark_node);
14250       assert (!DECL_EXTERNAL (decl));
14251     }
14252   else if (top_level)
14253     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14254
14255   /* For Fortran, we by default put things in .common when possible.  */
14256   DECL_COMMON (decl) = 1;
14257
14258   /* Add this decl to the current binding level. TEM may equal DECL or it may
14259      be a previous decl of the same name.  */
14260   if (is_top_level)
14261     tem = pushdecl_top_level (decl);
14262   else
14263     tem = pushdecl (decl);
14264
14265   /* For a local variable, define the RTL now.  */
14266   if (!top_level
14267   /* But not if this is a duplicate decl and we preserved the rtl from the
14268      previous one (which may or may not happen).  */
14269       && !DECL_RTL_SET_P (tem))
14270     {
14271       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14272         expand_decl (tem);
14273       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14274                && DECL_INITIAL (tem) != 0)
14275         expand_decl (tem);
14276     }
14277
14278   return tem;
14279 }
14280
14281 /* Create the FUNCTION_DECL for a function definition.
14282    DECLSPECS and DECLARATOR are the parts of the declaration;
14283    they describe the function's name and the type it returns,
14284    but twisted together in a fashion that parallels the syntax of C.
14285
14286    This function creates a binding context for the function body
14287    as well as setting up the FUNCTION_DECL in current_function_decl.
14288
14289    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14290    (it defines a datum instead), we return 0, which tells
14291    yyparse to report a parse error.
14292
14293    NESTED is nonzero for a function nested within another function.  */
14294
14295 static void
14296 start_function (tree name, tree type, int nested, int public)
14297 {
14298   tree decl1;
14299   tree restype;
14300   int old_immediate_size_expand = immediate_size_expand;
14301
14302   named_labels = 0;
14303   shadowed_labels = 0;
14304
14305   /* Don't expand any sizes in the return type of the function.  */
14306   immediate_size_expand = 0;
14307
14308   if (nested)
14309     {
14310       assert (!public);
14311       assert (current_function_decl != NULL_TREE);
14312       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14313     }
14314   else
14315     {
14316       assert (current_function_decl == NULL_TREE);
14317     }
14318
14319   if (TREE_CODE (type) == ERROR_MARK)
14320     decl1 = current_function_decl = error_mark_node;
14321   else
14322     {
14323       decl1 = build_decl (FUNCTION_DECL,
14324                           name,
14325                           type);
14326       TREE_PUBLIC (decl1) = public ? 1 : 0;
14327       if (nested)
14328         DECL_INLINE (decl1) = 1;
14329       TREE_STATIC (decl1) = 1;
14330       DECL_EXTERNAL (decl1) = 0;
14331
14332       announce_function (decl1);
14333
14334       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14335          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14336       DECL_INITIAL (decl1) = error_mark_node;
14337
14338       /* Record the decl so that the function name is defined. If we already have
14339          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14340
14341       current_function_decl = pushdecl (decl1);
14342     }
14343
14344   if (!nested)
14345     ffecom_outer_function_decl_ = current_function_decl;
14346
14347   pushlevel (0);
14348   current_binding_level->prep_state = 2;
14349
14350   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14351     {
14352       make_decl_rtl (current_function_decl, NULL);
14353
14354       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14355       DECL_RESULT (current_function_decl)
14356         = build_decl (RESULT_DECL, NULL_TREE, restype);
14357     }
14358
14359   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14360     TREE_ADDRESSABLE (current_function_decl) = 1;
14361
14362   immediate_size_expand = old_immediate_size_expand;
14363 }
14364 \f
14365 /* Here are the public functions the GNU back end needs.  */
14366
14367 tree
14368 convert (type, expr)
14369      tree type, expr;
14370 {
14371   register tree e = expr;
14372   register enum tree_code code = TREE_CODE (type);
14373
14374   if (type == TREE_TYPE (e)
14375       || TREE_CODE (e) == ERROR_MARK)
14376     return e;
14377   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14378     return fold (build1 (NOP_EXPR, type, e));
14379   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14380       || code == ERROR_MARK)
14381     return error_mark_node;
14382   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14383     {
14384       assert ("void value not ignored as it ought to be" == NULL);
14385       return error_mark_node;
14386     }
14387   if (code == VOID_TYPE)
14388     return build1 (CONVERT_EXPR, type, e);
14389   if ((code != RECORD_TYPE)
14390       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14391     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14392                   e);
14393   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14394     return fold (convert_to_integer (type, e));
14395   if (code == POINTER_TYPE)
14396     return fold (convert_to_pointer (type, e));
14397   if (code == REAL_TYPE)
14398     return fold (convert_to_real (type, e));
14399   if (code == COMPLEX_TYPE)
14400     return fold (convert_to_complex (type, e));
14401   if (code == RECORD_TYPE)
14402     return fold (ffecom_convert_to_complex_ (type, e));
14403
14404   assert ("conversion to non-scalar type requested" == NULL);
14405   return error_mark_node;
14406 }
14407
14408 /* integrate_decl_tree calls this function, but since we don't use the
14409    DECL_LANG_SPECIFIC field, this is a no-op.  */
14410
14411 void
14412 copy_lang_decl (node)
14413      tree node UNUSED;
14414 {
14415 }
14416
14417 /* Return the list of declarations of the current level.
14418    Note that this list is in reverse order unless/until
14419    you nreverse it; and when you do nreverse it, you must
14420    store the result back using `storedecls' or you will lose.  */
14421
14422 tree
14423 getdecls ()
14424 {
14425   return current_binding_level->names;
14426 }
14427
14428 /* Nonzero if we are currently in the global binding level.  */
14429
14430 int
14431 global_bindings_p ()
14432 {
14433   return current_binding_level == global_binding_level;
14434 }
14435
14436 /* Print an error message for invalid use of an incomplete type.
14437    VALUE is the expression that was used (or 0 if that isn't known)
14438    and TYPE is the type that was invalid.  */
14439
14440 void
14441 incomplete_type_error (value, type)
14442      tree value UNUSED;
14443      tree type;
14444 {
14445   if (TREE_CODE (type) == ERROR_MARK)
14446     return;
14447
14448   assert ("incomplete type?!?" == NULL);
14449 }
14450
14451 /* Mark ARG for GC.  */
14452 static void
14453 mark_binding_level (void *arg)
14454 {
14455   struct binding_level *level = *(struct binding_level **) arg;
14456
14457   while (level)
14458     {
14459       ggc_mark_tree (level->names);
14460       ggc_mark_tree (level->blocks);
14461       ggc_mark_tree (level->this_block);
14462       level = level->level_chain;
14463     }
14464 }
14465
14466 void
14467 init_decl_processing ()
14468 {
14469   static tree *const tree_roots[] = {
14470     &current_function_decl,
14471     &string_type_node,
14472     &ffecom_tree_fun_type_void,
14473     &ffecom_integer_zero_node,
14474     &ffecom_integer_one_node,
14475     &ffecom_tree_subr_type,
14476     &ffecom_tree_ptr_to_subr_type,
14477     &ffecom_tree_blockdata_type,
14478     &ffecom_tree_xargc_,
14479     &ffecom_f2c_integer_type_node,
14480     &ffecom_f2c_ptr_to_integer_type_node,
14481     &ffecom_f2c_address_type_node,
14482     &ffecom_f2c_real_type_node,
14483     &ffecom_f2c_ptr_to_real_type_node,
14484     &ffecom_f2c_doublereal_type_node,
14485     &ffecom_f2c_complex_type_node,
14486     &ffecom_f2c_doublecomplex_type_node,
14487     &ffecom_f2c_longint_type_node,
14488     &ffecom_f2c_logical_type_node,
14489     &ffecom_f2c_flag_type_node,
14490     &ffecom_f2c_ftnlen_type_node,
14491     &ffecom_f2c_ftnlen_zero_node,
14492     &ffecom_f2c_ftnlen_one_node,
14493     &ffecom_f2c_ftnlen_two_node,
14494     &ffecom_f2c_ptr_to_ftnlen_type_node,
14495     &ffecom_f2c_ftnint_type_node,
14496     &ffecom_f2c_ptr_to_ftnint_type_node,
14497     &ffecom_outer_function_decl_,
14498     &ffecom_previous_function_decl_,
14499     &ffecom_which_entrypoint_decl_,
14500     &ffecom_float_zero_,
14501     &ffecom_float_half_,
14502     &ffecom_double_zero_,
14503     &ffecom_double_half_,
14504     &ffecom_func_result_,
14505     &ffecom_func_length_,
14506     &ffecom_multi_type_node_,
14507     &ffecom_multi_retval_,
14508     &named_labels,
14509     &shadowed_labels
14510   };
14511   size_t i;
14512
14513   malloc_init ();
14514
14515   /* Record our roots.  */
14516   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14517     ggc_add_tree_root (tree_roots[i], 1);
14518   ggc_add_tree_root (&ffecom_tree_type[0][0],
14519                      FFEINFO_basictype*FFEINFO_kindtype);
14520   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14521                      FFEINFO_basictype*FFEINFO_kindtype);
14522   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14523                      FFEINFO_basictype*FFEINFO_kindtype);
14524   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14525   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14526                 mark_binding_level);
14527   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14528                 mark_binding_level);
14529   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14530
14531   ffe_init_0 ();
14532 }
14533
14534 const char *
14535 init_parse (filename)
14536      const char *filename;
14537 {
14538   /* Open input file.  */
14539   if (filename == 0 || !strcmp (filename, "-"))
14540     {
14541       finput = stdin;
14542       filename = "stdin";
14543     }
14544   else
14545     finput = fopen (filename, "r");
14546   if (finput == 0)
14547     fatal_io_error ("can't open %s", filename);
14548
14549 #ifdef IO_BUFFER_SIZE
14550   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14551 #endif
14552
14553   /* Make identifier nodes long enough for the language-specific slots.  */
14554   set_identifier_size (sizeof (struct lang_identifier));
14555   decl_printable_name = lang_printable_name;
14556 #if BUILT_FOR_270
14557   print_error_function = lang_print_error_function;
14558 #endif
14559
14560   return filename;
14561 }
14562
14563 void
14564 finish_parse ()
14565 {
14566   fclose (finput);
14567 }
14568
14569 /* Delete the node BLOCK from the current binding level.
14570    This is used for the block inside a stmt expr ({...})
14571    so that the block can be reinserted where appropriate.  */
14572
14573 static void
14574 delete_block (block)
14575      tree block;
14576 {
14577   tree t;
14578   if (current_binding_level->blocks == block)
14579     current_binding_level->blocks = TREE_CHAIN (block);
14580   for (t = current_binding_level->blocks; t;)
14581     {
14582       if (TREE_CHAIN (t) == block)
14583         TREE_CHAIN (t) = TREE_CHAIN (block);
14584       else
14585         t = TREE_CHAIN (t);
14586     }
14587   TREE_CHAIN (block) = NULL;
14588   /* Clear TREE_USED which is always set by poplevel.
14589      The flag is set again if insert_block is called.  */
14590   TREE_USED (block) = 0;
14591 }
14592
14593 void
14594 insert_block (block)
14595      tree block;
14596 {
14597   TREE_USED (block) = 1;
14598   current_binding_level->blocks
14599     = chainon (current_binding_level->blocks, block);
14600 }
14601
14602 /* Each front end provides its own.  */
14603 static void ffe_init PARAMS ((void));
14604 static void ffe_finish PARAMS ((void));
14605 static void ffe_init_options PARAMS ((void));
14606
14607 struct lang_hooks lang_hooks = {ffe_init,
14608                                 ffe_finish,
14609                                 ffe_init_options,
14610                                 ffe_decode_option,
14611                                 NULL /* post_options */};
14612
14613 /* used by print-tree.c */
14614
14615 void
14616 lang_print_xnode (file, node, indent)
14617      FILE *file UNUSED;
14618      tree node UNUSED;
14619      int indent UNUSED;
14620 {
14621 }
14622
14623 static void
14624 ffe_finish ()
14625 {
14626   ffe_terminate_0 ();
14627
14628   if (ffe_is_ffedebug ())
14629     malloc_pool_display (malloc_pool_image ());
14630 }
14631
14632 const char *
14633 lang_identify ()
14634 {
14635   return "f77";
14636 }
14637
14638 /* Return the typed-based alias set for T, which may be an expression
14639    or a type.  Return -1 if we don't do anything special.  */
14640
14641 HOST_WIDE_INT
14642 lang_get_alias_set (t)
14643      tree t ATTRIBUTE_UNUSED;
14644 {
14645   /* We do not wish to use alias-set based aliasing at all.  Used in the
14646      extreme (every object with its own set, with equivalences recorded)
14647      it might be helpful, but there are problems when it comes to inlining.
14648      We get on ok with flag_argument_noalias, and alias-set aliasing does
14649      currently limit how stack slots can be reused, which is a lose.  */
14650   return 0;
14651 }
14652
14653 static void
14654 ffe_init_options ()
14655 {
14656   /* Set default options for Fortran.  */
14657   flag_move_all_movables = 1;
14658   flag_reduce_all_givs = 1;
14659   flag_argument_noalias = 2;
14660   flag_errno_math = 0;
14661   flag_complex_divide_method = 1;
14662 }
14663
14664 static void
14665 ffe_init ()
14666 {
14667   /* If the file is output from cpp, it should contain a first line
14668      `# 1 "real-filename"', and the current design of gcc (toplev.c
14669      in particular and the way it sets up information relied on by
14670      INCLUDE) requires that we read this now, and store the
14671      "real-filename" info in master_input_filename.  Ask the lexer
14672      to try doing this.  */
14673   ffelex_hash_kludge (finput);
14674 }
14675
14676 int
14677 mark_addressable (exp)
14678      tree exp;
14679 {
14680   register tree x = exp;
14681   while (1)
14682     switch (TREE_CODE (x))
14683       {
14684       case ADDR_EXPR:
14685       case COMPONENT_REF:
14686       case ARRAY_REF:
14687         x = TREE_OPERAND (x, 0);
14688         break;
14689
14690       case CONSTRUCTOR:
14691         TREE_ADDRESSABLE (x) = 1;
14692         return 1;
14693
14694       case VAR_DECL:
14695       case CONST_DECL:
14696       case PARM_DECL:
14697       case RESULT_DECL:
14698         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14699             && DECL_NONLOCAL (x))
14700           {
14701             if (TREE_PUBLIC (x))
14702               {
14703                 assert ("address of global register var requested" == NULL);
14704                 return 0;
14705               }
14706             assert ("address of register variable requested" == NULL);
14707           }
14708         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14709           {
14710             if (TREE_PUBLIC (x))
14711               {
14712                 assert ("address of global register var requested" == NULL);
14713                 return 0;
14714               }
14715             assert ("address of register var requested" == NULL);
14716           }
14717         put_var_into_stack (x);
14718
14719         /* drops in */
14720       case FUNCTION_DECL:
14721         TREE_ADDRESSABLE (x) = 1;
14722 #if 0                           /* poplevel deals with this now.  */
14723         if (DECL_CONTEXT (x) == 0)
14724           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14725 #endif
14726
14727       default:
14728         return 1;
14729       }
14730 }
14731
14732 /* If DECL has a cleanup, build and return that cleanup here.
14733    This is a callback called by expand_expr.  */
14734
14735 tree
14736 maybe_build_cleanup (decl)
14737      tree decl UNUSED;
14738 {
14739   /* There are no cleanups in Fortran.  */
14740   return NULL_TREE;
14741 }
14742
14743 /* Exit a binding level.
14744    Pop the level off, and restore the state of the identifier-decl mappings
14745    that were in effect when this level was entered.
14746
14747    If KEEP is nonzero, this level had explicit declarations, so
14748    and create a "block" (a BLOCK node) for the level
14749    to record its declarations and subblocks for symbol table output.
14750
14751    If FUNCTIONBODY is nonzero, this level is the body of a function,
14752    so create a block as if KEEP were set and also clear out all
14753    label names.
14754
14755    If REVERSE is nonzero, reverse the order of decls before putting
14756    them into the BLOCK.  */
14757
14758 tree
14759 poplevel (keep, reverse, functionbody)
14760      int keep;
14761      int reverse;
14762      int functionbody;
14763 {
14764   register tree link;
14765   /* The chain of decls was accumulated in reverse order.
14766      Put it into forward order, just for cleanliness.  */
14767   tree decls;
14768   tree subblocks = current_binding_level->blocks;
14769   tree block = 0;
14770   tree decl;
14771   int block_previously_created;
14772
14773   /* Get the decls in the order they were written.
14774      Usually current_binding_level->names is in reverse order.
14775      But parameter decls were previously put in forward order.  */
14776
14777   if (reverse)
14778     current_binding_level->names
14779       = decls = nreverse (current_binding_level->names);
14780   else
14781     decls = current_binding_level->names;
14782
14783   /* Output any nested inline functions within this block
14784      if they weren't already output.  */
14785
14786   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14787     if (TREE_CODE (decl) == FUNCTION_DECL
14788         && ! TREE_ASM_WRITTEN (decl)
14789         && DECL_INITIAL (decl) != 0
14790         && TREE_ADDRESSABLE (decl))
14791       {
14792         /* If this decl was copied from a file-scope decl
14793            on account of a block-scope extern decl,
14794            propagate TREE_ADDRESSABLE to the file-scope decl.
14795
14796            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14797            true, since then the decl goes through save_for_inline_copying.  */
14798         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14799             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14800           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14801         else if (DECL_SAVED_INSNS (decl) != 0)
14802           {
14803             push_function_context ();
14804             output_inline_function (decl);
14805             pop_function_context ();
14806           }
14807       }
14808
14809   /* If there were any declarations or structure tags in that level,
14810      or if this level is a function body,
14811      create a BLOCK to record them for the life of this function.  */
14812
14813   block = 0;
14814   block_previously_created = (current_binding_level->this_block != 0);
14815   if (block_previously_created)
14816     block = current_binding_level->this_block;
14817   else if (keep || functionbody)
14818     block = make_node (BLOCK);
14819   if (block != 0)
14820     {
14821       BLOCK_VARS (block) = decls;
14822       BLOCK_SUBBLOCKS (block) = subblocks;
14823     }
14824
14825   /* In each subblock, record that this is its superior.  */
14826
14827   for (link = subblocks; link; link = TREE_CHAIN (link))
14828     BLOCK_SUPERCONTEXT (link) = block;
14829
14830   /* Clear out the meanings of the local variables of this level.  */
14831
14832   for (link = decls; link; link = TREE_CHAIN (link))
14833     {
14834       if (DECL_NAME (link) != 0)
14835         {
14836           /* If the ident. was used or addressed via a local extern decl,
14837              don't forget that fact.  */
14838           if (DECL_EXTERNAL (link))
14839             {
14840               if (TREE_USED (link))
14841                 TREE_USED (DECL_NAME (link)) = 1;
14842               if (TREE_ADDRESSABLE (link))
14843                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14844             }
14845           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14846         }
14847     }
14848
14849   /* If the level being exited is the top level of a function,
14850      check over all the labels, and clear out the current
14851      (function local) meanings of their names.  */
14852
14853   if (functionbody)
14854     {
14855       /* If this is the top level block of a function,
14856          the vars are the function's parameters.
14857          Don't leave them in the BLOCK because they are
14858          found in the FUNCTION_DECL instead.  */
14859
14860       BLOCK_VARS (block) = 0;
14861     }
14862
14863   /* Pop the current level, and free the structure for reuse.  */
14864
14865   {
14866     register struct binding_level *level = current_binding_level;
14867     current_binding_level = current_binding_level->level_chain;
14868
14869     level->level_chain = free_binding_level;
14870     free_binding_level = level;
14871   }
14872
14873   /* Dispose of the block that we just made inside some higher level.  */
14874   if (functionbody
14875       && current_function_decl != error_mark_node)
14876     DECL_INITIAL (current_function_decl) = block;
14877   else if (block)
14878     {
14879       if (!block_previously_created)
14880         current_binding_level->blocks
14881           = chainon (current_binding_level->blocks, block);
14882     }
14883   /* If we did not make a block for the level just exited,
14884      any blocks made for inner levels
14885      (since they cannot be recorded as subblocks in that level)
14886      must be carried forward so they will later become subblocks
14887      of something else.  */
14888   else if (subblocks)
14889     current_binding_level->blocks
14890       = chainon (current_binding_level->blocks, subblocks);
14891
14892   if (block)
14893     TREE_USED (block) = 1;
14894   return block;
14895 }
14896
14897 void
14898 print_lang_decl (file, node, indent)
14899      FILE *file UNUSED;
14900      tree node UNUSED;
14901      int indent UNUSED;
14902 {
14903 }
14904
14905 void
14906 print_lang_identifier (file, node, indent)
14907      FILE *file;
14908      tree node;
14909      int indent;
14910 {
14911   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14912   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14913 }
14914
14915 void
14916 print_lang_statistics ()
14917 {
14918 }
14919
14920 void
14921 print_lang_type (file, node, indent)
14922      FILE *file UNUSED;
14923      tree node UNUSED;
14924      int indent UNUSED;
14925 {
14926 }
14927
14928 /* Record a decl-node X as belonging to the current lexical scope.
14929    Check for errors (such as an incompatible declaration for the same
14930    name already seen in the same scope).
14931
14932    Returns either X or an old decl for the same name.
14933    If an old decl is returned, it may have been smashed
14934    to agree with what X says.  */
14935
14936 tree
14937 pushdecl (x)
14938      tree x;
14939 {
14940   register tree t;
14941   register tree name = DECL_NAME (x);
14942   register struct binding_level *b = current_binding_level;
14943
14944   if ((TREE_CODE (x) == FUNCTION_DECL)
14945       && (DECL_INITIAL (x) == 0)
14946       && DECL_EXTERNAL (x))
14947     DECL_CONTEXT (x) = NULL_TREE;
14948   else
14949     DECL_CONTEXT (x) = current_function_decl;
14950
14951   if (name)
14952     {
14953       if (IDENTIFIER_INVENTED (name))
14954         {
14955 #if BUILT_FOR_270
14956           DECL_ARTIFICIAL (x) = 1;
14957 #endif
14958           DECL_IN_SYSTEM_HEADER (x) = 1;
14959         }
14960
14961       t = lookup_name_current_level (name);
14962
14963       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14964
14965       /* Don't push non-parms onto list for parms until we understand
14966          why we're doing this and whether it works.  */
14967
14968       assert ((b == global_binding_level)
14969               || !ffecom_transform_only_dummies_
14970               || TREE_CODE (x) == PARM_DECL);
14971
14972       if ((t != NULL_TREE) && duplicate_decls (x, t))
14973         return t;
14974
14975       /* If we are processing a typedef statement, generate a whole new
14976          ..._TYPE node (which will be just an variant of the existing
14977          ..._TYPE node with identical properties) and then install the
14978          TYPE_DECL node generated to represent the typedef name as the
14979          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14980
14981          The whole point here is to end up with a situation where each and every
14982          ..._TYPE node the compiler creates will be uniquely associated with
14983          AT MOST one node representing a typedef name. This way, even though
14984          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14985          (i.e. "typedef name") nodes very early on, later parts of the
14986          compiler can always do the reverse translation and get back the
14987          corresponding typedef name.  For example, given:
14988
14989          typedef struct S MY_TYPE; MY_TYPE object;
14990
14991          Later parts of the compiler might only know that `object' was of type
14992          `struct S' if it were not for code just below.  With this code
14993          however, later parts of the compiler see something like:
14994
14995          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14996
14997          And they can then deduce (from the node for type struct S') that the
14998          original object declaration was:
14999
15000          MY_TYPE object;
15001
15002          Being able to do this is important for proper support of protoize, and
15003          also for generating precise symbolic debugging information which
15004          takes full account of the programmer's (typedef) vocabulary.
15005
15006          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15007          TYPE_DECL node that we are now processing really represents a
15008          standard built-in type.
15009
15010          Since all standard types are effectively declared at line zero in the
15011          source file, we can easily check to see if we are working on a
15012          standard type by checking the current value of lineno.  */
15013
15014       if (TREE_CODE (x) == TYPE_DECL)
15015         {
15016           if (DECL_SOURCE_LINE (x) == 0)
15017             {
15018               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15019                 TYPE_NAME (TREE_TYPE (x)) = x;
15020             }
15021           else if (TREE_TYPE (x) != error_mark_node)
15022             {
15023               tree tt = TREE_TYPE (x);
15024
15025               tt = build_type_copy (tt);
15026               TYPE_NAME (tt) = x;
15027               TREE_TYPE (x) = tt;
15028             }
15029         }
15030
15031       /* This name is new in its binding level. Install the new declaration
15032          and return it.  */
15033       if (b == global_binding_level)
15034         IDENTIFIER_GLOBAL_VALUE (name) = x;
15035       else
15036         IDENTIFIER_LOCAL_VALUE (name) = x;
15037     }
15038
15039   /* Put decls on list in reverse order. We will reverse them later if
15040      necessary.  */
15041   TREE_CHAIN (x) = b->names;
15042   b->names = x;
15043
15044   return x;
15045 }
15046
15047 /* Nonzero if the current level needs to have a BLOCK made.  */
15048
15049 static int
15050 kept_level_p ()
15051 {
15052   tree decl;
15053
15054   for (decl = current_binding_level->names;
15055        decl;
15056        decl = TREE_CHAIN (decl))
15057     {
15058       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15059           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15060         /* Currently, there aren't supposed to be non-artificial names
15061            at other than the top block for a function -- they're
15062            believed to always be temps.  But it's wise to check anyway.  */
15063         return 1;
15064     }
15065   return 0;
15066 }
15067
15068 /* Enter a new binding level.
15069    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15070    not for that of tags.  */
15071
15072 void
15073 pushlevel (tag_transparent)
15074      int tag_transparent;
15075 {
15076   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15077
15078   assert (! tag_transparent);
15079
15080   if (current_binding_level == global_binding_level)
15081     {
15082       named_labels = 0;
15083     }
15084
15085   /* Reuse or create a struct for this binding level.  */
15086
15087   if (free_binding_level)
15088     {
15089       newlevel = free_binding_level;
15090       free_binding_level = free_binding_level->level_chain;
15091     }
15092   else
15093     {
15094       newlevel = make_binding_level ();
15095     }
15096
15097   /* Add this level to the front of the chain (stack) of levels that
15098      are active.  */
15099
15100   *newlevel = clear_binding_level;
15101   newlevel->level_chain = current_binding_level;
15102   current_binding_level = newlevel;
15103 }
15104
15105 /* Set the BLOCK node for the innermost scope
15106    (the one we are currently in).  */
15107
15108 void
15109 set_block (block)
15110      register tree block;
15111 {
15112   current_binding_level->this_block = block;
15113   current_binding_level->names = chainon (current_binding_level->names,
15114                                           BLOCK_VARS (block));
15115   current_binding_level->blocks = chainon (current_binding_level->blocks,
15116                                            BLOCK_SUBBLOCKS (block));
15117 }
15118
15119 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15120
15121 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15122
15123 void
15124 set_yydebug (value)
15125      int value;
15126 {
15127   if (value)
15128     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15129 }
15130
15131 tree
15132 signed_or_unsigned_type (unsignedp, type)
15133      int unsignedp;
15134      tree type;
15135 {
15136   tree type2;
15137
15138   if (! INTEGRAL_TYPE_P (type))
15139     return type;
15140   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15141     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15142   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15143     return unsignedp ? unsigned_type_node : integer_type_node;
15144   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15145     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15146   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15147     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15148   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15149     return (unsignedp ? long_long_unsigned_type_node
15150             : long_long_integer_type_node);
15151
15152   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15153   if (type2 == NULL_TREE)
15154     return type;
15155
15156   return type2;
15157 }
15158
15159 tree
15160 signed_type (type)
15161      tree type;
15162 {
15163   tree type1 = TYPE_MAIN_VARIANT (type);
15164   ffeinfoKindtype kt;
15165   tree type2;
15166
15167   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15168     return signed_char_type_node;
15169   if (type1 == unsigned_type_node)
15170     return integer_type_node;
15171   if (type1 == short_unsigned_type_node)
15172     return short_integer_type_node;
15173   if (type1 == long_unsigned_type_node)
15174     return long_integer_type_node;
15175   if (type1 == long_long_unsigned_type_node)
15176     return long_long_integer_type_node;
15177 #if 0   /* gcc/c-* files only */
15178   if (type1 == unsigned_intDI_type_node)
15179     return intDI_type_node;
15180   if (type1 == unsigned_intSI_type_node)
15181     return intSI_type_node;
15182   if (type1 == unsigned_intHI_type_node)
15183     return intHI_type_node;
15184   if (type1 == unsigned_intQI_type_node)
15185     return intQI_type_node;
15186 #endif
15187
15188   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15189   if (type2 != NULL_TREE)
15190     return type2;
15191
15192   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15193     {
15194       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15195
15196       if (type1 == type2)
15197         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15198     }
15199
15200   return type;
15201 }
15202
15203 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15204    or validate its data type for an `if' or `while' statement or ?..: exp.
15205
15206    This preparation consists of taking the ordinary
15207    representation of an expression expr and producing a valid tree
15208    boolean expression describing whether expr is nonzero.  We could
15209    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15210    but we optimize comparisons, &&, ||, and !.
15211
15212    The resulting type should always be `integer_type_node'.  */
15213
15214 tree
15215 truthvalue_conversion (expr)
15216      tree expr;
15217 {
15218   if (TREE_CODE (expr) == ERROR_MARK)
15219     return expr;
15220
15221 #if 0 /* This appears to be wrong for C++.  */
15222   /* These really should return error_mark_node after 2.4 is stable.
15223      But not all callers handle ERROR_MARK properly.  */
15224   switch (TREE_CODE (TREE_TYPE (expr)))
15225     {
15226     case RECORD_TYPE:
15227       error ("struct type value used where scalar is required");
15228       return integer_zero_node;
15229
15230     case UNION_TYPE:
15231       error ("union type value used where scalar is required");
15232       return integer_zero_node;
15233
15234     case ARRAY_TYPE:
15235       error ("array type value used where scalar is required");
15236       return integer_zero_node;
15237
15238     default:
15239       break;
15240     }
15241 #endif /* 0 */
15242
15243   switch (TREE_CODE (expr))
15244     {
15245       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15246          or comparison expressions as truth values at this level.  */
15247 #if 0
15248     case COMPONENT_REF:
15249       /* A one-bit unsigned bit-field is already acceptable.  */
15250       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15251           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15252         return expr;
15253       break;
15254 #endif
15255
15256     case EQ_EXPR:
15257       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15258          or comparison expressions as truth values at this level.  */
15259 #if 0
15260       if (integer_zerop (TREE_OPERAND (expr, 1)))
15261         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15262 #endif
15263     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15264     case TRUTH_ANDIF_EXPR:
15265     case TRUTH_ORIF_EXPR:
15266     case TRUTH_AND_EXPR:
15267     case TRUTH_OR_EXPR:
15268     case TRUTH_XOR_EXPR:
15269       TREE_TYPE (expr) = integer_type_node;
15270       return expr;
15271
15272     case ERROR_MARK:
15273       return expr;
15274
15275     case INTEGER_CST:
15276       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15277
15278     case REAL_CST:
15279       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15280
15281     case ADDR_EXPR:
15282       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15283         return build (COMPOUND_EXPR, integer_type_node,
15284                       TREE_OPERAND (expr, 0), integer_one_node);
15285       else
15286         return integer_one_node;
15287
15288     case COMPLEX_EXPR:
15289       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15290                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15291                        integer_type_node,
15292                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15293                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15294
15295     case NEGATE_EXPR:
15296     case ABS_EXPR:
15297     case FLOAT_EXPR:
15298     case FFS_EXPR:
15299       /* These don't change whether an object is non-zero or zero.  */
15300       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15301
15302     case LROTATE_EXPR:
15303     case RROTATE_EXPR:
15304       /* These don't change whether an object is zero or non-zero, but
15305          we can't ignore them if their second arg has side-effects.  */
15306       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15307         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15308                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15309       else
15310         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15311
15312     case COND_EXPR:
15313       /* Distribute the conversion into the arms of a COND_EXPR.  */
15314       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15315                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15316                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15317
15318     case CONVERT_EXPR:
15319       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15320          since that affects how `default_conversion' will behave.  */
15321       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15322           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15323         break;
15324       /* fall through... */
15325     case NOP_EXPR:
15326       /* If this is widening the argument, we can ignore it.  */
15327       if (TYPE_PRECISION (TREE_TYPE (expr))
15328           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15329         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15330       break;
15331
15332     case MINUS_EXPR:
15333       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15334          this case.  */
15335       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15336           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15337         break;
15338       /* fall through... */
15339     case BIT_XOR_EXPR:
15340       /* This and MINUS_EXPR can be changed into a comparison of the
15341          two objects.  */
15342       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15343           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15344         return ffecom_2 (NE_EXPR, integer_type_node,
15345                          TREE_OPERAND (expr, 0),
15346                          TREE_OPERAND (expr, 1));
15347       return ffecom_2 (NE_EXPR, integer_type_node,
15348                        TREE_OPERAND (expr, 0),
15349                        fold (build1 (NOP_EXPR,
15350                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15351                                      TREE_OPERAND (expr, 1))));
15352
15353     case BIT_AND_EXPR:
15354       if (integer_onep (TREE_OPERAND (expr, 1)))
15355         return expr;
15356       break;
15357
15358     case MODIFY_EXPR:
15359 #if 0                           /* No such thing in Fortran. */
15360       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15361         warning ("suggest parentheses around assignment used as truth value");
15362 #endif
15363       break;
15364
15365     default:
15366       break;
15367     }
15368
15369   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15370     return (ffecom_2
15371             ((TREE_SIDE_EFFECTS (expr)
15372               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15373              integer_type_node,
15374              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15375                                               TREE_TYPE (TREE_TYPE (expr)),
15376                                               expr)),
15377              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15378                                               TREE_TYPE (TREE_TYPE (expr)),
15379                                               expr))));
15380
15381   return ffecom_2 (NE_EXPR, integer_type_node,
15382                    expr,
15383                    convert (TREE_TYPE (expr), integer_zero_node));
15384 }
15385
15386 tree
15387 type_for_mode (mode, unsignedp)
15388      enum machine_mode mode;
15389      int unsignedp;
15390 {
15391   int i;
15392   int j;
15393   tree t;
15394
15395   if (mode == TYPE_MODE (integer_type_node))
15396     return unsignedp ? unsigned_type_node : integer_type_node;
15397
15398   if (mode == TYPE_MODE (signed_char_type_node))
15399     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15400
15401   if (mode == TYPE_MODE (short_integer_type_node))
15402     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15403
15404   if (mode == TYPE_MODE (long_integer_type_node))
15405     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15406
15407   if (mode == TYPE_MODE (long_long_integer_type_node))
15408     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15409
15410 #if HOST_BITS_PER_WIDE_INT >= 64
15411   if (mode == TYPE_MODE (intTI_type_node))
15412     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15413 #endif
15414
15415   if (mode == TYPE_MODE (float_type_node))
15416     return float_type_node;
15417
15418   if (mode == TYPE_MODE (double_type_node))
15419     return double_type_node;
15420
15421   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15422     return build_pointer_type (char_type_node);
15423
15424   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15425     return build_pointer_type (integer_type_node);
15426
15427   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15428     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15429       {
15430         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15431             && (mode == TYPE_MODE (t)))
15432           {
15433             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15434               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15435             else
15436               return t;
15437           }
15438       }
15439
15440   return 0;
15441 }
15442
15443 tree
15444 type_for_size (bits, unsignedp)
15445      unsigned bits;
15446      int unsignedp;
15447 {
15448   ffeinfoKindtype kt;
15449   tree type_node;
15450
15451   if (bits == TYPE_PRECISION (integer_type_node))
15452     return unsignedp ? unsigned_type_node : integer_type_node;
15453
15454   if (bits == TYPE_PRECISION (signed_char_type_node))
15455     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15456
15457   if (bits == TYPE_PRECISION (short_integer_type_node))
15458     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15459
15460   if (bits == TYPE_PRECISION (long_integer_type_node))
15461     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15462
15463   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15464     return (unsignedp ? long_long_unsigned_type_node
15465             : long_long_integer_type_node);
15466
15467   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15468     {
15469       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15470
15471       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15472         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15473           : type_node;
15474     }
15475
15476   return 0;
15477 }
15478
15479 tree
15480 unsigned_type (type)
15481      tree type;
15482 {
15483   tree type1 = TYPE_MAIN_VARIANT (type);
15484   ffeinfoKindtype kt;
15485   tree type2;
15486
15487   if (type1 == signed_char_type_node || type1 == char_type_node)
15488     return unsigned_char_type_node;
15489   if (type1 == integer_type_node)
15490     return unsigned_type_node;
15491   if (type1 == short_integer_type_node)
15492     return short_unsigned_type_node;
15493   if (type1 == long_integer_type_node)
15494     return long_unsigned_type_node;
15495   if (type1 == long_long_integer_type_node)
15496     return long_long_unsigned_type_node;
15497 #if 0   /* gcc/c-* files only */
15498   if (type1 == intDI_type_node)
15499     return unsigned_intDI_type_node;
15500   if (type1 == intSI_type_node)
15501     return unsigned_intSI_type_node;
15502   if (type1 == intHI_type_node)
15503     return unsigned_intHI_type_node;
15504   if (type1 == intQI_type_node)
15505     return unsigned_intQI_type_node;
15506 #endif
15507
15508   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15509   if (type2 != NULL_TREE)
15510     return type2;
15511
15512   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15513     {
15514       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15515
15516       if (type1 == type2)
15517         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15518     }
15519
15520   return type;
15521 }
15522
15523 void
15524 lang_mark_tree (t)
15525      union tree_node *t ATTRIBUTE_UNUSED;
15526 {
15527   if (TREE_CODE (t) == IDENTIFIER_NODE)
15528     {
15529       struct lang_identifier *i = (struct lang_identifier *) t;
15530       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15531       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15532       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15533     }
15534   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15535     ggc_mark (TYPE_LANG_SPECIFIC (t));
15536 }
15537
15538 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15539 \f
15540 #if FFECOM_GCC_INCLUDE
15541
15542 /* From gcc/cccp.c, the code to handle -I.  */
15543
15544 /* Skip leading "./" from a directory name.
15545    This may yield the empty string, which represents the current directory.  */
15546
15547 static const char *
15548 skip_redundant_dir_prefix (const char *dir)
15549 {
15550   while (dir[0] == '.' && dir[1] == '/')
15551     for (dir += 2; *dir == '/'; dir++)
15552       continue;
15553   if (dir[0] == '.' && !dir[1])
15554     dir++;
15555   return dir;
15556 }
15557
15558 /* The file_name_map structure holds a mapping of file names for a
15559    particular directory.  This mapping is read from the file named
15560    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15561    map filenames on a file system with severe filename restrictions,
15562    such as DOS.  The format of the file name map file is just a series
15563    of lines with two tokens on each line.  The first token is the name
15564    to map, and the second token is the actual name to use.  */
15565
15566 struct file_name_map
15567 {
15568   struct file_name_map *map_next;
15569   char *map_from;
15570   char *map_to;
15571 };
15572
15573 #define FILE_NAME_MAP_FILE "header.gcc"
15574
15575 /* Current maximum length of directory names in the search path
15576    for include files.  (Altered as we get more of them.)  */
15577
15578 static int max_include_len = 0;
15579
15580 struct file_name_list
15581   {
15582     struct file_name_list *next;
15583     char *fname;
15584     /* Mapping of file names for this directory.  */
15585     struct file_name_map *name_map;
15586     /* Non-zero if name_map is valid.  */
15587     int got_name_map;
15588   };
15589
15590 static struct file_name_list *include = NULL;   /* First dir to search */
15591 static struct file_name_list *last_include = NULL;      /* Last in chain */
15592
15593 /* I/O buffer structure.
15594    The `fname' field is nonzero for source files and #include files
15595    and for the dummy text used for -D and -U.
15596    It is zero for rescanning results of macro expansion
15597    and for expanding macro arguments.  */
15598 #define INPUT_STACK_MAX 400
15599 static struct file_buf {
15600   const char *fname;
15601   /* Filename specified with #line command.  */
15602   const char *nominal_fname;
15603   /* Record where in the search path this file was found.
15604      For #include_next.  */
15605   struct file_name_list *dir;
15606   ffewhereLine line;
15607   ffewhereColumn column;
15608 } instack[INPUT_STACK_MAX];
15609
15610 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15611 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15612
15613 /* Current nesting level of input sources.
15614    `instack[indepth]' is the level currently being read.  */
15615 static int indepth = -1;
15616
15617 typedef struct file_buf FILE_BUF;
15618
15619 typedef unsigned char U_CHAR;
15620
15621 /* table to tell if char can be part of a C identifier. */
15622 U_CHAR is_idchar[256];
15623 /* table to tell if char can be first char of a c identifier. */
15624 U_CHAR is_idstart[256];
15625 /* table to tell if c is horizontal space.  */
15626 U_CHAR is_hor_space[256];
15627 /* table to tell if c is horizontal or vertical space.  */
15628 static U_CHAR is_space[256];
15629
15630 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15631 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15632
15633 /* Nonzero means -I- has been seen,
15634    so don't look for #include "foo" the source-file directory.  */
15635 static int ignore_srcdir;
15636
15637 #ifndef INCLUDE_LEN_FUDGE
15638 #define INCLUDE_LEN_FUDGE 0
15639 #endif
15640
15641 static void append_include_chain (struct file_name_list *first,
15642                                   struct file_name_list *last);
15643 static FILE *open_include_file (char *filename,
15644                                 struct file_name_list *searchptr);
15645 static void print_containing_files (ffebadSeverity sev);
15646 static char *read_filename_string (int ch, FILE *f);
15647 static struct file_name_map *read_name_map (const char *dirname);
15648
15649 /* Append a chain of `struct file_name_list's
15650    to the end of the main include chain.
15651    FIRST is the beginning of the chain to append, and LAST is the end.  */
15652
15653 static void
15654 append_include_chain (first, last)
15655      struct file_name_list *first, *last;
15656 {
15657   struct file_name_list *dir;
15658
15659   if (!first || !last)
15660     return;
15661
15662   if (include == 0)
15663     include = first;
15664   else
15665     last_include->next = first;
15666
15667   for (dir = first; ; dir = dir->next) {
15668     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15669     if (len > max_include_len)
15670       max_include_len = len;
15671     if (dir == last)
15672       break;
15673   }
15674
15675   last->next = NULL;
15676   last_include = last;
15677 }
15678
15679 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15680    being tried from the include file search path.  This function maps
15681    filenames on file systems based on information read by
15682    read_name_map.  */
15683
15684 static FILE *
15685 open_include_file (filename, searchptr)
15686      char *filename;
15687      struct file_name_list *searchptr;
15688 {
15689   register struct file_name_map *map;
15690   register char *from;
15691   char *p, *dir;
15692
15693   if (searchptr && ! searchptr->got_name_map)
15694     {
15695       searchptr->name_map = read_name_map (searchptr->fname
15696                                            ? searchptr->fname : ".");
15697       searchptr->got_name_map = 1;
15698     }
15699
15700   /* First check the mapping for the directory we are using.  */
15701   if (searchptr && searchptr->name_map)
15702     {
15703       from = filename;
15704       if (searchptr->fname)
15705         from += strlen (searchptr->fname) + 1;
15706       for (map = searchptr->name_map; map; map = map->map_next)
15707         {
15708           if (! strcmp (map->map_from, from))
15709             {
15710               /* Found a match.  */
15711               return fopen (map->map_to, "r");
15712             }
15713         }
15714     }
15715
15716   /* Try to find a mapping file for the particular directory we are
15717      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15718      in /usr/include/header.gcc and look up types.h in
15719      /usr/include/sys/header.gcc.  */
15720   p = strrchr (filename, '/');
15721 #ifdef DIR_SEPARATOR
15722   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15723   else {
15724     char *tmp = strrchr (filename, DIR_SEPARATOR);
15725     if (tmp != NULL && tmp > p) p = tmp;
15726   }
15727 #endif
15728   if (! p)
15729     p = filename;
15730   if (searchptr
15731       && searchptr->fname
15732       && strlen (searchptr->fname) == (size_t) (p - filename)
15733       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15734     {
15735       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15736       return fopen (filename, "r");
15737     }
15738
15739   if (p == filename)
15740     {
15741       from = filename;
15742       map = read_name_map (".");
15743     }
15744   else
15745     {
15746       dir = (char *) xmalloc (p - filename + 1);
15747       memcpy (dir, filename, p - filename);
15748       dir[p - filename] = '\0';
15749       from = p + 1;
15750       map = read_name_map (dir);
15751       free (dir);
15752     }
15753   for (; map; map = map->map_next)
15754     if (! strcmp (map->map_from, from))
15755       return fopen (map->map_to, "r");
15756
15757   return fopen (filename, "r");
15758 }
15759
15760 /* Print the file names and line numbers of the #include
15761    commands which led to the current file.  */
15762
15763 static void
15764 print_containing_files (ffebadSeverity sev)
15765 {
15766   FILE_BUF *ip = NULL;
15767   int i;
15768   int first = 1;
15769   const char *str1;
15770   const char *str2;
15771
15772   /* If stack of files hasn't changed since we last printed
15773      this info, don't repeat it.  */
15774   if (last_error_tick == input_file_stack_tick)
15775     return;
15776
15777   for (i = indepth; i >= 0; i--)
15778     if (instack[i].fname != NULL) {
15779       ip = &instack[i];
15780       break;
15781     }
15782
15783   /* Give up if we don't find a source file.  */
15784   if (ip == NULL)
15785     return;
15786
15787   /* Find the other, outer source files.  */
15788   for (i--; i >= 0; i--)
15789     if (instack[i].fname != NULL)
15790       {
15791         ip = &instack[i];
15792         if (first)
15793           {
15794             first = 0;
15795             str1 = "In file included";
15796           }
15797         else
15798           {
15799             str1 = "...          ...";
15800           }
15801
15802         if (i == 1)
15803           str2 = ":";
15804         else
15805           str2 = "";
15806
15807         ffebad_start_msg ("%A from %B at %0%C", sev);
15808         ffebad_here (0, ip->line, ip->column);
15809         ffebad_string (str1);
15810         ffebad_string (ip->nominal_fname);
15811         ffebad_string (str2);
15812         ffebad_finish ();
15813       }
15814
15815   /* Record we have printed the status as of this time.  */
15816   last_error_tick = input_file_stack_tick;
15817 }
15818
15819 /* Read a space delimited string of unlimited length from a stdio
15820    file.  */
15821
15822 static char *
15823 read_filename_string (ch, f)
15824      int ch;
15825      FILE *f;
15826 {
15827   char *alloc, *set;
15828   int len;
15829
15830   len = 20;
15831   set = alloc = xmalloc (len + 1);
15832   if (! is_space[ch])
15833     {
15834       *set++ = ch;
15835       while ((ch = getc (f)) != EOF && ! is_space[ch])
15836         {
15837           if (set - alloc == len)
15838             {
15839               len *= 2;
15840               alloc = xrealloc (alloc, len + 1);
15841               set = alloc + len / 2;
15842             }
15843           *set++ = ch;
15844         }
15845     }
15846   *set = '\0';
15847   ungetc (ch, f);
15848   return alloc;
15849 }
15850
15851 /* Read the file name map file for DIRNAME.  */
15852
15853 static struct file_name_map *
15854 read_name_map (dirname)
15855      const char *dirname;
15856 {
15857   /* This structure holds a linked list of file name maps, one per
15858      directory.  */
15859   struct file_name_map_list
15860     {
15861       struct file_name_map_list *map_list_next;
15862       char *map_list_name;
15863       struct file_name_map *map_list_map;
15864     };
15865   static struct file_name_map_list *map_list;
15866   register struct file_name_map_list *map_list_ptr;
15867   char *name;
15868   FILE *f;
15869   size_t dirlen;
15870   int separator_needed;
15871
15872   dirname = skip_redundant_dir_prefix (dirname);
15873
15874   for (map_list_ptr = map_list; map_list_ptr;
15875        map_list_ptr = map_list_ptr->map_list_next)
15876     if (! strcmp (map_list_ptr->map_list_name, dirname))
15877       return map_list_ptr->map_list_map;
15878
15879   map_list_ptr = ((struct file_name_map_list *)
15880                   xmalloc (sizeof (struct file_name_map_list)));
15881   map_list_ptr->map_list_name = xstrdup (dirname);
15882   map_list_ptr->map_list_map = NULL;
15883
15884   dirlen = strlen (dirname);
15885   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15886   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15887   strcpy (name, dirname);
15888   name[dirlen] = '/';
15889   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15890   f = fopen (name, "r");
15891   free (name);
15892   if (!f)
15893     map_list_ptr->map_list_map = NULL;
15894   else
15895     {
15896       int ch;
15897
15898       while ((ch = getc (f)) != EOF)
15899         {
15900           char *from, *to;
15901           struct file_name_map *ptr;
15902
15903           if (is_space[ch])
15904             continue;
15905           from = read_filename_string (ch, f);
15906           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15907             ;
15908           to = read_filename_string (ch, f);
15909
15910           ptr = ((struct file_name_map *)
15911                  xmalloc (sizeof (struct file_name_map)));
15912           ptr->map_from = from;
15913
15914           /* Make the real filename absolute.  */
15915           if (*to == '/')
15916             ptr->map_to = to;
15917           else
15918             {
15919               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15920               strcpy (ptr->map_to, dirname);
15921               ptr->map_to[dirlen] = '/';
15922               strcpy (ptr->map_to + dirlen + separator_needed, to);
15923               free (to);
15924             }
15925
15926           ptr->map_next = map_list_ptr->map_list_map;
15927           map_list_ptr->map_list_map = ptr;
15928
15929           while ((ch = getc (f)) != '\n')
15930             if (ch == EOF)
15931               break;
15932         }
15933       fclose (f);
15934     }
15935
15936   map_list_ptr->map_list_next = map_list;
15937   map_list = map_list_ptr;
15938
15939   return map_list_ptr->map_list_map;
15940 }
15941
15942 static void
15943 ffecom_file_ (const char *name)
15944 {
15945   FILE_BUF *fp;
15946
15947   /* Do partial setup of input buffer for the sake of generating
15948      early #line directives (when -g is in effect).  */
15949
15950   fp = &instack[++indepth];
15951   memset ((char *) fp, 0, sizeof (FILE_BUF));
15952   if (name == NULL)
15953     name = "";
15954   fp->nominal_fname = fp->fname = name;
15955 }
15956
15957 /* Initialize syntactic classifications of characters.  */
15958
15959 static void
15960 ffecom_initialize_char_syntax_ ()
15961 {
15962   register int i;
15963
15964   /*
15965    * Set up is_idchar and is_idstart tables.  These should be
15966    * faster than saying (is_alpha (c) || c == '_'), etc.
15967    * Set up these things before calling any routines tthat
15968    * refer to them.
15969    */
15970   for (i = 'a'; i <= 'z'; i++) {
15971     is_idchar[i - 'a' + 'A'] = 1;
15972     is_idchar[i] = 1;
15973     is_idstart[i - 'a' + 'A'] = 1;
15974     is_idstart[i] = 1;
15975   }
15976   for (i = '0'; i <= '9'; i++)
15977     is_idchar[i] = 1;
15978   is_idchar['_'] = 1;
15979   is_idstart['_'] = 1;
15980
15981   /* horizontal space table */
15982   is_hor_space[' '] = 1;
15983   is_hor_space['\t'] = 1;
15984   is_hor_space['\v'] = 1;
15985   is_hor_space['\f'] = 1;
15986   is_hor_space['\r'] = 1;
15987
15988   is_space[' '] = 1;
15989   is_space['\t'] = 1;
15990   is_space['\v'] = 1;
15991   is_space['\f'] = 1;
15992   is_space['\n'] = 1;
15993   is_space['\r'] = 1;
15994 }
15995
15996 static void
15997 ffecom_close_include_ (FILE *f)
15998 {
15999   fclose (f);
16000
16001   indepth--;
16002   input_file_stack_tick++;
16003
16004   ffewhere_line_kill (instack[indepth].line);
16005   ffewhere_column_kill (instack[indepth].column);
16006 }
16007
16008 static int
16009 ffecom_decode_include_option_ (char *spec)
16010 {
16011   struct file_name_list *dirtmp;
16012
16013   if (! ignore_srcdir && !strcmp (spec, "-"))
16014     ignore_srcdir = 1;
16015   else
16016     {
16017       dirtmp = (struct file_name_list *)
16018         xmalloc (sizeof (struct file_name_list));
16019       dirtmp->next = 0;         /* New one goes on the end */
16020       dirtmp->fname = spec;
16021       dirtmp->got_name_map = 0;
16022       if (spec[0] == 0)
16023         error ("Directory name must immediately follow -I");
16024       else
16025         append_include_chain (dirtmp, dirtmp);
16026     }
16027   return 1;
16028 }
16029
16030 /* Open INCLUDEd file.  */
16031
16032 static FILE *
16033 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16034 {
16035   char *fbeg = name;
16036   size_t flen = strlen (fbeg);
16037   struct file_name_list *search_start = include; /* Chain of dirs to search */
16038   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16039   struct file_name_list *searchptr = 0;
16040   char *fname;          /* Dynamically allocated fname buffer */
16041   FILE *f;
16042   FILE_BUF *fp;
16043
16044   if (flen == 0)
16045     return NULL;
16046
16047   dsp[0].fname = NULL;
16048
16049   /* If -I- was specified, don't search current dir, only spec'd ones. */
16050   if (!ignore_srcdir)
16051     {
16052       for (fp = &instack[indepth]; fp >= instack; fp--)
16053         {
16054           int n;
16055           char *ep;
16056           const char *nam;
16057
16058           if ((nam = fp->nominal_fname) != NULL)
16059             {
16060               /* Found a named file.  Figure out dir of the file,
16061                  and put it in front of the search list.  */
16062               dsp[0].next = search_start;
16063               search_start = dsp;
16064 #ifndef VMS
16065               ep = strrchr (nam, '/');
16066 #ifdef DIR_SEPARATOR
16067             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16068             else {
16069               char *tmp = strrchr (nam, DIR_SEPARATOR);
16070               if (tmp != NULL && tmp > ep) ep = tmp;
16071             }
16072 #endif
16073 #else                           /* VMS */
16074               ep = strrchr (nam, ']');
16075               if (ep == NULL) ep = strrchr (nam, '>');
16076               if (ep == NULL) ep = strrchr (nam, ':');
16077               if (ep != NULL) ep++;
16078 #endif                          /* VMS */
16079               if (ep != NULL)
16080                 {
16081                   n = ep - nam;
16082                   dsp[0].fname = (char *) xmalloc (n + 1);
16083                   strncpy (dsp[0].fname, nam, n);
16084                   dsp[0].fname[n] = '\0';
16085                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16086                     max_include_len = n + INCLUDE_LEN_FUDGE;
16087                 }
16088               else
16089                 dsp[0].fname = NULL; /* Current directory */
16090               dsp[0].got_name_map = 0;
16091               break;
16092             }
16093         }
16094     }
16095
16096   /* Allocate this permanently, because it gets stored in the definitions
16097      of macros.  */
16098   fname = xmalloc (max_include_len + flen + 4);
16099   /* + 2 above for slash and terminating null.  */
16100   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16101      for g77 yet).  */
16102
16103   /* If specified file name is absolute, just open it.  */
16104
16105   if (*fbeg == '/'
16106 #ifdef DIR_SEPARATOR
16107       || *fbeg == DIR_SEPARATOR
16108 #endif
16109       )
16110     {
16111       strncpy (fname, (char *) fbeg, flen);
16112       fname[flen] = 0;
16113       f = open_include_file (fname, NULL_PTR);
16114     }
16115   else
16116     {
16117       f = NULL;
16118
16119       /* Search directory path, trying to open the file.
16120          Copy each filename tried into FNAME.  */
16121
16122       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16123         {
16124           if (searchptr->fname)
16125             {
16126               /* The empty string in a search path is ignored.
16127                  This makes it possible to turn off entirely
16128                  a standard piece of the list.  */
16129               if (searchptr->fname[0] == 0)
16130                 continue;
16131               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16132               if (fname[0] && fname[strlen (fname) - 1] != '/')
16133                 strcat (fname, "/");
16134               fname[strlen (fname) + flen] = 0;
16135             }
16136           else
16137             fname[0] = 0;
16138
16139           strncat (fname, fbeg, flen);
16140 #ifdef VMS
16141           /* Change this 1/2 Unix 1/2 VMS file specification into a
16142              full VMS file specification */
16143           if (searchptr->fname && (searchptr->fname[0] != 0))
16144             {
16145               /* Fix up the filename */
16146               hack_vms_include_specification (fname);
16147             }
16148           else
16149             {
16150               /* This is a normal VMS filespec, so use it unchanged.  */
16151               strncpy (fname, (char *) fbeg, flen);
16152               fname[flen] = 0;
16153 #if 0   /* Not for g77.  */
16154               /* if it's '#include filename', add the missing .h */
16155               if (strchr (fname, '.') == NULL)
16156                 strcat (fname, ".h");
16157 #endif
16158             }
16159 #endif /* VMS */
16160           f = open_include_file (fname, searchptr);
16161 #ifdef EACCES
16162           if (f == NULL && errno == EACCES)
16163             {
16164               print_containing_files (FFEBAD_severityWARNING);
16165               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16166                                 FFEBAD_severityWARNING);
16167               ffebad_string (fname);
16168               ffebad_here (0, l, c);
16169               ffebad_finish ();
16170             }
16171 #endif
16172           if (f != NULL)
16173             break;
16174         }
16175     }
16176
16177   if (f == NULL)
16178     {
16179       /* A file that was not found.  */
16180
16181       strncpy (fname, (char *) fbeg, flen);
16182       fname[flen] = 0;
16183       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16184       ffebad_start (FFEBAD_OPEN_INCLUDE);
16185       ffebad_here (0, l, c);
16186       ffebad_string (fname);
16187       ffebad_finish ();
16188     }
16189
16190   if (dsp[0].fname != NULL)
16191     free (dsp[0].fname);
16192
16193   if (f == NULL)
16194     return NULL;
16195
16196   if (indepth >= (INPUT_STACK_MAX - 1))
16197     {
16198       print_containing_files (FFEBAD_severityFATAL);
16199       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16200                         FFEBAD_severityFATAL);
16201       ffebad_string (fname);
16202       ffebad_here (0, l, c);
16203       ffebad_finish ();
16204       return NULL;
16205     }
16206
16207   instack[indepth].line = ffewhere_line_use (l);
16208   instack[indepth].column = ffewhere_column_use (c);
16209
16210   fp = &instack[indepth + 1];
16211   memset ((char *) fp, 0, sizeof (FILE_BUF));
16212   fp->nominal_fname = fp->fname = fname;
16213   fp->dir = searchptr;
16214
16215   indepth++;
16216   input_file_stack_tick++;
16217
16218   return f;
16219 }
16220 #endif  /* FFECOM_GCC_INCLUDE */
16221
16222 /**INDENT* (Do not reformat this comment even with -fca option.)
16223    Data-gathering files: Given the source file listed below, compiled with
16224    f2c I obtained the output file listed after that, and from the output
16225    file I derived the above code.
16226
16227 -------- (begin input file to f2c)
16228         implicit none
16229         character*10 A1,A2
16230         complex C1,C2
16231         integer I1,I2
16232         real R1,R2
16233         double precision D1,D2
16234 C
16235         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16236 c /
16237         call fooI(I1/I2)
16238         call fooR(R1/I1)
16239         call fooD(D1/I1)
16240         call fooC(C1/I1)
16241         call fooR(R1/R2)
16242         call fooD(R1/D1)
16243         call fooD(D1/D2)
16244         call fooD(D1/R1)
16245         call fooC(C1/C2)
16246         call fooC(C1/R1)
16247         call fooZ(C1/D1)
16248 c **
16249         call fooI(I1**I2)
16250         call fooR(R1**I1)
16251         call fooD(D1**I1)
16252         call fooC(C1**I1)
16253         call fooR(R1**R2)
16254         call fooD(R1**D1)
16255         call fooD(D1**D2)
16256         call fooD(D1**R1)
16257         call fooC(C1**C2)
16258         call fooC(C1**R1)
16259         call fooZ(C1**D1)
16260 c FFEINTRIN_impABS
16261         call fooR(ABS(R1))
16262 c FFEINTRIN_impACOS
16263         call fooR(ACOS(R1))
16264 c FFEINTRIN_impAIMAG
16265         call fooR(AIMAG(C1))
16266 c FFEINTRIN_impAINT
16267         call fooR(AINT(R1))
16268 c FFEINTRIN_impALOG
16269         call fooR(ALOG(R1))
16270 c FFEINTRIN_impALOG10
16271         call fooR(ALOG10(R1))
16272 c FFEINTRIN_impAMAX0
16273         call fooR(AMAX0(I1,I2))
16274 c FFEINTRIN_impAMAX1
16275         call fooR(AMAX1(R1,R2))
16276 c FFEINTRIN_impAMIN0
16277         call fooR(AMIN0(I1,I2))
16278 c FFEINTRIN_impAMIN1
16279         call fooR(AMIN1(R1,R2))
16280 c FFEINTRIN_impAMOD
16281         call fooR(AMOD(R1,R2))
16282 c FFEINTRIN_impANINT
16283         call fooR(ANINT(R1))
16284 c FFEINTRIN_impASIN
16285         call fooR(ASIN(R1))
16286 c FFEINTRIN_impATAN
16287         call fooR(ATAN(R1))
16288 c FFEINTRIN_impATAN2
16289         call fooR(ATAN2(R1,R2))
16290 c FFEINTRIN_impCABS
16291         call fooR(CABS(C1))
16292 c FFEINTRIN_impCCOS
16293         call fooC(CCOS(C1))
16294 c FFEINTRIN_impCEXP
16295         call fooC(CEXP(C1))
16296 c FFEINTRIN_impCHAR
16297         call fooA(CHAR(I1))
16298 c FFEINTRIN_impCLOG
16299         call fooC(CLOG(C1))
16300 c FFEINTRIN_impCONJG
16301         call fooC(CONJG(C1))
16302 c FFEINTRIN_impCOS
16303         call fooR(COS(R1))
16304 c FFEINTRIN_impCOSH
16305         call fooR(COSH(R1))
16306 c FFEINTRIN_impCSIN
16307         call fooC(CSIN(C1))
16308 c FFEINTRIN_impCSQRT
16309         call fooC(CSQRT(C1))
16310 c FFEINTRIN_impDABS
16311         call fooD(DABS(D1))
16312 c FFEINTRIN_impDACOS
16313         call fooD(DACOS(D1))
16314 c FFEINTRIN_impDASIN
16315         call fooD(DASIN(D1))
16316 c FFEINTRIN_impDATAN
16317         call fooD(DATAN(D1))
16318 c FFEINTRIN_impDATAN2
16319         call fooD(DATAN2(D1,D2))
16320 c FFEINTRIN_impDCOS
16321         call fooD(DCOS(D1))
16322 c FFEINTRIN_impDCOSH
16323         call fooD(DCOSH(D1))
16324 c FFEINTRIN_impDDIM
16325         call fooD(DDIM(D1,D2))
16326 c FFEINTRIN_impDEXP
16327         call fooD(DEXP(D1))
16328 c FFEINTRIN_impDIM
16329         call fooR(DIM(R1,R2))
16330 c FFEINTRIN_impDINT
16331         call fooD(DINT(D1))
16332 c FFEINTRIN_impDLOG
16333         call fooD(DLOG(D1))
16334 c FFEINTRIN_impDLOG10
16335         call fooD(DLOG10(D1))
16336 c FFEINTRIN_impDMAX1
16337         call fooD(DMAX1(D1,D2))
16338 c FFEINTRIN_impDMIN1
16339         call fooD(DMIN1(D1,D2))
16340 c FFEINTRIN_impDMOD
16341         call fooD(DMOD(D1,D2))
16342 c FFEINTRIN_impDNINT
16343         call fooD(DNINT(D1))
16344 c FFEINTRIN_impDPROD
16345         call fooD(DPROD(R1,R2))
16346 c FFEINTRIN_impDSIGN
16347         call fooD(DSIGN(D1,D2))
16348 c FFEINTRIN_impDSIN
16349         call fooD(DSIN(D1))
16350 c FFEINTRIN_impDSINH
16351         call fooD(DSINH(D1))
16352 c FFEINTRIN_impDSQRT
16353         call fooD(DSQRT(D1))
16354 c FFEINTRIN_impDTAN
16355         call fooD(DTAN(D1))
16356 c FFEINTRIN_impDTANH
16357         call fooD(DTANH(D1))
16358 c FFEINTRIN_impEXP
16359         call fooR(EXP(R1))
16360 c FFEINTRIN_impIABS
16361         call fooI(IABS(I1))
16362 c FFEINTRIN_impICHAR
16363         call fooI(ICHAR(A1))
16364 c FFEINTRIN_impIDIM
16365         call fooI(IDIM(I1,I2))
16366 c FFEINTRIN_impIDNINT
16367         call fooI(IDNINT(D1))
16368 c FFEINTRIN_impINDEX
16369         call fooI(INDEX(A1,A2))
16370 c FFEINTRIN_impISIGN
16371         call fooI(ISIGN(I1,I2))
16372 c FFEINTRIN_impLEN
16373         call fooI(LEN(A1))
16374 c FFEINTRIN_impLGE
16375         call fooL(LGE(A1,A2))
16376 c FFEINTRIN_impLGT
16377         call fooL(LGT(A1,A2))
16378 c FFEINTRIN_impLLE
16379         call fooL(LLE(A1,A2))
16380 c FFEINTRIN_impLLT
16381         call fooL(LLT(A1,A2))
16382 c FFEINTRIN_impMAX0
16383         call fooI(MAX0(I1,I2))
16384 c FFEINTRIN_impMAX1
16385         call fooI(MAX1(R1,R2))
16386 c FFEINTRIN_impMIN0
16387         call fooI(MIN0(I1,I2))
16388 c FFEINTRIN_impMIN1
16389         call fooI(MIN1(R1,R2))
16390 c FFEINTRIN_impMOD
16391         call fooI(MOD(I1,I2))
16392 c FFEINTRIN_impNINT
16393         call fooI(NINT(R1))
16394 c FFEINTRIN_impSIGN
16395         call fooR(SIGN(R1,R2))
16396 c FFEINTRIN_impSIN
16397         call fooR(SIN(R1))
16398 c FFEINTRIN_impSINH
16399         call fooR(SINH(R1))
16400 c FFEINTRIN_impSQRT
16401         call fooR(SQRT(R1))
16402 c FFEINTRIN_impTAN
16403         call fooR(TAN(R1))
16404 c FFEINTRIN_impTANH
16405         call fooR(TANH(R1))
16406 c FFEINTRIN_imp_CMPLX_C
16407         call fooC(cmplx(C1,C2))
16408 c FFEINTRIN_imp_CMPLX_D
16409         call fooZ(cmplx(D1,D2))
16410 c FFEINTRIN_imp_CMPLX_I
16411         call fooC(cmplx(I1,I2))
16412 c FFEINTRIN_imp_CMPLX_R
16413         call fooC(cmplx(R1,R2))
16414 c FFEINTRIN_imp_DBLE_C
16415         call fooD(dble(C1))
16416 c FFEINTRIN_imp_DBLE_D
16417         call fooD(dble(D1))
16418 c FFEINTRIN_imp_DBLE_I
16419         call fooD(dble(I1))
16420 c FFEINTRIN_imp_DBLE_R
16421         call fooD(dble(R1))
16422 c FFEINTRIN_imp_INT_C
16423         call fooI(int(C1))
16424 c FFEINTRIN_imp_INT_D
16425         call fooI(int(D1))
16426 c FFEINTRIN_imp_INT_I
16427         call fooI(int(I1))
16428 c FFEINTRIN_imp_INT_R
16429         call fooI(int(R1))
16430 c FFEINTRIN_imp_REAL_C
16431         call fooR(real(C1))
16432 c FFEINTRIN_imp_REAL_D
16433         call fooR(real(D1))
16434 c FFEINTRIN_imp_REAL_I
16435         call fooR(real(I1))
16436 c FFEINTRIN_imp_REAL_R
16437         call fooR(real(R1))
16438 c
16439 c FFEINTRIN_imp_INT_D:
16440 c
16441 c FFEINTRIN_specIDINT
16442         call fooI(IDINT(D1))
16443 c
16444 c FFEINTRIN_imp_INT_R:
16445 c
16446 c FFEINTRIN_specIFIX
16447         call fooI(IFIX(R1))
16448 c FFEINTRIN_specINT
16449         call fooI(INT(R1))
16450 c
16451 c FFEINTRIN_imp_REAL_D:
16452 c
16453 c FFEINTRIN_specSNGL
16454         call fooR(SNGL(D1))
16455 c
16456 c FFEINTRIN_imp_REAL_I:
16457 c
16458 c FFEINTRIN_specFLOAT
16459         call fooR(FLOAT(I1))
16460 c FFEINTRIN_specREAL
16461         call fooR(REAL(I1))
16462 c
16463         end
16464 -------- (end input file to f2c)
16465
16466 -------- (begin output from providing above input file as input to:
16467 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16468 --------     -e "s:^#.*$::g"')
16469
16470 //  -- translated by f2c (version 19950223).
16471    You must link the resulting object file with the libraries:
16472         -lf2c -lm   (in that order)
16473 //
16474
16475
16476 // f2c.h  --  Standard Fortran to C header file //
16477
16478 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16479
16480         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16481
16482
16483
16484
16485 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16486 // we assume short, float are OK //
16487 typedef long int // long int // integer;
16488 typedef char *address;
16489 typedef short int shortint;
16490 typedef float real;
16491 typedef double doublereal;
16492 typedef struct { real r, i; } complex;
16493 typedef struct { doublereal r, i; } doublecomplex;
16494 typedef long int // long int // logical;
16495 typedef short int shortlogical;
16496 typedef char logical1;
16497 typedef char integer1;
16498 // typedef long long longint; // // system-dependent //
16499
16500
16501
16502
16503 // Extern is for use with -E //
16504
16505
16506
16507
16508 // I/O stuff //
16509
16510
16511
16512
16513
16514
16515
16516
16517 typedef long int // int or long int // flag;
16518 typedef long int // int or long int // ftnlen;
16519 typedef long int // int or long int // ftnint;
16520
16521
16522 //external read, write//
16523 typedef struct
16524 {       flag cierr;
16525         ftnint ciunit;
16526         flag ciend;
16527         char *cifmt;
16528         ftnint cirec;
16529 } cilist;
16530
16531 //internal read, write//
16532 typedef struct
16533 {       flag icierr;
16534         char *iciunit;
16535         flag iciend;
16536         char *icifmt;
16537         ftnint icirlen;
16538         ftnint icirnum;
16539 } icilist;
16540
16541 //open//
16542 typedef struct
16543 {       flag oerr;
16544         ftnint ounit;
16545         char *ofnm;
16546         ftnlen ofnmlen;
16547         char *osta;
16548         char *oacc;
16549         char *ofm;
16550         ftnint orl;
16551         char *oblnk;
16552 } olist;
16553
16554 //close//
16555 typedef struct
16556 {       flag cerr;
16557         ftnint cunit;
16558         char *csta;
16559 } cllist;
16560
16561 //rewind, backspace, endfile//
16562 typedef struct
16563 {       flag aerr;
16564         ftnint aunit;
16565 } alist;
16566
16567 // inquire //
16568 typedef struct
16569 {       flag inerr;
16570         ftnint inunit;
16571         char *infile;
16572         ftnlen infilen;
16573         ftnint  *inex;  //parameters in standard's order//
16574         ftnint  *inopen;
16575         ftnint  *innum;
16576         ftnint  *innamed;
16577         char    *inname;
16578         ftnlen  innamlen;
16579         char    *inacc;
16580         ftnlen  inacclen;
16581         char    *inseq;
16582         ftnlen  inseqlen;
16583         char    *indir;
16584         ftnlen  indirlen;
16585         char    *infmt;
16586         ftnlen  infmtlen;
16587         char    *inform;
16588         ftnint  informlen;
16589         char    *inunf;
16590         ftnlen  inunflen;
16591         ftnint  *inrecl;
16592         ftnint  *innrec;
16593         char    *inblank;
16594         ftnlen  inblanklen;
16595 } inlist;
16596
16597
16598
16599 union Multitype {       // for multiple entry points //
16600         integer1 g;
16601         shortint h;
16602         integer i;
16603         // longint j; //
16604         real r;
16605         doublereal d;
16606         complex c;
16607         doublecomplex z;
16608         };
16609
16610 typedef union Multitype Multitype;
16611
16612 typedef long Long;      // No longer used; formerly in Namelist //
16613
16614 struct Vardesc {        // for Namelist //
16615         char *name;
16616         char *addr;
16617         ftnlen *dims;
16618         int  type;
16619         };
16620 typedef struct Vardesc Vardesc;
16621
16622 struct Namelist {
16623         char *name;
16624         Vardesc **vars;
16625         int nvars;
16626         };
16627 typedef struct Namelist Namelist;
16628
16629
16630
16631
16632
16633
16634
16635
16636 // procedure parameter types for -A and -C++ //
16637
16638
16639
16640
16641 typedef int // Unknown procedure type // (*U_fp)();
16642 typedef shortint (*J_fp)();
16643 typedef integer (*I_fp)();
16644 typedef real (*R_fp)();
16645 typedef doublereal (*D_fp)(), (*E_fp)();
16646 typedef // Complex // void  (*C_fp)();
16647 typedef // Double Complex // void  (*Z_fp)();
16648 typedef logical (*L_fp)();
16649 typedef shortlogical (*K_fp)();
16650 typedef // Character // void  (*H_fp)();
16651 typedef // Subroutine // int (*S_fp)();
16652
16653 // E_fp is for real functions when -R is not specified //
16654 typedef void  C_f;      // complex function //
16655 typedef void  H_f;      // character function //
16656 typedef void  Z_f;      // double complex function //
16657 typedef doublereal E_f; // real function with -R not specified //
16658
16659 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16660
16661
16662 // (No such symbols should be defined in a strict ANSI C compiler.
16663    We can avoid trouble with f2c-translated code by using
16664    gcc -ansi [-traditional].) //
16665
16666
16667
16668
16669
16670
16671
16672
16673
16674
16675
16676
16677
16678
16679
16680
16681
16682
16683
16684
16685
16686
16687
16688 // Main program // MAIN__()
16689 {
16690     // System generated locals //
16691     integer i__1;
16692     real r__1, r__2;
16693     doublereal d__1, d__2;
16694     complex q__1;
16695     doublecomplex z__1, z__2, z__3;
16696     logical L__1;
16697     char ch__1[1];
16698
16699     // Builtin functions //
16700     void c_div();
16701     integer pow_ii();
16702     double pow_ri(), pow_di();
16703     void pow_ci();
16704     double pow_dd();
16705     void pow_zz();
16706     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16707             asin(), atan(), atan2(), c_abs();
16708     void c_cos(), c_exp(), c_log(), r_cnjg();
16709     double cos(), cosh();
16710     void c_sin(), c_sqrt();
16711     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16712             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16713     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16714     logical l_ge(), l_gt(), l_le(), l_lt();
16715     integer i_nint();
16716     double r_sign();
16717
16718     // Local variables //
16719     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16720             fool_(), fooz_(), getem_();
16721     static char a1[10], a2[10];
16722     static complex c1, c2;
16723     static doublereal d1, d2;
16724     static integer i1, i2;
16725     static real r1, r2;
16726
16727
16728     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16729 // / //
16730     i__1 = i1 / i2;
16731     fooi_(&i__1);
16732     r__1 = r1 / i1;
16733     foor_(&r__1);
16734     d__1 = d1 / i1;
16735     food_(&d__1);
16736     d__1 = (doublereal) i1;
16737     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16738     fooc_(&q__1);
16739     r__1 = r1 / r2;
16740     foor_(&r__1);
16741     d__1 = r1 / d1;
16742     food_(&d__1);
16743     d__1 = d1 / d2;
16744     food_(&d__1);
16745     d__1 = d1 / r1;
16746     food_(&d__1);
16747     c_div(&q__1, &c1, &c2);
16748     fooc_(&q__1);
16749     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16750     fooc_(&q__1);
16751     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16752     fooz_(&z__1);
16753 // ** //
16754     i__1 = pow_ii(&i1, &i2);
16755     fooi_(&i__1);
16756     r__1 = pow_ri(&r1, &i1);
16757     foor_(&r__1);
16758     d__1 = pow_di(&d1, &i1);
16759     food_(&d__1);
16760     pow_ci(&q__1, &c1, &i1);
16761     fooc_(&q__1);
16762     d__1 = (doublereal) r1;
16763     d__2 = (doublereal) r2;
16764     r__1 = pow_dd(&d__1, &d__2);
16765     foor_(&r__1);
16766     d__2 = (doublereal) r1;
16767     d__1 = pow_dd(&d__2, &d1);
16768     food_(&d__1);
16769     d__1 = pow_dd(&d1, &d2);
16770     food_(&d__1);
16771     d__2 = (doublereal) r1;
16772     d__1 = pow_dd(&d1, &d__2);
16773     food_(&d__1);
16774     z__2.r = c1.r, z__2.i = c1.i;
16775     z__3.r = c2.r, z__3.i = c2.i;
16776     pow_zz(&z__1, &z__2, &z__3);
16777     q__1.r = z__1.r, q__1.i = z__1.i;
16778     fooc_(&q__1);
16779     z__2.r = c1.r, z__2.i = c1.i;
16780     z__3.r = r1, z__3.i = 0.;
16781     pow_zz(&z__1, &z__2, &z__3);
16782     q__1.r = z__1.r, q__1.i = z__1.i;
16783     fooc_(&q__1);
16784     z__2.r = c1.r, z__2.i = c1.i;
16785     z__3.r = d1, z__3.i = 0.;
16786     pow_zz(&z__1, &z__2, &z__3);
16787     fooz_(&z__1);
16788 // FFEINTRIN_impABS //
16789     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16790     foor_(&r__1);
16791 // FFEINTRIN_impACOS //
16792     r__1 = acos(r1);
16793     foor_(&r__1);
16794 // FFEINTRIN_impAIMAG //
16795     r__1 = r_imag(&c1);
16796     foor_(&r__1);
16797 // FFEINTRIN_impAINT //
16798     r__1 = r_int(&r1);
16799     foor_(&r__1);
16800 // FFEINTRIN_impALOG //
16801     r__1 = log(r1);
16802     foor_(&r__1);
16803 // FFEINTRIN_impALOG10 //
16804     r__1 = r_lg10(&r1);
16805     foor_(&r__1);
16806 // FFEINTRIN_impAMAX0 //
16807     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16808     foor_(&r__1);
16809 // FFEINTRIN_impAMAX1 //
16810     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16811     foor_(&r__1);
16812 // FFEINTRIN_impAMIN0 //
16813     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16814     foor_(&r__1);
16815 // FFEINTRIN_impAMIN1 //
16816     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16817     foor_(&r__1);
16818 // FFEINTRIN_impAMOD //
16819     r__1 = r_mod(&r1, &r2);
16820     foor_(&r__1);
16821 // FFEINTRIN_impANINT //
16822     r__1 = r_nint(&r1);
16823     foor_(&r__1);
16824 // FFEINTRIN_impASIN //
16825     r__1 = asin(r1);
16826     foor_(&r__1);
16827 // FFEINTRIN_impATAN //
16828     r__1 = atan(r1);
16829     foor_(&r__1);
16830 // FFEINTRIN_impATAN2 //
16831     r__1 = atan2(r1, r2);
16832     foor_(&r__1);
16833 // FFEINTRIN_impCABS //
16834     r__1 = c_abs(&c1);
16835     foor_(&r__1);
16836 // FFEINTRIN_impCCOS //
16837     c_cos(&q__1, &c1);
16838     fooc_(&q__1);
16839 // FFEINTRIN_impCEXP //
16840     c_exp(&q__1, &c1);
16841     fooc_(&q__1);
16842 // FFEINTRIN_impCHAR //
16843     *(unsigned char *)&ch__1[0] = i1;
16844     fooa_(ch__1, 1L);
16845 // FFEINTRIN_impCLOG //
16846     c_log(&q__1, &c1);
16847     fooc_(&q__1);
16848 // FFEINTRIN_impCONJG //
16849     r_cnjg(&q__1, &c1);
16850     fooc_(&q__1);
16851 // FFEINTRIN_impCOS //
16852     r__1 = cos(r1);
16853     foor_(&r__1);
16854 // FFEINTRIN_impCOSH //
16855     r__1 = cosh(r1);
16856     foor_(&r__1);
16857 // FFEINTRIN_impCSIN //
16858     c_sin(&q__1, &c1);
16859     fooc_(&q__1);
16860 // FFEINTRIN_impCSQRT //
16861     c_sqrt(&q__1, &c1);
16862     fooc_(&q__1);
16863 // FFEINTRIN_impDABS //
16864     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16865     food_(&d__1);
16866 // FFEINTRIN_impDACOS //
16867     d__1 = acos(d1);
16868     food_(&d__1);
16869 // FFEINTRIN_impDASIN //
16870     d__1 = asin(d1);
16871     food_(&d__1);
16872 // FFEINTRIN_impDATAN //
16873     d__1 = atan(d1);
16874     food_(&d__1);
16875 // FFEINTRIN_impDATAN2 //
16876     d__1 = atan2(d1, d2);
16877     food_(&d__1);
16878 // FFEINTRIN_impDCOS //
16879     d__1 = cos(d1);
16880     food_(&d__1);
16881 // FFEINTRIN_impDCOSH //
16882     d__1 = cosh(d1);
16883     food_(&d__1);
16884 // FFEINTRIN_impDDIM //
16885     d__1 = d_dim(&d1, &d2);
16886     food_(&d__1);
16887 // FFEINTRIN_impDEXP //
16888     d__1 = exp(d1);
16889     food_(&d__1);
16890 // FFEINTRIN_impDIM //
16891     r__1 = r_dim(&r1, &r2);
16892     foor_(&r__1);
16893 // FFEINTRIN_impDINT //
16894     d__1 = d_int(&d1);
16895     food_(&d__1);
16896 // FFEINTRIN_impDLOG //
16897     d__1 = log(d1);
16898     food_(&d__1);
16899 // FFEINTRIN_impDLOG10 //
16900     d__1 = d_lg10(&d1);
16901     food_(&d__1);
16902 // FFEINTRIN_impDMAX1 //
16903     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16904     food_(&d__1);
16905 // FFEINTRIN_impDMIN1 //
16906     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16907     food_(&d__1);
16908 // FFEINTRIN_impDMOD //
16909     d__1 = d_mod(&d1, &d2);
16910     food_(&d__1);
16911 // FFEINTRIN_impDNINT //
16912     d__1 = d_nint(&d1);
16913     food_(&d__1);
16914 // FFEINTRIN_impDPROD //
16915     d__1 = (doublereal) r1 * r2;
16916     food_(&d__1);
16917 // FFEINTRIN_impDSIGN //
16918     d__1 = d_sign(&d1, &d2);
16919     food_(&d__1);
16920 // FFEINTRIN_impDSIN //
16921     d__1 = sin(d1);
16922     food_(&d__1);
16923 // FFEINTRIN_impDSINH //
16924     d__1 = sinh(d1);
16925     food_(&d__1);
16926 // FFEINTRIN_impDSQRT //
16927     d__1 = sqrt(d1);
16928     food_(&d__1);
16929 // FFEINTRIN_impDTAN //
16930     d__1 = tan(d1);
16931     food_(&d__1);
16932 // FFEINTRIN_impDTANH //
16933     d__1 = tanh(d1);
16934     food_(&d__1);
16935 // FFEINTRIN_impEXP //
16936     r__1 = exp(r1);
16937     foor_(&r__1);
16938 // FFEINTRIN_impIABS //
16939     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16940     fooi_(&i__1);
16941 // FFEINTRIN_impICHAR //
16942     i__1 = *(unsigned char *)a1;
16943     fooi_(&i__1);
16944 // FFEINTRIN_impIDIM //
16945     i__1 = i_dim(&i1, &i2);
16946     fooi_(&i__1);
16947 // FFEINTRIN_impIDNINT //
16948     i__1 = i_dnnt(&d1);
16949     fooi_(&i__1);
16950 // FFEINTRIN_impINDEX //
16951     i__1 = i_indx(a1, a2, 10L, 10L);
16952     fooi_(&i__1);
16953 // FFEINTRIN_impISIGN //
16954     i__1 = i_sign(&i1, &i2);
16955     fooi_(&i__1);
16956 // FFEINTRIN_impLEN //
16957     i__1 = i_len(a1, 10L);
16958     fooi_(&i__1);
16959 // FFEINTRIN_impLGE //
16960     L__1 = l_ge(a1, a2, 10L, 10L);
16961     fool_(&L__1);
16962 // FFEINTRIN_impLGT //
16963     L__1 = l_gt(a1, a2, 10L, 10L);
16964     fool_(&L__1);
16965 // FFEINTRIN_impLLE //
16966     L__1 = l_le(a1, a2, 10L, 10L);
16967     fool_(&L__1);
16968 // FFEINTRIN_impLLT //
16969     L__1 = l_lt(a1, a2, 10L, 10L);
16970     fool_(&L__1);
16971 // FFEINTRIN_impMAX0 //
16972     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16973     fooi_(&i__1);
16974 // FFEINTRIN_impMAX1 //
16975     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16976     fooi_(&i__1);
16977 // FFEINTRIN_impMIN0 //
16978     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16979     fooi_(&i__1);
16980 // FFEINTRIN_impMIN1 //
16981     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16982     fooi_(&i__1);
16983 // FFEINTRIN_impMOD //
16984     i__1 = i1 % i2;
16985     fooi_(&i__1);
16986 // FFEINTRIN_impNINT //
16987     i__1 = i_nint(&r1);
16988     fooi_(&i__1);
16989 // FFEINTRIN_impSIGN //
16990     r__1 = r_sign(&r1, &r2);
16991     foor_(&r__1);
16992 // FFEINTRIN_impSIN //
16993     r__1 = sin(r1);
16994     foor_(&r__1);
16995 // FFEINTRIN_impSINH //
16996     r__1 = sinh(r1);
16997     foor_(&r__1);
16998 // FFEINTRIN_impSQRT //
16999     r__1 = sqrt(r1);
17000     foor_(&r__1);
17001 // FFEINTRIN_impTAN //
17002     r__1 = tan(r1);
17003     foor_(&r__1);
17004 // FFEINTRIN_impTANH //
17005     r__1 = tanh(r1);
17006     foor_(&r__1);
17007 // FFEINTRIN_imp_CMPLX_C //
17008     r__1 = c1.r;
17009     r__2 = c2.r;
17010     q__1.r = r__1, q__1.i = r__2;
17011     fooc_(&q__1);
17012 // FFEINTRIN_imp_CMPLX_D //
17013     z__1.r = d1, z__1.i = d2;
17014     fooz_(&z__1);
17015 // FFEINTRIN_imp_CMPLX_I //
17016     r__1 = (real) i1;
17017     r__2 = (real) i2;
17018     q__1.r = r__1, q__1.i = r__2;
17019     fooc_(&q__1);
17020 // FFEINTRIN_imp_CMPLX_R //
17021     q__1.r = r1, q__1.i = r2;
17022     fooc_(&q__1);
17023 // FFEINTRIN_imp_DBLE_C //
17024     d__1 = (doublereal) c1.r;
17025     food_(&d__1);
17026 // FFEINTRIN_imp_DBLE_D //
17027     d__1 = d1;
17028     food_(&d__1);
17029 // FFEINTRIN_imp_DBLE_I //
17030     d__1 = (doublereal) i1;
17031     food_(&d__1);
17032 // FFEINTRIN_imp_DBLE_R //
17033     d__1 = (doublereal) r1;
17034     food_(&d__1);
17035 // FFEINTRIN_imp_INT_C //
17036     i__1 = (integer) c1.r;
17037     fooi_(&i__1);
17038 // FFEINTRIN_imp_INT_D //
17039     i__1 = (integer) d1;
17040     fooi_(&i__1);
17041 // FFEINTRIN_imp_INT_I //
17042     i__1 = i1;
17043     fooi_(&i__1);
17044 // FFEINTRIN_imp_INT_R //
17045     i__1 = (integer) r1;
17046     fooi_(&i__1);
17047 // FFEINTRIN_imp_REAL_C //
17048     r__1 = c1.r;
17049     foor_(&r__1);
17050 // FFEINTRIN_imp_REAL_D //
17051     r__1 = (real) d1;
17052     foor_(&r__1);
17053 // FFEINTRIN_imp_REAL_I //
17054     r__1 = (real) i1;
17055     foor_(&r__1);
17056 // FFEINTRIN_imp_REAL_R //
17057     r__1 = r1;
17058     foor_(&r__1);
17059
17060 // FFEINTRIN_imp_INT_D: //
17061
17062 // FFEINTRIN_specIDINT //
17063     i__1 = (integer) d1;
17064     fooi_(&i__1);
17065
17066 // FFEINTRIN_imp_INT_R: //
17067
17068 // FFEINTRIN_specIFIX //
17069     i__1 = (integer) r1;
17070     fooi_(&i__1);
17071 // FFEINTRIN_specINT //
17072     i__1 = (integer) r1;
17073     fooi_(&i__1);
17074
17075 // FFEINTRIN_imp_REAL_D: //
17076
17077 // FFEINTRIN_specSNGL //
17078     r__1 = (real) d1;
17079     foor_(&r__1);
17080
17081 // FFEINTRIN_imp_REAL_I: //
17082
17083 // FFEINTRIN_specFLOAT //
17084     r__1 = (real) i1;
17085     foor_(&r__1);
17086 // FFEINTRIN_specREAL //
17087     r__1 = (real) i1;
17088     foor_(&r__1);
17089
17090 } // MAIN__ //
17091
17092 -------- (end output file from f2c)
17093
17094 */