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   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11415   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11416   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11417                         char_type_node));
11418   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11419                         long_integer_type_node));
11420   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11421                         unsigned_type_node));
11422   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11423                         long_unsigned_type_node));
11424   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11425                         long_long_integer_type_node));
11426   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11427                         long_long_unsigned_type_node));
11428   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11429                         short_integer_type_node));
11430   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11431                         short_unsigned_type_node));
11432
11433   /* Set the sizetype before we make other types.  This *should* be the
11434      first type we create.  */
11435
11436   set_sizetype
11437     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11438   ffecom_typesize_pointer_
11439     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11440
11441   build_common_tree_nodes_2 (0);
11442
11443   /* Define both `signed char' and `unsigned char'.  */
11444   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11445                         signed_char_type_node));
11446
11447   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11448                         unsigned_char_type_node));
11449
11450   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11451                         float_type_node));
11452   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11453                         double_type_node));
11454   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11455                         long_double_type_node));
11456
11457   /* For now, override what build_common_tree_nodes has done.  */
11458   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11459   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11460   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11461   complex_long_double_type_node
11462     = ffecom_make_complex_type_ (long_double_type_node);
11463
11464   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11465                         complex_integer_type_node));
11466   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11467                         complex_float_type_node));
11468   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11469                         complex_double_type_node));
11470   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11471                         complex_long_double_type_node));
11472
11473   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11474                         void_type_node));
11475   /* We are not going to have real types in C with less than byte alignment,
11476      so we might as well not have any types that claim to have it.  */
11477   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11478   TYPE_USER_ALIGN (void_type_node) = 0;
11479
11480   string_type_node = build_pointer_type (char_type_node);
11481
11482   ffecom_tree_fun_type_void
11483     = build_function_type (void_type_node, NULL_TREE);
11484
11485   ffecom_tree_ptr_to_fun_type_void
11486     = build_pointer_type (ffecom_tree_fun_type_void);
11487
11488   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11489
11490   float_ftype_float
11491     = build_function_type (float_type_node,
11492                            tree_cons (NULL_TREE, float_type_node, endlink));
11493
11494   double_ftype_double
11495     = build_function_type (double_type_node,
11496                            tree_cons (NULL_TREE, double_type_node, endlink));
11497
11498   ldouble_ftype_ldouble
11499     = build_function_type (long_double_type_node,
11500                            tree_cons (NULL_TREE, long_double_type_node,
11501                                       endlink));
11502
11503   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11504     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11505       {
11506         ffecom_tree_type[i][j] = NULL_TREE;
11507         ffecom_tree_fun_type[i][j] = NULL_TREE;
11508         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11509         ffecom_f2c_typecode_[i][j] = -1;
11510       }
11511
11512   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11513      to size FLOAT_TYPE_SIZE because they have to be the same size as
11514      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11515      Compiler options and other such stuff that change the ways these
11516      types are set should not affect this particular setup.  */
11517
11518   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11519     = t = make_signed_type (FLOAT_TYPE_SIZE);
11520   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11521                         t));
11522   type = ffetype_new ();
11523   base_type = type;
11524   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11525                     type);
11526   ffetype_set_ams (type,
11527                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11528                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11529   ffetype_set_star (base_type,
11530                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11531                     type);
11532   ffetype_set_kind (base_type, 1, type);
11533   ffecom_typesize_integer1_ = ffetype_size (type);
11534   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11535
11536   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11537     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11538   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11539                         t));
11540
11541   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11542     = t = make_signed_type (CHAR_TYPE_SIZE);
11543   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11544                         t));
11545   type = ffetype_new ();
11546   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11547                     type);
11548   ffetype_set_ams (type,
11549                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11550                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11551   ffetype_set_star (base_type,
11552                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11553                     type);
11554   ffetype_set_kind (base_type, 3, type);
11555   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11556
11557   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11558     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11559   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11560                         t));
11561
11562   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11563     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11564   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11565                         t));
11566   type = ffetype_new ();
11567   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11568                     type);
11569   ffetype_set_ams (type,
11570                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11571                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11572   ffetype_set_star (base_type,
11573                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11574                     type);
11575   ffetype_set_kind (base_type, 6, type);
11576   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11577
11578   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11579     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11580   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11581                         t));
11582
11583   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11584     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11585   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11586                         t));
11587   type = ffetype_new ();
11588   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11589                     type);
11590   ffetype_set_ams (type,
11591                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11592                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11593   ffetype_set_star (base_type,
11594                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11595                     type);
11596   ffetype_set_kind (base_type, 2, type);
11597   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11598
11599   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11600     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11601   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11602                         t));
11603
11604 #if 0
11605   if (ffe_is_do_internal_checks ()
11606       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11607       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11608       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11609       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11610     {
11611       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11612                LONG_TYPE_SIZE);
11613     }
11614 #endif
11615
11616   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11617     = t = make_signed_type (FLOAT_TYPE_SIZE);
11618   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11619                         t));
11620   type = ffetype_new ();
11621   base_type = type;
11622   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11623                     type);
11624   ffetype_set_ams (type,
11625                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11626                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11627   ffetype_set_star (base_type,
11628                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11629                     type);
11630   ffetype_set_kind (base_type, 1, type);
11631   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11632
11633   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11634     = t = make_signed_type (CHAR_TYPE_SIZE);
11635   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11636                         t));
11637   type = ffetype_new ();
11638   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11639                     type);
11640   ffetype_set_ams (type,
11641                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11642                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11643   ffetype_set_star (base_type,
11644                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11645                     type);
11646   ffetype_set_kind (base_type, 3, type);
11647   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11648
11649   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11650     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11651   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11652                         t));
11653   type = ffetype_new ();
11654   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11655                     type);
11656   ffetype_set_ams (type,
11657                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11658                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11659   ffetype_set_star (base_type,
11660                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11661                     type);
11662   ffetype_set_kind (base_type, 6, type);
11663   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11664
11665   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11666     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11667   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11668                         t));
11669   type = ffetype_new ();
11670   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11671                     type);
11672   ffetype_set_ams (type,
11673                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11674                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11675   ffetype_set_star (base_type,
11676                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11677                     type);
11678   ffetype_set_kind (base_type, 2, type);
11679   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11680
11681   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11682     = t = make_node (REAL_TYPE);
11683   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11684   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11685                         t));
11686   layout_type (t);
11687   type = ffetype_new ();
11688   base_type = type;
11689   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11690                     type);
11691   ffetype_set_ams (type,
11692                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11693                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11694   ffetype_set_star (base_type,
11695                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11696                     type);
11697   ffetype_set_kind (base_type, 1, type);
11698   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11699     = FFETARGET_f2cTYREAL;
11700   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11701
11702   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11703     = t = make_node (REAL_TYPE);
11704   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11705   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11706                         t));
11707   layout_type (t);
11708   type = ffetype_new ();
11709   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11710                     type);
11711   ffetype_set_ams (type,
11712                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11713                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11714   ffetype_set_star (base_type,
11715                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11716                     type);
11717   ffetype_set_kind (base_type, 2, type);
11718   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11719     = FFETARGET_f2cTYDREAL;
11720   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11721
11722   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11723     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11724   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11725                         t));
11726   type = ffetype_new ();
11727   base_type = type;
11728   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11729                     type);
11730   ffetype_set_ams (type,
11731                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11732                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11733   ffetype_set_star (base_type,
11734                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11735                     type);
11736   ffetype_set_kind (base_type, 1, type);
11737   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11738     = FFETARGET_f2cTYCOMPLEX;
11739   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11740
11741   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11742     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11743   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11744                         t));
11745   type = ffetype_new ();
11746   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11747                     type);
11748   ffetype_set_ams (type,
11749                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11750                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11751   ffetype_set_star (base_type,
11752                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11753                     type);
11754   ffetype_set_kind (base_type, 2,
11755                     type);
11756   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11757     = FFETARGET_f2cTYDCOMPLEX;
11758   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11759
11760   /* Make function and ptr-to-function types for non-CHARACTER types. */
11761
11762   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11763     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11764       {
11765         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11766           {
11767             if (i == FFEINFO_basictypeINTEGER)
11768               {
11769                 /* Figure out the smallest INTEGER type that can hold
11770                    a pointer on this machine. */
11771                 if (GET_MODE_SIZE (TYPE_MODE (t))
11772                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11773                   {
11774                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11775                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11776                             > GET_MODE_SIZE (TYPE_MODE (t))))
11777                       ffecom_pointer_kind_ = j;
11778                   }
11779               }
11780             else if (i == FFEINFO_basictypeCOMPLEX)
11781               t = void_type_node;
11782             /* For f2c compatibility, REAL functions are really
11783                implemented as DOUBLE PRECISION.  */
11784             else if ((i == FFEINFO_basictypeREAL)
11785                      && (j == FFEINFO_kindtypeREAL1))
11786               t = ffecom_tree_type
11787                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11788
11789             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11790                                                                   NULL_TREE);
11791             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11792           }
11793       }
11794
11795   /* Set up pointer types.  */
11796
11797   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11798     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11799   else if (0 && ffe_is_do_internal_checks ())
11800     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11801   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11802                                   FFEINFO_kindtypeINTEGERDEFAULT),
11803                     7,
11804                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11805                                   ffecom_pointer_kind_));
11806
11807   if (ffe_is_ugly_assign ())
11808     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11809   else
11810     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11811   if (0 && ffe_is_do_internal_checks ())
11812     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11813
11814   ffecom_integer_type_node
11815     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11816   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11817                                       integer_zero_node);
11818   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11819                                      integer_one_node);
11820
11821   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11822      Turns out that by TYLONG, runtime/libI77/lio.h really means
11823      "whatever size an ftnint is".  For consistency and sanity,
11824      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11825      all are INTEGER, which we also make out of whatever back-end
11826      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11827      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11828      accommodate machines like the Alpha.  Note that this suggests
11829      f2c and libf2c are missing a distinction perhaps needed on
11830      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11831
11832   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11833                             FFETARGET_f2cTYLONG);
11834   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11835                             FFETARGET_f2cTYSHORT);
11836   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11837                             FFETARGET_f2cTYINT1);
11838   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11839                             FFETARGET_f2cTYQUAD);
11840   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11841                             FFETARGET_f2cTYLOGICAL);
11842   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11843                             FFETARGET_f2cTYLOGICAL2);
11844   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11845                             FFETARGET_f2cTYLOGICAL1);
11846   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11847   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11848                             FFETARGET_f2cTYQUAD);
11849
11850   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11851      loop.  CHARACTER items are built as arrays of unsigned char.  */
11852
11853   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11854     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11855   type = ffetype_new ();
11856   base_type = type;
11857   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11858                     FFEINFO_kindtypeCHARACTER1,
11859                     type);
11860   ffetype_set_ams (type,
11861                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11862                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11863   ffetype_set_kind (base_type, 1, type);
11864   assert (ffetype_size (type)
11865           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11866
11867   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11868     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11869   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11870     [FFEINFO_kindtypeCHARACTER1]
11871     = ffecom_tree_ptr_to_fun_type_void;
11872   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11873     = FFETARGET_f2cTYCHAR;
11874
11875   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11876     = 0;
11877
11878   /* Make multi-return-value type and fields. */
11879
11880   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11881
11882   field = NULL_TREE;
11883
11884   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11885     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11886       {
11887         char name[30];
11888
11889         if (ffecom_tree_type[i][j] == NULL_TREE)
11890           continue;             /* Not supported. */
11891         sprintf (&name[0], "bt_%s_kt_%s",
11892                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11893                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11894         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11895                                                  get_identifier (name),
11896                                                  ffecom_tree_type[i][j]);
11897         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11898           = ffecom_multi_type_node_;
11899         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11900         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11901         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11902         field = ffecom_multi_fields_[i][j];
11903       }
11904
11905   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11906   layout_type (ffecom_multi_type_node_);
11907
11908   /* Subroutines usually return integer because they might have alternate
11909      returns. */
11910
11911   ffecom_tree_subr_type
11912     = build_function_type (integer_type_node, NULL_TREE);
11913   ffecom_tree_ptr_to_subr_type
11914     = build_pointer_type (ffecom_tree_subr_type);
11915   ffecom_tree_blockdata_type
11916     = build_function_type (void_type_node, NULL_TREE);
11917
11918   builtin_function ("__builtin_sqrtf", float_ftype_float,
11919                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11920   builtin_function ("__builtin_fsqrt", double_ftype_double,
11921                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11922   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11923                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11924   builtin_function ("__builtin_sinf", float_ftype_float,
11925                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11926   builtin_function ("__builtin_sin", double_ftype_double,
11927                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11928   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11929                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11930   builtin_function ("__builtin_cosf", float_ftype_float,
11931                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11932   builtin_function ("__builtin_cos", double_ftype_double,
11933                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11934   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11935                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11936
11937 #if BUILT_FOR_270
11938   pedantic_lvalues = FALSE;
11939 #endif
11940
11941   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11942                          FFECOM_f2cINTEGER,
11943                          "integer");
11944   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11945                          FFECOM_f2cADDRESS,
11946                          "address");
11947   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11948                          FFECOM_f2cREAL,
11949                          "real");
11950   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11951                          FFECOM_f2cDOUBLEREAL,
11952                          "doublereal");
11953   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11954                          FFECOM_f2cCOMPLEX,
11955                          "complex");
11956   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11957                          FFECOM_f2cDOUBLECOMPLEX,
11958                          "doublecomplex");
11959   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11960                          FFECOM_f2cLONGINT,
11961                          "longint");
11962   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11963                          FFECOM_f2cLOGICAL,
11964                          "logical");
11965   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11966                          FFECOM_f2cFLAG,
11967                          "flag");
11968   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11969                          FFECOM_f2cFTNLEN,
11970                          "ftnlen");
11971   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11972                          FFECOM_f2cFTNINT,
11973                          "ftnint");
11974
11975   ffecom_f2c_ftnlen_zero_node
11976     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11977
11978   ffecom_f2c_ftnlen_one_node
11979     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11980
11981   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11982   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11983
11984   ffecom_f2c_ptr_to_ftnlen_type_node
11985     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11986
11987   ffecom_f2c_ptr_to_ftnint_type_node
11988     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11989
11990   ffecom_f2c_ptr_to_integer_type_node
11991     = build_pointer_type (ffecom_f2c_integer_type_node);
11992
11993   ffecom_f2c_ptr_to_real_type_node
11994     = build_pointer_type (ffecom_f2c_real_type_node);
11995
11996   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11997   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11998   {
11999     REAL_VALUE_TYPE point_5;
12000
12001 #ifdef REAL_ARITHMETIC
12002     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12003 #else
12004     point_5 = .5;
12005 #endif
12006     ffecom_float_half_ = build_real (float_type_node, point_5);
12007     ffecom_double_half_ = build_real (double_type_node, point_5);
12008   }
12009
12010   /* Do "extern int xargc;".  */
12011
12012   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12013                                    get_identifier ("f__xargc"),
12014                                    integer_type_node);
12015   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12016   TREE_STATIC (ffecom_tree_xargc_) = 1;
12017   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12018   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12019   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12020
12021 #if 0   /* This is being fixed, and seems to be working now. */
12022   if ((FLOAT_TYPE_SIZE != 32)
12023       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12024     {
12025       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12026                (int) FLOAT_TYPE_SIZE);
12027       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12028           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12029       warning ("properly unless they all are 32 bits wide.");
12030       warning ("Please keep this in mind before you report bugs.  g77 should");
12031       warning ("support non-32-bit machines better as of version 0.6.");
12032     }
12033 #endif
12034
12035 #if 0   /* Code in ste.c that would crash has been commented out. */
12036   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12037       < TYPE_PRECISION (string_type_node))
12038     /* I/O will probably crash.  */
12039     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12040              TYPE_PRECISION (string_type_node),
12041              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12042 #endif
12043
12044 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12045   if (TYPE_PRECISION (ffecom_integer_type_node)
12046       < TYPE_PRECISION (string_type_node))
12047     /* ASSIGN 10 TO I will crash.  */
12048     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12049  ASSIGN statement might fail",
12050              TYPE_PRECISION (string_type_node),
12051              TYPE_PRECISION (ffecom_integer_type_node));
12052 #endif
12053 }
12054
12055 #endif
12056 /* ffecom_init_2 -- Initialize
12057
12058    ffecom_init_2();  */
12059
12060 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12061 void
12062 ffecom_init_2 ()
12063 {
12064   assert (ffecom_outer_function_decl_ == NULL_TREE);
12065   assert (current_function_decl == NULL_TREE);
12066   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12067
12068   ffecom_master_arglist_ = NULL;
12069   ++ffecom_num_fns_;
12070   ffecom_primary_entry_ = NULL;
12071   ffecom_is_altreturning_ = FALSE;
12072   ffecom_func_result_ = NULL_TREE;
12073   ffecom_multi_retval_ = NULL_TREE;
12074 }
12075
12076 #endif
12077 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12078
12079    tree t;
12080    ffebld expr;  // FFE opITEM list.
12081    tree = ffecom_list_expr(expr);
12082
12083    List of actual args is transformed into corresponding gcc backend list.  */
12084
12085 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12086 tree
12087 ffecom_list_expr (ffebld expr)
12088 {
12089   tree list;
12090   tree *plist = &list;
12091   tree trail = NULL_TREE;       /* Append char length args here. */
12092   tree *ptrail = &trail;
12093   tree length;
12094
12095   while (expr != NULL)
12096     {
12097       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12098
12099       if (texpr == error_mark_node)
12100         return error_mark_node;
12101
12102       *plist = build_tree_list (NULL_TREE, texpr);
12103       plist = &TREE_CHAIN (*plist);
12104       expr = ffebld_trail (expr);
12105       if (length != NULL_TREE)
12106         {
12107           *ptrail = build_tree_list (NULL_TREE, length);
12108           ptrail = &TREE_CHAIN (*ptrail);
12109         }
12110     }
12111
12112   *plist = trail;
12113
12114   return list;
12115 }
12116
12117 #endif
12118 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12119
12120    tree t;
12121    ffebld expr;  // FFE opITEM list.
12122    tree = ffecom_list_ptr_to_expr(expr);
12123
12124    List of actual args is transformed into corresponding gcc backend list for
12125    use in calling an external procedure (vs. a statement function).  */
12126
12127 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12128 tree
12129 ffecom_list_ptr_to_expr (ffebld expr)
12130 {
12131   tree list;
12132   tree *plist = &list;
12133   tree trail = NULL_TREE;       /* Append char length args here. */
12134   tree *ptrail = &trail;
12135   tree length;
12136
12137   while (expr != NULL)
12138     {
12139       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12140
12141       if (texpr == error_mark_node)
12142         return error_mark_node;
12143
12144       *plist = build_tree_list (NULL_TREE, texpr);
12145       plist = &TREE_CHAIN (*plist);
12146       expr = ffebld_trail (expr);
12147       if (length != NULL_TREE)
12148         {
12149           *ptrail = build_tree_list (NULL_TREE, length);
12150           ptrail = &TREE_CHAIN (*ptrail);
12151         }
12152     }
12153
12154   *plist = trail;
12155
12156   return list;
12157 }
12158
12159 #endif
12160 /* Obtain gcc's LABEL_DECL tree for label.  */
12161
12162 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12163 tree
12164 ffecom_lookup_label (ffelab label)
12165 {
12166   tree glabel;
12167
12168   if (ffelab_hook (label) == NULL_TREE)
12169     {
12170       char labelname[16];
12171
12172       switch (ffelab_type (label))
12173         {
12174         case FFELAB_typeLOOPEND:
12175         case FFELAB_typeNOTLOOP:
12176         case FFELAB_typeENDIF:
12177           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12178           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12179                                void_type_node);
12180           DECL_CONTEXT (glabel) = current_function_decl;
12181           DECL_MODE (glabel) = VOIDmode;
12182           break;
12183
12184         case FFELAB_typeFORMAT:
12185           glabel = build_decl (VAR_DECL,
12186                                ffecom_get_invented_identifier
12187                                ("__g77_format_%d", (int) ffelab_value (label)),
12188                                build_type_variant (build_array_type
12189                                                    (char_type_node,
12190                                                     NULL_TREE),
12191                                                    1, 0));
12192           TREE_CONSTANT (glabel) = 1;
12193           TREE_STATIC (glabel) = 1;
12194           DECL_CONTEXT (glabel) = current_function_decl;
12195           DECL_INITIAL (glabel) = NULL;
12196           make_decl_rtl (glabel, NULL);
12197           expand_decl (glabel);
12198
12199           ffecom_save_tree_forever (glabel);
12200
12201           break;
12202
12203         case FFELAB_typeANY:
12204           glabel = error_mark_node;
12205           break;
12206
12207         default:
12208           assert ("bad label type" == NULL);
12209           glabel = NULL;
12210           break;
12211         }
12212       ffelab_set_hook (label, glabel);
12213     }
12214   else
12215     {
12216       glabel = ffelab_hook (label);
12217     }
12218
12219   return glabel;
12220 }
12221
12222 #endif
12223 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12224    a single source specification (as in the fourth argument of MVBITS).
12225    If the type is NULL_TREE, the type of lhs is used to make the type of
12226    the MODIFY_EXPR.  */
12227
12228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12229 tree
12230 ffecom_modify (tree newtype, tree lhs,
12231                tree rhs)
12232 {
12233   if (lhs == error_mark_node || rhs == error_mark_node)
12234     return error_mark_node;
12235
12236   if (newtype == NULL_TREE)
12237     newtype = TREE_TYPE (lhs);
12238
12239   if (TREE_SIDE_EFFECTS (lhs))
12240     lhs = stabilize_reference (lhs);
12241
12242   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12243 }
12244
12245 #endif
12246
12247 /* Register source file name.  */
12248
12249 void
12250 ffecom_file (const char *name)
12251 {
12252 #if FFECOM_GCC_INCLUDE
12253   ffecom_file_ (name);
12254 #endif
12255 }
12256
12257 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12258
12259    ffestorag st;
12260    ffecom_notify_init_storage(st);
12261
12262    Gets called when all possible units in an aggregate storage area (a LOCAL
12263    with equivalences or a COMMON) have been initialized.  The initialization
12264    info either is in ffestorag_init or, if that is NULL,
12265    ffestorag_accretion:
12266
12267    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12268    even for an array if the array is one element in length!
12269
12270    ffestorag_accretion will contain an opACCTER.  It is much like an
12271    opARRTER except it has an ffebit object in it instead of just a size.
12272    The back end can use the info in the ffebit object, if it wants, to
12273    reduce the amount of actual initialization, but in any case it should
12274    kill the ffebit object when done.  Also, set accretion to NULL but
12275    init to a non-NULL value.
12276
12277    After performing initialization, DO NOT set init to NULL, because that'll
12278    tell the front end it is ok for more initialization to happen.  Instead,
12279    set init to an opANY expression or some such thing that you can use to
12280    tell that you've already initialized the object.
12281
12282    27-Oct-91  JCB  1.1
12283       Support two-pass FFE.  */
12284
12285 void
12286 ffecom_notify_init_storage (ffestorag st)
12287 {
12288   ffebld init;                  /* The initialization expression. */
12289 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12290   ffetargetOffset size;         /* The size of the entity. */
12291   ffetargetAlign pad;           /* Its initial padding. */
12292 #endif
12293
12294   if (ffestorag_init (st) == NULL)
12295     {
12296       init = ffestorag_accretion (st);
12297       assert (init != NULL);
12298       ffestorag_set_accretion (st, NULL);
12299       ffestorag_set_accretes (st, 0);
12300
12301 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12302       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12303       size = ffebld_accter_size (init);
12304       pad = ffebld_accter_pad (init);
12305       ffebit_kill (ffebld_accter_bits (init));
12306       ffebld_set_op (init, FFEBLD_opARRTER);
12307       ffebld_set_arrter (init, ffebld_accter (init));
12308       ffebld_arrter_set_size (init, size);
12309       ffebld_arrter_set_pad (init, size);
12310 #endif
12311
12312 #if FFECOM_TWOPASS
12313       ffestorag_set_init (st, init);
12314 #endif
12315     }
12316 #if FFECOM_ONEPASS
12317   else
12318     init = ffestorag_init (st);
12319 #endif
12320
12321 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12322   ffestorag_set_init (st, ffebld_new_any ());
12323
12324   if (ffebld_op (init) == FFEBLD_opANY)
12325     return;                     /* Oh, we already did this! */
12326
12327 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12328   {
12329     ffesymbol s;
12330
12331     if (ffestorag_symbol (st) != NULL)
12332       s = ffestorag_symbol (st);
12333     else
12334       s = ffestorag_typesymbol (st);
12335
12336     fprintf (dmpout, "= initialize_storage \"%s\" ",
12337              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12338     ffebld_dump (init);
12339     fputc ('\n', dmpout);
12340   }
12341 #endif
12342
12343 #endif /* if FFECOM_ONEPASS */
12344 }
12345
12346 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12347
12348    ffesymbol s;
12349    ffecom_notify_init_symbol(s);
12350
12351    Gets called when all possible units in a symbol (not placed in COMMON
12352    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12353    have been initialized.  The initialization info either is in
12354    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12355
12356    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12357    even for an array if the array is one element in length!
12358
12359    ffesymbol_accretion will contain an opACCTER.  It is much like an
12360    opARRTER except it has an ffebit object in it instead of just a size.
12361    The back end can use the info in the ffebit object, if it wants, to
12362    reduce the amount of actual initialization, but in any case it should
12363    kill the ffebit object when done.  Also, set accretion to NULL but
12364    init to a non-NULL value.
12365
12366    After performing initialization, DO NOT set init to NULL, because that'll
12367    tell the front end it is ok for more initialization to happen.  Instead,
12368    set init to an opANY expression or some such thing that you can use to
12369    tell that you've already initialized the object.
12370
12371    27-Oct-91  JCB  1.1
12372       Support two-pass FFE.  */
12373
12374 void
12375 ffecom_notify_init_symbol (ffesymbol s)
12376 {
12377   ffebld init;                  /* The initialization expression. */
12378 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12379   ffetargetOffset size;         /* The size of the entity. */
12380   ffetargetAlign pad;           /* Its initial padding. */
12381 #endif
12382
12383   if (ffesymbol_storage (s) == NULL)
12384     return;                     /* Do nothing until COMMON/EQUIVALENCE
12385                                    possibilities checked. */
12386
12387   if ((ffesymbol_init (s) == NULL)
12388       && ((init = ffesymbol_accretion (s)) != NULL))
12389     {
12390       ffesymbol_set_accretion (s, NULL);
12391       ffesymbol_set_accretes (s, 0);
12392
12393 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12394       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12395       size = ffebld_accter_size (init);
12396       pad = ffebld_accter_pad (init);
12397       ffebit_kill (ffebld_accter_bits (init));
12398       ffebld_set_op (init, FFEBLD_opARRTER);
12399       ffebld_set_arrter (init, ffebld_accter (init));
12400       ffebld_arrter_set_size (init, size);
12401       ffebld_arrter_set_pad (init, size);
12402 #endif
12403
12404 #if FFECOM_TWOPASS
12405       ffesymbol_set_init (s, init);
12406 #endif
12407     }
12408 #if FFECOM_ONEPASS
12409   else
12410     init = ffesymbol_init (s);
12411 #endif
12412
12413 #if FFECOM_ONEPASS
12414   ffesymbol_set_init (s, ffebld_new_any ());
12415
12416   if (ffebld_op (init) == FFEBLD_opANY)
12417     return;                     /* Oh, we already did this! */
12418
12419 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12420   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12421   ffebld_dump (init);
12422   fputc ('\n', dmpout);
12423 #endif
12424
12425 #endif /* if FFECOM_ONEPASS */
12426 }
12427
12428 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12429
12430    ffesymbol s;
12431    ffecom_notify_primary_entry(s);
12432
12433    Gets called when implicit or explicit PROGRAM statement seen or when
12434    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12435    global symbol that serves as the entry point.  */
12436
12437 void
12438 ffecom_notify_primary_entry (ffesymbol s)
12439 {
12440   ffecom_primary_entry_ = s;
12441   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12442
12443   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12444       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12445     ffecom_primary_entry_is_proc_ = TRUE;
12446   else
12447     ffecom_primary_entry_is_proc_ = FALSE;
12448
12449   if (!ffe_is_silent ())
12450     {
12451       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12452         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12453       else
12454         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12455     }
12456
12457 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12458   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12459     {
12460       ffebld list;
12461       ffebld arg;
12462
12463       for (list = ffesymbol_dummyargs (s);
12464            list != NULL;
12465            list = ffebld_trail (list))
12466         {
12467           arg = ffebld_head (list);
12468           if (ffebld_op (arg) == FFEBLD_opSTAR)
12469             {
12470               ffecom_is_altreturning_ = TRUE;
12471               break;
12472             }
12473         }
12474     }
12475 #endif
12476 }
12477
12478 FILE *
12479 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12480 {
12481 #if FFECOM_GCC_INCLUDE
12482   return ffecom_open_include_ (name, l, c);
12483 #else
12484   return fopen (name, "r");
12485 #endif
12486 }
12487
12488 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12489
12490    tree t;
12491    ffebld expr;  // FFE expression.
12492    tree = ffecom_ptr_to_expr(expr);
12493
12494    Like ffecom_expr, but sticks address-of in front of most things.  */
12495
12496 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12497 tree
12498 ffecom_ptr_to_expr (ffebld expr)
12499 {
12500   tree item;
12501   ffeinfoBasictype bt;
12502   ffeinfoKindtype kt;
12503   ffesymbol s;
12504
12505   assert (expr != NULL);
12506
12507   switch (ffebld_op (expr))
12508     {
12509     case FFEBLD_opSYMTER:
12510       s = ffebld_symter (expr);
12511       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12512         {
12513           ffecomGfrt ix;
12514
12515           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12516           assert (ix != FFECOM_gfrt);
12517           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12518             {
12519               ffecom_make_gfrt_ (ix);
12520               item = ffecom_gfrt_[ix];
12521             }
12522         }
12523       else
12524         {
12525           item = ffesymbol_hook (s).decl_tree;
12526           if (item == NULL_TREE)
12527             {
12528               s = ffecom_sym_transform_ (s);
12529               item = ffesymbol_hook (s).decl_tree;
12530             }
12531         }
12532       assert (item != NULL);
12533       if (item == error_mark_node)
12534         return item;
12535       if (!ffesymbol_hook (s).addr)
12536         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12537                          item);
12538       return item;
12539
12540     case FFEBLD_opARRAYREF:
12541       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12542
12543     case FFEBLD_opCONTER:
12544
12545       bt = ffeinfo_basictype (ffebld_info (expr));
12546       kt = ffeinfo_kindtype (ffebld_info (expr));
12547
12548       item = ffecom_constantunion (&ffebld_constant_union
12549                                    (ffebld_conter (expr)), bt, kt,
12550                                    ffecom_tree_type[bt][kt]);
12551       if (item == error_mark_node)
12552         return error_mark_node;
12553       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12554                        item);
12555       return item;
12556
12557     case FFEBLD_opANY:
12558       return error_mark_node;
12559
12560     default:
12561       bt = ffeinfo_basictype (ffebld_info (expr));
12562       kt = ffeinfo_kindtype (ffebld_info (expr));
12563
12564       item = ffecom_expr (expr);
12565       if (item == error_mark_node)
12566         return error_mark_node;
12567
12568       /* The back end currently optimizes a bit too zealously for us, in that
12569          we fail JCB001 if the following block of code is omitted.  It checks
12570          to see if the transformed expression is a symbol or array reference,
12571          and encloses it in a SAVE_EXPR if that is the case.  */
12572
12573       STRIP_NOPS (item);
12574       if ((TREE_CODE (item) == VAR_DECL)
12575           || (TREE_CODE (item) == PARM_DECL)
12576           || (TREE_CODE (item) == RESULT_DECL)
12577           || (TREE_CODE (item) == INDIRECT_REF)
12578           || (TREE_CODE (item) == ARRAY_REF)
12579           || (TREE_CODE (item) == COMPONENT_REF)
12580 #ifdef OFFSET_REF
12581           || (TREE_CODE (item) == OFFSET_REF)
12582 #endif
12583           || (TREE_CODE (item) == BUFFER_REF)
12584           || (TREE_CODE (item) == REALPART_EXPR)
12585           || (TREE_CODE (item) == IMAGPART_EXPR))
12586         {
12587           item = ffecom_save_tree (item);
12588         }
12589
12590       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12591                        item);
12592       return item;
12593     }
12594
12595   assert ("fall-through error" == NULL);
12596   return error_mark_node;
12597 }
12598
12599 #endif
12600 /* Obtain a temp var with given data type.
12601
12602    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12603    or >= 0 for a CHARACTER type.
12604
12605    elements is -1 for a scalar or > 0 for an array of type.  */
12606
12607 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12608 tree
12609 ffecom_make_tempvar (const char *commentary, tree type,
12610                      ffetargetCharacterSize size, int elements)
12611 {
12612   tree t;
12613   static int mynumber;
12614
12615   assert (current_binding_level->prep_state < 2);
12616
12617   if (type == error_mark_node)
12618     return error_mark_node;
12619
12620   if (size != FFETARGET_charactersizeNONE)
12621     type = build_array_type (type,
12622                              build_range_type (ffecom_f2c_ftnlen_type_node,
12623                                                ffecom_f2c_ftnlen_one_node,
12624                                                build_int_2 (size, 0)));
12625   if (elements != -1)
12626     type = build_array_type (type,
12627                              build_range_type (integer_type_node,
12628                                                integer_zero_node,
12629                                                build_int_2 (elements - 1,
12630                                                             0)));
12631   t = build_decl (VAR_DECL,
12632                   ffecom_get_invented_identifier ("__g77_%s_%d",
12633                                                   commentary,
12634                                                   mynumber++),
12635                   type);
12636
12637   t = start_decl (t, FALSE);
12638   finish_decl (t, NULL_TREE, FALSE);
12639
12640   return t;
12641 }
12642 #endif
12643
12644 /* Prepare argument pointer to expression.
12645
12646    Like ffecom_prepare_expr, except for expressions to be evaluated
12647    via ffecom_arg_ptr_to_expr.  */
12648
12649 void
12650 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12651 {
12652   /* ~~For now, it seems to be the same thing.  */
12653   ffecom_prepare_expr (expr);
12654   return;
12655 }
12656
12657 /* End of preparations.  */
12658
12659 bool
12660 ffecom_prepare_end (void)
12661 {
12662   int prep_state = current_binding_level->prep_state;
12663
12664   assert (prep_state < 2);
12665   current_binding_level->prep_state = 2;
12666
12667   return (prep_state == 1) ? TRUE : FALSE;
12668 }
12669
12670 /* Prepare expression.
12671
12672    This is called before any code is generated for the current block.
12673    It scans the expression, declares any temporaries that might be needed
12674    during evaluation of the expression, and stores those temporaries in
12675    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12676    specifies the destination that ffecom_expr_ will see, in case that
12677    helps avoid generating unused temporaries.
12678
12679    ~~Improve to avoid allocating unused temporaries by taking `dest'
12680    into account vis-a-vis aliasing requirements of complex/character
12681    functions.  */
12682
12683 void
12684 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12685 {
12686   ffeinfoBasictype bt;
12687   ffeinfoKindtype kt;
12688   ffetargetCharacterSize sz;
12689   tree tempvar = NULL_TREE;
12690
12691   assert (current_binding_level->prep_state < 2);
12692
12693   if (! expr)
12694     return;
12695
12696   bt = ffeinfo_basictype (ffebld_info (expr));
12697   kt = ffeinfo_kindtype (ffebld_info (expr));
12698   sz = ffeinfo_size (ffebld_info (expr));
12699
12700   /* Generate whatever temporaries are needed to represent the result
12701      of the expression.  */
12702
12703   if (bt == FFEINFO_basictypeCHARACTER)
12704     {
12705       while (ffebld_op (expr) == FFEBLD_opPAREN)
12706         expr = ffebld_left (expr);
12707     }
12708
12709   switch (ffebld_op (expr))
12710     {
12711     default:
12712       /* Don't make temps for SYMTER, CONTER, etc.  */
12713       if (ffebld_arity (expr) == 0)
12714         break;
12715
12716       switch (bt)
12717         {
12718         case FFEINFO_basictypeCOMPLEX:
12719           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12720             {
12721               ffesymbol s;
12722
12723               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12724                 break;
12725
12726               s = ffebld_symter (ffebld_left (expr));
12727               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12728                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12729                       && ! ffesymbol_is_f2c (s))
12730                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12731                       && ! ffe_is_f2c_library ()))
12732                 break;
12733             }
12734           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12735             {
12736               /* Requires special treatment.  There's no POW_CC function
12737                  in libg2c, so POW_ZZ is used, which means we always
12738                  need a double-complex temp, not a single-complex.  */
12739               kt = FFEINFO_kindtypeREAL2;
12740             }
12741           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12742             /* The other ops don't need temps for complex operands.  */
12743             break;
12744
12745           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12746              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12747           tempvar = ffecom_make_tempvar ("complex",
12748                                          ffecom_tree_type
12749                                          [FFEINFO_basictypeCOMPLEX][kt],
12750                                          FFETARGET_charactersizeNONE,
12751                                          -1);
12752           break;
12753
12754         case FFEINFO_basictypeCHARACTER:
12755           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12756             break;
12757
12758           if (sz == FFETARGET_charactersizeNONE)
12759             /* ~~Kludge alert!  This should someday be fixed. */
12760             sz = 24;
12761
12762           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12763           break;
12764
12765         default:
12766           break;
12767         }
12768       break;
12769
12770 #ifdef HAHA
12771     case FFEBLD_opPOWER:
12772       {
12773         tree rtype, ltype;
12774         tree rtmp, ltmp, result;
12775
12776         ltype = ffecom_type_expr (ffebld_left (expr));
12777         rtype = ffecom_type_expr (ffebld_right (expr));
12778
12779         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12780         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12781         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12782
12783         tempvar = make_tree_vec (3);
12784         TREE_VEC_ELT (tempvar, 0) = rtmp;
12785         TREE_VEC_ELT (tempvar, 1) = ltmp;
12786         TREE_VEC_ELT (tempvar, 2) = result;
12787       }
12788       break;
12789 #endif  /* HAHA */
12790
12791     case FFEBLD_opCONCATENATE:
12792       {
12793         /* This gets special handling, because only one set of temps
12794            is needed for a tree of these -- the tree is treated as
12795            a flattened list of concatenations when generating code.  */
12796
12797         ffecomConcatList_ catlist;
12798         tree ltmp, itmp, result;
12799         int count;
12800         int i;
12801
12802         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12803         count = ffecom_concat_list_count_ (catlist);
12804
12805         if (count >= 2)
12806           {
12807             ltmp
12808               = ffecom_make_tempvar ("concat_len",
12809                                      ffecom_f2c_ftnlen_type_node,
12810                                      FFETARGET_charactersizeNONE, count);
12811             itmp
12812               = ffecom_make_tempvar ("concat_item",
12813                                      ffecom_f2c_address_type_node,
12814                                      FFETARGET_charactersizeNONE, count);
12815             result
12816               = ffecom_make_tempvar ("concat_res",
12817                                      char_type_node,
12818                                      ffecom_concat_list_maxlen_ (catlist),
12819                                      -1);
12820
12821             tempvar = make_tree_vec (3);
12822             TREE_VEC_ELT (tempvar, 0) = ltmp;
12823             TREE_VEC_ELT (tempvar, 1) = itmp;
12824             TREE_VEC_ELT (tempvar, 2) = result;
12825           }
12826
12827         for (i = 0; i < count; ++i)
12828           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12829                                                                     i));
12830
12831         ffecom_concat_list_kill_ (catlist);
12832
12833         if (tempvar)
12834           {
12835             ffebld_nonter_set_hook (expr, tempvar);
12836             current_binding_level->prep_state = 1;
12837           }
12838       }
12839       return;
12840
12841     case FFEBLD_opCONVERT:
12842       if (bt == FFEINFO_basictypeCHARACTER
12843           && ((ffebld_size_known (ffebld_left (expr))
12844                == FFETARGET_charactersizeNONE)
12845               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12846         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12847       break;
12848     }
12849
12850   if (tempvar)
12851     {
12852       ffebld_nonter_set_hook (expr, tempvar);
12853       current_binding_level->prep_state = 1;
12854     }
12855
12856   /* Prepare subexpressions for this expr.  */
12857
12858   switch (ffebld_op (expr))
12859     {
12860     case FFEBLD_opPERCENT_LOC:
12861       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12862       break;
12863
12864     case FFEBLD_opPERCENT_VAL:
12865     case FFEBLD_opPERCENT_REF:
12866       ffecom_prepare_expr (ffebld_left (expr));
12867       break;
12868
12869     case FFEBLD_opPERCENT_DESCR:
12870       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12871       break;
12872
12873     case FFEBLD_opITEM:
12874       {
12875         ffebld item;
12876
12877         for (item = expr;
12878              item != NULL;
12879              item = ffebld_trail (item))
12880           if (ffebld_head (item) != NULL)
12881             ffecom_prepare_expr (ffebld_head (item));
12882       }
12883       break;
12884
12885     default:
12886       /* Need to handle character conversion specially.  */
12887       switch (ffebld_arity (expr))
12888         {
12889         case 2:
12890           ffecom_prepare_expr (ffebld_left (expr));
12891           ffecom_prepare_expr (ffebld_right (expr));
12892           break;
12893
12894         case 1:
12895           ffecom_prepare_expr (ffebld_left (expr));
12896           break;
12897
12898         default:
12899           break;
12900         }
12901     }
12902
12903   return;
12904 }
12905
12906 /* Prepare expression for reading and writing.
12907
12908    Like ffecom_prepare_expr, except for expressions to be evaluated
12909    via ffecom_expr_rw.  */
12910
12911 void
12912 ffecom_prepare_expr_rw (tree type, ffebld expr)
12913 {
12914   /* This is all we support for now.  */
12915   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12916
12917   /* ~~For now, it seems to be the same thing.  */
12918   ffecom_prepare_expr (expr);
12919   return;
12920 }
12921
12922 /* Prepare expression for writing.
12923
12924    Like ffecom_prepare_expr, except for expressions to be evaluated
12925    via ffecom_expr_w.  */
12926
12927 void
12928 ffecom_prepare_expr_w (tree type, ffebld expr)
12929 {
12930   /* This is all we support for now.  */
12931   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12932
12933   /* ~~For now, it seems to be the same thing.  */
12934   ffecom_prepare_expr (expr);
12935   return;
12936 }
12937
12938 /* Prepare expression for returning.
12939
12940    Like ffecom_prepare_expr, except for expressions to be evaluated
12941    via ffecom_return_expr.  */
12942
12943 void
12944 ffecom_prepare_return_expr (ffebld expr)
12945 {
12946   assert (current_binding_level->prep_state < 2);
12947
12948   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12949       && ffecom_is_altreturning_
12950       && expr != NULL)
12951     ffecom_prepare_expr (expr);
12952 }
12953
12954 /* Prepare pointer to expression.
12955
12956    Like ffecom_prepare_expr, except for expressions to be evaluated
12957    via ffecom_ptr_to_expr.  */
12958
12959 void
12960 ffecom_prepare_ptr_to_expr (ffebld expr)
12961 {
12962   /* ~~For now, it seems to be the same thing.  */
12963   ffecom_prepare_expr (expr);
12964   return;
12965 }
12966
12967 /* Transform expression into constant pointer-to-expression tree.
12968
12969    If the expression can be transformed into a pointer-to-expression tree
12970    that is constant, that is done, and the tree returned.  Else NULL_TREE
12971    is returned.
12972
12973    That way, a caller can attempt to provide compile-time initialization
12974    of a variable and, if that fails, *then* choose to start a new block
12975    and resort to using temporaries, as appropriate.  */
12976
12977 tree
12978 ffecom_ptr_to_const_expr (ffebld expr)
12979 {
12980   if (! expr)
12981     return integer_zero_node;
12982
12983   if (ffebld_op (expr) == FFEBLD_opANY)
12984     return error_mark_node;
12985
12986   if (ffebld_arity (expr) == 0
12987       && (ffebld_op (expr) != FFEBLD_opSYMTER
12988           || ffebld_where (expr) == FFEINFO_whereCOMMON
12989           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12990           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12991     {
12992       tree t;
12993
12994       t = ffecom_ptr_to_expr (expr);
12995       assert (TREE_CONSTANT (t));
12996       return t;
12997     }
12998
12999   return NULL_TREE;
13000 }
13001
13002 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13003
13004    tree rtn;  // NULL_TREE means use expand_null_return()
13005    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13006    rtn = ffecom_return_expr(expr);
13007
13008    Based on the program unit type and other info (like return function
13009    type, return master function type when alternate ENTRY points,
13010    whether subroutine has any alternate RETURN points, etc), returns the
13011    appropriate expression to be returned to the caller, or NULL_TREE
13012    meaning no return value or the caller expects it to be returned somewhere
13013    else (which is handled by other parts of this module).  */
13014
13015 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13016 tree
13017 ffecom_return_expr (ffebld expr)
13018 {
13019   tree rtn;
13020
13021   switch (ffecom_primary_entry_kind_)
13022     {
13023     case FFEINFO_kindPROGRAM:
13024     case FFEINFO_kindBLOCKDATA:
13025       rtn = NULL_TREE;
13026       break;
13027
13028     case FFEINFO_kindSUBROUTINE:
13029       if (!ffecom_is_altreturning_)
13030         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13031       else if (expr == NULL)
13032         rtn = integer_zero_node;
13033       else
13034         rtn = ffecom_expr (expr);
13035       break;
13036
13037     case FFEINFO_kindFUNCTION:
13038       if ((ffecom_multi_retval_ != NULL_TREE)
13039           || (ffesymbol_basictype (ffecom_primary_entry_)
13040               == FFEINFO_basictypeCHARACTER)
13041           || ((ffesymbol_basictype (ffecom_primary_entry_)
13042                == FFEINFO_basictypeCOMPLEX)
13043               && (ffecom_num_entrypoints_ == 0)
13044               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13045         {                       /* Value is returned by direct assignment
13046                                    into (implicit) dummy. */
13047           rtn = NULL_TREE;
13048           break;
13049         }
13050       rtn = ffecom_func_result_;
13051 #if 0
13052       /* Spurious error if RETURN happens before first reference!  So elide
13053          this code.  In particular, for debugging registry, rtn should always
13054          be non-null after all, but TREE_USED won't be set until we encounter
13055          a reference in the code.  Perfectly okay (but weird) code that,
13056          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13057          this diagnostic for no reason.  Have people use -O -Wuninitialized
13058          and leave it to the back end to find obviously weird cases.  */
13059
13060       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13061          situation; if the return value has never been referenced, it won't
13062          have a tree under 2pass mode. */
13063       if ((rtn == NULL_TREE)
13064           || !TREE_USED (rtn))
13065         {
13066           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13067           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13068                        ffesymbol_where_column (ffecom_primary_entry_));
13069           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13070                                          (ffecom_primary_entry_)));
13071           ffebad_finish ();
13072         }
13073 #endif
13074       break;
13075
13076     default:
13077       assert ("bad unit kind" == NULL);
13078     case FFEINFO_kindANY:
13079       rtn = error_mark_node;
13080       break;
13081     }
13082
13083   return rtn;
13084 }
13085
13086 #endif
13087 /* Do save_expr only if tree is not error_mark_node.  */
13088
13089 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13090 tree
13091 ffecom_save_tree (tree t)
13092 {
13093   return save_expr (t);
13094 }
13095 #endif
13096
13097 /* Start a compound statement (block).  */
13098
13099 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13100 void
13101 ffecom_start_compstmt (void)
13102 {
13103   bison_rule_pushlevel_ ();
13104 }
13105 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13106
13107 /* Public entry point for front end to access start_decl.  */
13108
13109 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13110 tree
13111 ffecom_start_decl (tree decl, bool is_initialized)
13112 {
13113   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13114   return start_decl (decl, FALSE);
13115 }
13116
13117 #endif
13118 /* ffecom_sym_commit -- Symbol's state being committed to reality
13119
13120    ffesymbol s;
13121    ffecom_sym_commit(s);
13122
13123    Does whatever the backend needs when a symbol is committed after having
13124    been backtrackable for a period of time.  */
13125
13126 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13127 void
13128 ffecom_sym_commit (ffesymbol s UNUSED)
13129 {
13130   assert (!ffesymbol_retractable ());
13131 }
13132
13133 #endif
13134 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13135
13136    ffecom_sym_end_transition();
13137
13138    Does backend-specific stuff and also calls ffest_sym_end_transition
13139    to do the necessary FFE stuff.
13140
13141    Backtracking is never enabled when this fn is called, so don't worry
13142    about it.  */
13143
13144 ffesymbol
13145 ffecom_sym_end_transition (ffesymbol s)
13146 {
13147   ffestorag st;
13148
13149   assert (!ffesymbol_retractable ());
13150
13151   s = ffest_sym_end_transition (s);
13152
13153 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13154   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13155       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13156     {
13157       ffecom_list_blockdata_
13158         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13159                                               FFEINTRIN_specNONE,
13160                                               FFEINTRIN_impNONE),
13161                            ffecom_list_blockdata_);
13162     }
13163 #endif
13164
13165   /* This is where we finally notice that a symbol has partial initialization
13166      and finalize it. */
13167
13168   if (ffesymbol_accretion (s) != NULL)
13169     {
13170       assert (ffesymbol_init (s) == NULL);
13171       ffecom_notify_init_symbol (s);
13172     }
13173   else if (((st = ffesymbol_storage (s)) != NULL)
13174            && ((st = ffestorag_parent (st)) != NULL)
13175            && (ffestorag_accretion (st) != NULL))
13176     {
13177       assert (ffestorag_init (st) == NULL);
13178       ffecom_notify_init_storage (st);
13179     }
13180
13181 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13182   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13183       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13184       && (ffesymbol_storage (s) != NULL))
13185     {
13186       ffecom_list_common_
13187         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13188                                               FFEINTRIN_specNONE,
13189                                               FFEINTRIN_impNONE),
13190                            ffecom_list_common_);
13191     }
13192 #endif
13193
13194   return s;
13195 }
13196
13197 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13198
13199    ffecom_sym_exec_transition();
13200
13201    Does backend-specific stuff and also calls ffest_sym_exec_transition
13202    to do the necessary FFE stuff.
13203
13204    See the long-winded description in ffecom_sym_learned for info
13205    on handling the situation where backtracking is inhibited.  */
13206
13207 ffesymbol
13208 ffecom_sym_exec_transition (ffesymbol s)
13209 {
13210   s = ffest_sym_exec_transition (s);
13211
13212   return s;
13213 }
13214
13215 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13216
13217    ffesymbol s;
13218    s = ffecom_sym_learned(s);
13219
13220    Called when a new symbol is seen after the exec transition or when more
13221    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13222    it arrives here is that all its latest info is updated already, so its
13223    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13224    field filled in if its gone through here or exec_transition first, and
13225    so on.
13226
13227    The backend probably wants to check ffesymbol_retractable() to see if
13228    backtracking is in effect.  If so, the FFE's changes to the symbol may
13229    be retracted (undone) or committed (ratified), at which time the
13230    appropriate ffecom_sym_retract or _commit function will be called
13231    for that function.
13232
13233    If the backend has its own backtracking mechanism, great, use it so that
13234    committal is a simple operation.  Though it doesn't make much difference,
13235    I suppose: the reason for tentative symbol evolution in the FFE is to
13236    enable error detection in weird incorrect statements early and to disable
13237    incorrect error detection on a correct statement.  The backend is not
13238    likely to introduce any information that'll get involved in these
13239    considerations, so it is probably just fine that the implementation
13240    model for this fn and for _exec_transition is to not do anything
13241    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13242    and instead wait until ffecom_sym_commit is called (which it never
13243    will be as long as we're using ambiguity-detecting statement analysis in
13244    the FFE, which we are initially to shake out the code, but don't depend
13245    on this), otherwise go ahead and do whatever is needed.
13246
13247    In essence, then, when this fn and _exec_transition get called while
13248    backtracking is enabled, a general mechanism would be to flag which (or
13249    both) of these were called (and in what order? neat question as to what
13250    might happen that I'm too lame to think through right now) and then when
13251    _commit is called reproduce the original calling sequence, if any, for
13252    the two fns (at which point backtracking will, of course, be disabled).  */
13253
13254 ffesymbol
13255 ffecom_sym_learned (ffesymbol s)
13256 {
13257   ffestorag_exec_layout (s);
13258
13259   return s;
13260 }
13261
13262 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13263
13264    ffesymbol s;
13265    ffecom_sym_retract(s);
13266
13267    Does whatever the backend needs when a symbol is retracted after having
13268    been backtrackable for a period of time.  */
13269
13270 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13271 void
13272 ffecom_sym_retract (ffesymbol s UNUSED)
13273 {
13274   assert (!ffesymbol_retractable ());
13275
13276 #if 0                           /* GCC doesn't commit any backtrackable sins,
13277                                    so nothing needed here. */
13278   switch (ffesymbol_hook (s).state)
13279     {
13280     case 0:                     /* nothing happened yet. */
13281       break;
13282
13283     case 1:                     /* exec transition happened. */
13284       break;
13285
13286     case 2:                     /* learned happened. */
13287       break;
13288
13289     case 3:                     /* learned then exec. */
13290       break;
13291
13292     case 4:                     /* exec then learned. */
13293       break;
13294
13295     default:
13296       assert ("bad hook state" == NULL);
13297       break;
13298     }
13299 #endif
13300 }
13301
13302 #endif
13303 /* Create temporary gcc label.  */
13304
13305 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13306 tree
13307 ffecom_temp_label ()
13308 {
13309   tree glabel;
13310   static int mynumber = 0;
13311
13312   glabel = build_decl (LABEL_DECL,
13313                        ffecom_get_invented_identifier ("__g77_label_%d",
13314                                                        mynumber++),
13315                        void_type_node);
13316   DECL_CONTEXT (glabel) = current_function_decl;
13317   DECL_MODE (glabel) = VOIDmode;
13318
13319   return glabel;
13320 }
13321
13322 #endif
13323 /* Return an expression that is usable as an arg in a conditional context
13324    (IF, DO WHILE, .NOT., and so on).
13325
13326    Use the one provided for the back end as of >2.6.0.  */
13327
13328 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13329 tree
13330 ffecom_truth_value (tree expr)
13331 {
13332   return truthvalue_conversion (expr);
13333 }
13334
13335 #endif
13336 /* Return the inversion of a truth value (the inversion of what
13337    ffecom_truth_value builds).
13338
13339    Apparently invert_truthvalue, which is properly in the back end, is
13340    enough for now, so just use it.  */
13341
13342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13343 tree
13344 ffecom_truth_value_invert (tree expr)
13345 {
13346   return invert_truthvalue (ffecom_truth_value (expr));
13347 }
13348
13349 #endif
13350
13351 /* Return the tree that is the type of the expression, as would be
13352    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13353    transforming the expression, generating temporaries, etc.  */
13354
13355 tree
13356 ffecom_type_expr (ffebld expr)
13357 {
13358   ffeinfoBasictype bt;
13359   ffeinfoKindtype kt;
13360   tree tree_type;
13361
13362   assert (expr != NULL);
13363
13364   bt = ffeinfo_basictype (ffebld_info (expr));
13365   kt = ffeinfo_kindtype (ffebld_info (expr));
13366   tree_type = ffecom_tree_type[bt][kt];
13367
13368   switch (ffebld_op (expr))
13369     {
13370     case FFEBLD_opCONTER:
13371     case FFEBLD_opSYMTER:
13372     case FFEBLD_opARRAYREF:
13373     case FFEBLD_opUPLUS:
13374     case FFEBLD_opPAREN:
13375     case FFEBLD_opUMINUS:
13376     case FFEBLD_opADD:
13377     case FFEBLD_opSUBTRACT:
13378     case FFEBLD_opMULTIPLY:
13379     case FFEBLD_opDIVIDE:
13380     case FFEBLD_opPOWER:
13381     case FFEBLD_opNOT:
13382     case FFEBLD_opFUNCREF:
13383     case FFEBLD_opSUBRREF:
13384     case FFEBLD_opAND:
13385     case FFEBLD_opOR:
13386     case FFEBLD_opXOR:
13387     case FFEBLD_opNEQV:
13388     case FFEBLD_opEQV:
13389     case FFEBLD_opCONVERT:
13390     case FFEBLD_opLT:
13391     case FFEBLD_opLE:
13392     case FFEBLD_opEQ:
13393     case FFEBLD_opNE:
13394     case FFEBLD_opGT:
13395     case FFEBLD_opGE:
13396     case FFEBLD_opPERCENT_LOC:
13397       return tree_type;
13398
13399     case FFEBLD_opACCTER:
13400     case FFEBLD_opARRTER:
13401     case FFEBLD_opITEM:
13402     case FFEBLD_opSTAR:
13403     case FFEBLD_opBOUNDS:
13404     case FFEBLD_opREPEAT:
13405     case FFEBLD_opLABTER:
13406     case FFEBLD_opLABTOK:
13407     case FFEBLD_opIMPDO:
13408     case FFEBLD_opCONCATENATE:
13409     case FFEBLD_opSUBSTR:
13410     default:
13411       assert ("bad op for ffecom_type_expr" == NULL);
13412       /* Fall through. */
13413     case FFEBLD_opANY:
13414       return error_mark_node;
13415     }
13416 }
13417
13418 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13419
13420    If the PARM_DECL already exists, return it, else create it.  It's an
13421    integer_type_node argument for the master function that implements a
13422    subroutine or function with more than one entrypoint and is bound at
13423    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13424    first ENTRY statement, and so on).  */
13425
13426 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13427 tree
13428 ffecom_which_entrypoint_decl ()
13429 {
13430   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13431
13432   return ffecom_which_entrypoint_decl_;
13433 }
13434
13435 #endif
13436 \f
13437 /* The following sections consists of private and public functions
13438    that have the same names and perform roughly the same functions
13439    as counterparts in the C front end.  Changes in the C front end
13440    might affect how things should be done here.  Only functions
13441    needed by the back end should be public here; the rest should
13442    be private (static in the C sense).  Functions needed by other
13443    g77 front-end modules should be accessed by them via public
13444    ffecom_* names, which should themselves call private versions
13445    in this section so the private versions are easy to recognize
13446    when upgrading to a new gcc and finding interesting changes
13447    in the front end.
13448
13449    Functions named after rule "foo:" in c-parse.y are named
13450    "bison_rule_foo_" so they are easy to find.  */
13451
13452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13453
13454 static void
13455 bison_rule_pushlevel_ ()
13456 {
13457   emit_line_note (input_filename, lineno);
13458   pushlevel (0);
13459   clear_last_expr ();
13460   expand_start_bindings (0);
13461 }
13462
13463 static tree
13464 bison_rule_compstmt_ ()
13465 {
13466   tree t;
13467   int keep = kept_level_p ();
13468
13469   /* Make the temps go away.  */
13470   if (! keep)
13471     current_binding_level->names = NULL_TREE;
13472
13473   emit_line_note (input_filename, lineno);
13474   expand_end_bindings (getdecls (), keep, 0);
13475   t = poplevel (keep, 1, 0);
13476
13477   return t;
13478 }
13479
13480 /* Return a definition for a builtin function named NAME and whose data type
13481    is TYPE.  TYPE should be a function type with argument types.
13482    FUNCTION_CODE tells later passes how to compile calls to this function.
13483    See tree.h for its possible values.
13484
13485    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13486    the name to be called if we can't opencode the function.  */
13487
13488 tree
13489 builtin_function (const char *name, tree type, int function_code,
13490                   enum built_in_class class,
13491                   const char *library_name)
13492 {
13493   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13494   DECL_EXTERNAL (decl) = 1;
13495   TREE_PUBLIC (decl) = 1;
13496   if (library_name)
13497     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13498   make_decl_rtl (decl, NULL);
13499   pushdecl (decl);
13500   DECL_BUILT_IN_CLASS (decl) = class;
13501   DECL_FUNCTION_CODE (decl) = function_code;
13502
13503   return decl;
13504 }
13505
13506 /* Handle when a new declaration NEWDECL
13507    has the same name as an old one OLDDECL
13508    in the same binding contour.
13509    Prints an error message if appropriate.
13510
13511    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13512    Otherwise, return 0.  */
13513
13514 static int
13515 duplicate_decls (tree newdecl, tree olddecl)
13516 {
13517   int types_match = 1;
13518   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13519                            && DECL_INITIAL (newdecl) != 0);
13520   tree oldtype = TREE_TYPE (olddecl);
13521   tree newtype = TREE_TYPE (newdecl);
13522
13523   if (olddecl == newdecl)
13524     return 1;
13525
13526   if (TREE_CODE (newtype) == ERROR_MARK
13527       || TREE_CODE (oldtype) == ERROR_MARK)
13528     types_match = 0;
13529
13530   /* New decl is completely inconsistent with the old one =>
13531      tell caller to replace the old one.
13532      This is always an error except in the case of shadowing a builtin.  */
13533   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13534     return 0;
13535
13536   /* For real parm decl following a forward decl,
13537      return 1 so old decl will be reused.  */
13538   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13539       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13540     return 1;
13541
13542   /* The new declaration is the same kind of object as the old one.
13543      The declarations may partially match.  Print warnings if they don't
13544      match enough.  Ultimately, copy most of the information from the new
13545      decl to the old one, and keep using the old one.  */
13546
13547   if (TREE_CODE (olddecl) == FUNCTION_DECL
13548       && DECL_BUILT_IN (olddecl))
13549     {
13550       /* A function declaration for a built-in function.  */
13551       if (!TREE_PUBLIC (newdecl))
13552         return 0;
13553       else if (!types_match)
13554         {
13555           /* Accept the return type of the new declaration if same modes.  */
13556           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13557           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13558
13559           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13560             {
13561               /* Function types may be shared, so we can't just modify
13562                  the return type of olddecl's function type.  */
13563               tree newtype
13564                 = build_function_type (newreturntype,
13565                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13566
13567               types_match = 1;
13568               if (types_match)
13569                 TREE_TYPE (olddecl) = newtype;
13570             }
13571         }
13572       if (!types_match)
13573         return 0;
13574     }
13575   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13576            && DECL_SOURCE_LINE (olddecl) == 0)
13577     {
13578       /* A function declaration for a predeclared function
13579          that isn't actually built in.  */
13580       if (!TREE_PUBLIC (newdecl))
13581         return 0;
13582       else if (!types_match)
13583         {
13584           /* If the types don't match, preserve volatility indication.
13585              Later on, we will discard everything else about the
13586              default declaration.  */
13587           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13588         }
13589     }
13590
13591   /* Copy all the DECL_... slots specified in the new decl
13592      except for any that we copy here from the old type.
13593
13594      Past this point, we don't change OLDTYPE and NEWTYPE
13595      even if we change the types of NEWDECL and OLDDECL.  */
13596
13597   if (types_match)
13598     {
13599       /* Merge the data types specified in the two decls.  */
13600       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13601         TREE_TYPE (newdecl)
13602           = TREE_TYPE (olddecl)
13603             = TREE_TYPE (newdecl);
13604
13605       /* Lay the type out, unless already done.  */
13606       if (oldtype != TREE_TYPE (newdecl))
13607         {
13608           if (TREE_TYPE (newdecl) != error_mark_node)
13609             layout_type (TREE_TYPE (newdecl));
13610           if (TREE_CODE (newdecl) != FUNCTION_DECL
13611               && TREE_CODE (newdecl) != TYPE_DECL
13612               && TREE_CODE (newdecl) != CONST_DECL)
13613             layout_decl (newdecl, 0);
13614         }
13615       else
13616         {
13617           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13618           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13619           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13620           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13621             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13622               {
13623                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13624                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13625               }
13626         }
13627
13628       /* Keep the old rtl since we can safely use it.  */
13629       COPY_DECL_RTL (olddecl, newdecl);
13630
13631       /* Merge the type qualifiers.  */
13632       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13633           && !TREE_THIS_VOLATILE (newdecl))
13634         TREE_THIS_VOLATILE (olddecl) = 0;
13635       if (TREE_READONLY (newdecl))
13636         TREE_READONLY (olddecl) = 1;
13637       if (TREE_THIS_VOLATILE (newdecl))
13638         {
13639           TREE_THIS_VOLATILE (olddecl) = 1;
13640           if (TREE_CODE (newdecl) == VAR_DECL)
13641             make_var_volatile (newdecl);
13642         }
13643
13644       /* Keep source location of definition rather than declaration.
13645          Likewise, keep decl at outer scope.  */
13646       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13647           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13648         {
13649           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13650           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13651
13652           if (DECL_CONTEXT (olddecl) == 0
13653               && TREE_CODE (newdecl) != FUNCTION_DECL)
13654             DECL_CONTEXT (newdecl) = 0;
13655         }
13656
13657       /* Merge the unused-warning information.  */
13658       if (DECL_IN_SYSTEM_HEADER (olddecl))
13659         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13660       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13661         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13662
13663       /* Merge the initialization information.  */
13664       if (DECL_INITIAL (newdecl) == 0)
13665         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13666
13667       /* Merge the section attribute.
13668          We want to issue an error if the sections conflict but that must be
13669          done later in decl_attributes since we are called before attributes
13670          are assigned.  */
13671       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13672         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13673
13674 #if BUILT_FOR_270
13675       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13676         {
13677           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13678           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13679         }
13680 #endif
13681     }
13682   /* If cannot merge, then use the new type and qualifiers,
13683      and don't preserve the old rtl.  */
13684   else
13685     {
13686       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13687       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13688       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13689       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13690     }
13691
13692   /* Merge the storage class information.  */
13693   /* For functions, static overrides non-static.  */
13694   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13695     {
13696       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13697       /* This is since we don't automatically
13698          copy the attributes of NEWDECL into OLDDECL.  */
13699       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13700       /* If this clears `static', clear it in the identifier too.  */
13701       if (! TREE_PUBLIC (olddecl))
13702         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13703     }
13704   if (DECL_EXTERNAL (newdecl))
13705     {
13706       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13707       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13708       /* An extern decl does not override previous storage class.  */
13709       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13710     }
13711   else
13712     {
13713       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13714       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13715     }
13716
13717   /* If either decl says `inline', this fn is inline,
13718      unless its definition was passed already.  */
13719   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13720     DECL_INLINE (olddecl) = 1;
13721   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13722
13723   /* Get rid of any built-in function if new arg types don't match it
13724      or if we have a function definition.  */
13725   if (TREE_CODE (newdecl) == FUNCTION_DECL
13726       && DECL_BUILT_IN (olddecl)
13727       && (!types_match || new_is_definition))
13728     {
13729       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13730       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13731     }
13732
13733   /* If redeclaring a builtin function, and not a definition,
13734      it stays built in.
13735      Also preserve various other info from the definition.  */
13736   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13737     {
13738       if (DECL_BUILT_IN (olddecl))
13739         {
13740           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13741           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13742         }
13743
13744       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13745       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13746       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13747       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13748     }
13749
13750   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13751      But preserve olddecl's DECL_UID.  */
13752   {
13753     register unsigned olddecl_uid = DECL_UID (olddecl);
13754
13755     memcpy ((char *) olddecl + sizeof (struct tree_common),
13756             (char *) newdecl + sizeof (struct tree_common),
13757             sizeof (struct tree_decl) - sizeof (struct tree_common));
13758     DECL_UID (olddecl) = olddecl_uid;
13759   }
13760
13761   return 1;
13762 }
13763
13764 /* Finish processing of a declaration;
13765    install its initial value.
13766    If the length of an array type is not known before,
13767    it must be determined now, from the initial value, or it is an error.  */
13768
13769 static void
13770 finish_decl (tree decl, tree init, bool is_top_level)
13771 {
13772   register tree type = TREE_TYPE (decl);
13773   int was_incomplete = (DECL_SIZE (decl) == 0);
13774   bool at_top_level = (current_binding_level == global_binding_level);
13775   bool top_level = is_top_level || at_top_level;
13776
13777   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13778      level anyway.  */
13779   assert (!is_top_level || !at_top_level);
13780
13781   if (TREE_CODE (decl) == PARM_DECL)
13782     assert (init == NULL_TREE);
13783   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13784      overlaps DECL_ARG_TYPE.  */
13785   else if (init == NULL_TREE)
13786     assert (DECL_INITIAL (decl) == NULL_TREE);
13787   else
13788     assert (DECL_INITIAL (decl) == error_mark_node);
13789
13790   if (init != NULL_TREE)
13791     {
13792       if (TREE_CODE (decl) != TYPE_DECL)
13793         DECL_INITIAL (decl) = init;
13794       else
13795         {
13796           /* typedef foo = bar; store the type of bar as the type of foo.  */
13797           TREE_TYPE (decl) = TREE_TYPE (init);
13798           DECL_INITIAL (decl) = init = 0;
13799         }
13800     }
13801
13802   /* Deduce size of array from initialization, if not already known */
13803
13804   if (TREE_CODE (type) == ARRAY_TYPE
13805       && TYPE_DOMAIN (type) == 0
13806       && TREE_CODE (decl) != TYPE_DECL)
13807     {
13808       assert (top_level);
13809       assert (was_incomplete);
13810
13811       layout_decl (decl, 0);
13812     }
13813
13814   if (TREE_CODE (decl) == VAR_DECL)
13815     {
13816       if (DECL_SIZE (decl) == NULL_TREE
13817           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13818         layout_decl (decl, 0);
13819
13820       if (DECL_SIZE (decl) == NULL_TREE
13821           && (TREE_STATIC (decl)
13822               ?
13823       /* A static variable with an incomplete type is an error if it is
13824          initialized. Also if it is not file scope. Otherwise, let it
13825          through, but if it is not `extern' then it may cause an error
13826          message later.  */
13827               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13828               :
13829       /* An automatic variable with an incomplete type is an error.  */
13830               !DECL_EXTERNAL (decl)))
13831         {
13832           assert ("storage size not known" == NULL);
13833           abort ();
13834         }
13835
13836       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13837           && (DECL_SIZE (decl) != 0)
13838           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13839         {
13840           assert ("storage size not constant" == NULL);
13841           abort ();
13842         }
13843     }
13844
13845   /* Output the assembler code and/or RTL code for variables and functions,
13846      unless the type is an undefined structure or union. If not, it will get
13847      done when the type is completed.  */
13848
13849   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13850     {
13851       rest_of_decl_compilation (decl, NULL,
13852                                 DECL_CONTEXT (decl) == 0,
13853                                 0);
13854
13855       if (DECL_CONTEXT (decl) != 0)
13856         {
13857           /* Recompute the RTL of a local array now if it used to be an
13858              incomplete type.  */
13859           if (was_incomplete
13860               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13861             {
13862               /* If we used it already as memory, it must stay in memory.  */
13863               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13864               /* If it's still incomplete now, no init will save it.  */
13865               if (DECL_SIZE (decl) == 0)
13866                 DECL_INITIAL (decl) = 0;
13867               expand_decl (decl);
13868             }
13869           /* Compute and store the initial value.  */
13870           if (TREE_CODE (decl) != FUNCTION_DECL)
13871             expand_decl_init (decl);
13872         }
13873     }
13874   else if (TREE_CODE (decl) == TYPE_DECL)
13875     {
13876       rest_of_decl_compilation (decl, NULL,
13877                                 DECL_CONTEXT (decl) == 0,
13878                                 0);
13879     }
13880
13881   /* At the end of a declaration, throw away any variable type sizes of types
13882      defined inside that declaration.  There is no use computing them in the
13883      following function definition.  */
13884   if (current_binding_level == global_binding_level)
13885     get_pending_sizes ();
13886 }
13887
13888 /* Finish up a function declaration and compile that function
13889    all the way to assembler language output.  The free the storage
13890    for the function definition.
13891
13892    This is called after parsing the body of the function definition.
13893
13894    NESTED is nonzero if the function being finished is nested in another.  */
13895
13896 static void
13897 finish_function (int nested)
13898 {
13899   register tree fndecl = current_function_decl;
13900
13901   assert (fndecl != NULL_TREE);
13902   if (TREE_CODE (fndecl) != ERROR_MARK)
13903     {
13904       if (nested)
13905         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13906       else
13907         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13908     }
13909
13910 /*  TREE_READONLY (fndecl) = 1;
13911     This caused &foo to be of type ptr-to-const-function
13912     which then got a warning when stored in a ptr-to-function variable.  */
13913
13914   poplevel (1, 0, 1);
13915
13916   if (TREE_CODE (fndecl) != ERROR_MARK)
13917     {
13918       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13919
13920       /* Must mark the RESULT_DECL as being in this function.  */
13921
13922       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13923
13924       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13925       /* Generate rtl for function exit.  */
13926       expand_function_end (input_filename, lineno, 0);
13927
13928       /* If this is a nested function, protect the local variables in the stack
13929          above us from being collected while we're compiling this function.  */
13930       if (nested)
13931         ggc_push_context ();
13932
13933       /* Run the optimizers and output the assembler code for this function.  */
13934       rest_of_compilation (fndecl);
13935
13936       /* Undo the GC context switch.  */
13937       if (nested)
13938         ggc_pop_context ();
13939     }
13940
13941   if (TREE_CODE (fndecl) != ERROR_MARK
13942       && !nested
13943       && DECL_SAVED_INSNS (fndecl) == 0)
13944     {
13945       /* Stop pointing to the local nodes about to be freed.  */
13946       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13947          function definition.  */
13948       /* For a nested function, this is done in pop_f_function_context.  */
13949       /* If rest_of_compilation set this to 0, leave it 0.  */
13950       if (DECL_INITIAL (fndecl) != 0)
13951         DECL_INITIAL (fndecl) = error_mark_node;
13952       DECL_ARGUMENTS (fndecl) = 0;
13953     }
13954
13955   if (!nested)
13956     {
13957       /* Let the error reporting routines know that we're outside a function.
13958          For a nested function, this value is used in pop_c_function_context
13959          and then reset via pop_function_context.  */
13960       ffecom_outer_function_decl_ = current_function_decl = NULL;
13961     }
13962 }
13963
13964 /* Plug-in replacement for identifying the name of a decl and, for a
13965    function, what we call it in diagnostics.  For now, "program unit"
13966    should suffice, since it's a bit of a hassle to figure out which
13967    of several kinds of things it is.  Note that it could conceivably
13968    be a statement function, which probably isn't really a program unit
13969    per se, but if that comes up, it should be easy to check (being a
13970    nested function and all).  */
13971
13972 static const char *
13973 lang_printable_name (tree decl, int v)
13974 {
13975   /* Just to keep GCC quiet about the unused variable.
13976      In theory, differing values of V should produce different
13977      output.  */
13978   switch (v)
13979     {
13980     default:
13981       if (TREE_CODE (decl) == ERROR_MARK)
13982         return "erroneous code";
13983       return IDENTIFIER_POINTER (DECL_NAME (decl));
13984     }
13985 }
13986
13987 /* g77's function to print out name of current function that caused
13988    an error.  */
13989
13990 #if BUILT_FOR_270
13991 static void
13992 lang_print_error_function (const char *file)
13993 {
13994   static ffeglobal last_g = NULL;
13995   static ffesymbol last_s = NULL;
13996   ffeglobal g;
13997   ffesymbol s;
13998   const char *kind;
13999
14000   if ((ffecom_primary_entry_ == NULL)
14001       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14002     {
14003       g = NULL;
14004       s = NULL;
14005       kind = NULL;
14006     }
14007   else
14008     {
14009       g = ffesymbol_global (ffecom_primary_entry_);
14010       if (ffecom_nested_entry_ == NULL)
14011         {
14012           s = ffecom_primary_entry_;
14013           switch (ffesymbol_kind (s))
14014             {
14015             case FFEINFO_kindFUNCTION:
14016               kind = "function";
14017               break;
14018
14019             case FFEINFO_kindSUBROUTINE:
14020               kind = "subroutine";
14021               break;
14022
14023             case FFEINFO_kindPROGRAM:
14024               kind = "program";
14025               break;
14026
14027             case FFEINFO_kindBLOCKDATA:
14028               kind = "block-data";
14029               break;
14030
14031             default:
14032               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14033               break;
14034             }
14035         }
14036       else
14037         {
14038           s = ffecom_nested_entry_;
14039           kind = "statement function";
14040         }
14041     }
14042
14043   if ((last_g != g) || (last_s != s))
14044     {
14045       if (file)
14046         fprintf (stderr, "%s: ", file);
14047
14048       if (s == NULL)
14049         fprintf (stderr, "Outside of any program unit:\n");
14050       else
14051         {
14052           const char *name = ffesymbol_text (s);
14053
14054           fprintf (stderr, "In %s `%s':\n", kind, name);
14055         }
14056
14057       last_g = g;
14058       last_s = s;
14059     }
14060 }
14061 #endif
14062
14063 /* Similar to `lookup_name' but look only at current binding level.  */
14064
14065 static tree
14066 lookup_name_current_level (tree name)
14067 {
14068   register tree t;
14069
14070   if (current_binding_level == global_binding_level)
14071     return IDENTIFIER_GLOBAL_VALUE (name);
14072
14073   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14074     return 0;
14075
14076   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14077     if (DECL_NAME (t) == name)
14078       break;
14079
14080   return t;
14081 }
14082
14083 /* Create a new `struct binding_level'.  */
14084
14085 static struct binding_level *
14086 make_binding_level ()
14087 {
14088   /* NOSTRICT */
14089   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14090 }
14091
14092 /* Save and restore the variables in this file and elsewhere
14093    that keep track of the progress of compilation of the current function.
14094    Used for nested functions.  */
14095
14096 struct f_function
14097 {
14098   struct f_function *next;
14099   tree named_labels;
14100   tree shadowed_labels;
14101   struct binding_level *binding_level;
14102 };
14103
14104 struct f_function *f_function_chain;
14105
14106 /* Restore the variables used during compilation of a C function.  */
14107
14108 static void
14109 pop_f_function_context ()
14110 {
14111   struct f_function *p = f_function_chain;
14112   tree link;
14113
14114   /* Bring back all the labels that were shadowed.  */
14115   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14116     if (DECL_NAME (TREE_VALUE (link)) != 0)
14117       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14118         = TREE_VALUE (link);
14119
14120   if (current_function_decl != error_mark_node
14121       && DECL_SAVED_INSNS (current_function_decl) == 0)
14122     {
14123       /* Stop pointing to the local nodes about to be freed.  */
14124       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14125          function definition.  */
14126       DECL_INITIAL (current_function_decl) = error_mark_node;
14127       DECL_ARGUMENTS (current_function_decl) = 0;
14128     }
14129
14130   pop_function_context ();
14131
14132   f_function_chain = p->next;
14133
14134   named_labels = p->named_labels;
14135   shadowed_labels = p->shadowed_labels;
14136   current_binding_level = p->binding_level;
14137
14138   free (p);
14139 }
14140
14141 /* Save and reinitialize the variables
14142    used during compilation of a C function.  */
14143
14144 static void
14145 push_f_function_context ()
14146 {
14147   struct f_function *p
14148   = (struct f_function *) xmalloc (sizeof (struct f_function));
14149
14150   push_function_context ();
14151
14152   p->next = f_function_chain;
14153   f_function_chain = p;
14154
14155   p->named_labels = named_labels;
14156   p->shadowed_labels = shadowed_labels;
14157   p->binding_level = current_binding_level;
14158 }
14159
14160 static void
14161 push_parm_decl (tree parm)
14162 {
14163   int old_immediate_size_expand = immediate_size_expand;
14164
14165   /* Don't try computing parm sizes now -- wait till fn is called.  */
14166
14167   immediate_size_expand = 0;
14168
14169   /* Fill in arg stuff.  */
14170
14171   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14172   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14173   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14174
14175   parm = pushdecl (parm);
14176
14177   immediate_size_expand = old_immediate_size_expand;
14178
14179   finish_decl (parm, NULL_TREE, FALSE);
14180 }
14181
14182 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14183
14184 static tree
14185 pushdecl_top_level (x)
14186      tree x;
14187 {
14188   register tree t;
14189   register struct binding_level *b = current_binding_level;
14190   register tree f = current_function_decl;
14191
14192   current_binding_level = global_binding_level;
14193   current_function_decl = NULL_TREE;
14194   t = pushdecl (x);
14195   current_binding_level = b;
14196   current_function_decl = f;
14197   return t;
14198 }
14199
14200 /* Store the list of declarations of the current level.
14201    This is done for the parameter declarations of a function being defined,
14202    after they are modified in the light of any missing parameters.  */
14203
14204 static tree
14205 storedecls (decls)
14206      tree decls;
14207 {
14208   return current_binding_level->names = decls;
14209 }
14210
14211 /* Store the parameter declarations into the current function declaration.
14212    This is called after parsing the parameter declarations, before
14213    digesting the body of the function.
14214
14215    For an old-style definition, modify the function's type
14216    to specify at least the number of arguments.  */
14217
14218 static void
14219 store_parm_decls (int is_main_program UNUSED)
14220 {
14221   register tree fndecl = current_function_decl;
14222
14223   if (fndecl == error_mark_node)
14224     return;
14225
14226   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14227   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14228
14229   /* Initialize the RTL code for the function.  */
14230
14231   init_function_start (fndecl, input_filename, lineno);
14232
14233   /* Set up parameters and prepare for return, for the function.  */
14234
14235   expand_function_start (fndecl, 0);
14236 }
14237
14238 static tree
14239 start_decl (tree decl, bool is_top_level)
14240 {
14241   register tree tem;
14242   bool at_top_level = (current_binding_level == global_binding_level);
14243   bool top_level = is_top_level || at_top_level;
14244
14245   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14246      level anyway.  */
14247   assert (!is_top_level || !at_top_level);
14248
14249   if (DECL_INITIAL (decl) != NULL_TREE)
14250     {
14251       assert (DECL_INITIAL (decl) == error_mark_node);
14252       assert (!DECL_EXTERNAL (decl));
14253     }
14254   else if (top_level)
14255     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14256
14257   /* For Fortran, we by default put things in .common when possible.  */
14258   DECL_COMMON (decl) = 1;
14259
14260   /* Add this decl to the current binding level. TEM may equal DECL or it may
14261      be a previous decl of the same name.  */
14262   if (is_top_level)
14263     tem = pushdecl_top_level (decl);
14264   else
14265     tem = pushdecl (decl);
14266
14267   /* For a local variable, define the RTL now.  */
14268   if (!top_level
14269   /* But not if this is a duplicate decl and we preserved the rtl from the
14270      previous one (which may or may not happen).  */
14271       && !DECL_RTL_SET_P (tem))
14272     {
14273       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14274         expand_decl (tem);
14275       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14276                && DECL_INITIAL (tem) != 0)
14277         expand_decl (tem);
14278     }
14279
14280   return tem;
14281 }
14282
14283 /* Create the FUNCTION_DECL for a function definition.
14284    DECLSPECS and DECLARATOR are the parts of the declaration;
14285    they describe the function's name and the type it returns,
14286    but twisted together in a fashion that parallels the syntax of C.
14287
14288    This function creates a binding context for the function body
14289    as well as setting up the FUNCTION_DECL in current_function_decl.
14290
14291    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14292    (it defines a datum instead), we return 0, which tells
14293    yyparse to report a parse error.
14294
14295    NESTED is nonzero for a function nested within another function.  */
14296
14297 static void
14298 start_function (tree name, tree type, int nested, int public)
14299 {
14300   tree decl1;
14301   tree restype;
14302   int old_immediate_size_expand = immediate_size_expand;
14303
14304   named_labels = 0;
14305   shadowed_labels = 0;
14306
14307   /* Don't expand any sizes in the return type of the function.  */
14308   immediate_size_expand = 0;
14309
14310   if (nested)
14311     {
14312       assert (!public);
14313       assert (current_function_decl != NULL_TREE);
14314       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14315     }
14316   else
14317     {
14318       assert (current_function_decl == NULL_TREE);
14319     }
14320
14321   if (TREE_CODE (type) == ERROR_MARK)
14322     decl1 = current_function_decl = error_mark_node;
14323   else
14324     {
14325       decl1 = build_decl (FUNCTION_DECL,
14326                           name,
14327                           type);
14328       TREE_PUBLIC (decl1) = public ? 1 : 0;
14329       if (nested)
14330         DECL_INLINE (decl1) = 1;
14331       TREE_STATIC (decl1) = 1;
14332       DECL_EXTERNAL (decl1) = 0;
14333
14334       announce_function (decl1);
14335
14336       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14337          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14338       DECL_INITIAL (decl1) = error_mark_node;
14339
14340       /* Record the decl so that the function name is defined. If we already have
14341          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14342
14343       current_function_decl = pushdecl (decl1);
14344     }
14345
14346   if (!nested)
14347     ffecom_outer_function_decl_ = current_function_decl;
14348
14349   pushlevel (0);
14350   current_binding_level->prep_state = 2;
14351
14352   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14353     {
14354       make_decl_rtl (current_function_decl, NULL);
14355
14356       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14357       DECL_RESULT (current_function_decl)
14358         = build_decl (RESULT_DECL, NULL_TREE, restype);
14359     }
14360
14361   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14362     TREE_ADDRESSABLE (current_function_decl) = 1;
14363
14364   immediate_size_expand = old_immediate_size_expand;
14365 }
14366 \f
14367 /* Here are the public functions the GNU back end needs.  */
14368
14369 tree
14370 convert (type, expr)
14371      tree type, expr;
14372 {
14373   register tree e = expr;
14374   register enum tree_code code = TREE_CODE (type);
14375
14376   if (type == TREE_TYPE (e)
14377       || TREE_CODE (e) == ERROR_MARK)
14378     return e;
14379   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14380     return fold (build1 (NOP_EXPR, type, e));
14381   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14382       || code == ERROR_MARK)
14383     return error_mark_node;
14384   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14385     {
14386       assert ("void value not ignored as it ought to be" == NULL);
14387       return error_mark_node;
14388     }
14389   if (code == VOID_TYPE)
14390     return build1 (CONVERT_EXPR, type, e);
14391   if ((code != RECORD_TYPE)
14392       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14393     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14394                   e);
14395   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14396     return fold (convert_to_integer (type, e));
14397   if (code == POINTER_TYPE)
14398     return fold (convert_to_pointer (type, e));
14399   if (code == REAL_TYPE)
14400     return fold (convert_to_real (type, e));
14401   if (code == COMPLEX_TYPE)
14402     return fold (convert_to_complex (type, e));
14403   if (code == RECORD_TYPE)
14404     return fold (ffecom_convert_to_complex_ (type, e));
14405
14406   assert ("conversion to non-scalar type requested" == NULL);
14407   return error_mark_node;
14408 }
14409
14410 /* integrate_decl_tree calls this function, but since we don't use the
14411    DECL_LANG_SPECIFIC field, this is a no-op.  */
14412
14413 void
14414 copy_lang_decl (node)
14415      tree node UNUSED;
14416 {
14417 }
14418
14419 /* Return the list of declarations of the current level.
14420    Note that this list is in reverse order unless/until
14421    you nreverse it; and when you do nreverse it, you must
14422    store the result back using `storedecls' or you will lose.  */
14423
14424 tree
14425 getdecls ()
14426 {
14427   return current_binding_level->names;
14428 }
14429
14430 /* Nonzero if we are currently in the global binding level.  */
14431
14432 int
14433 global_bindings_p ()
14434 {
14435   return current_binding_level == global_binding_level;
14436 }
14437
14438 /* Print an error message for invalid use of an incomplete type.
14439    VALUE is the expression that was used (or 0 if that isn't known)
14440    and TYPE is the type that was invalid.  */
14441
14442 void
14443 incomplete_type_error (value, type)
14444      tree value UNUSED;
14445      tree type;
14446 {
14447   if (TREE_CODE (type) == ERROR_MARK)
14448     return;
14449
14450   assert ("incomplete type?!?" == NULL);
14451 }
14452
14453 /* Mark ARG for GC.  */
14454 static void
14455 mark_binding_level (void *arg)
14456 {
14457   struct binding_level *level = *(struct binding_level **) arg;
14458
14459   while (level)
14460     {
14461       ggc_mark_tree (level->names);
14462       ggc_mark_tree (level->blocks);
14463       ggc_mark_tree (level->this_block);
14464       level = level->level_chain;
14465     }
14466 }
14467
14468 void
14469 init_decl_processing ()
14470 {
14471   static tree *const tree_roots[] = {
14472     &current_function_decl,
14473     &string_type_node,
14474     &ffecom_tree_fun_type_void,
14475     &ffecom_integer_zero_node,
14476     &ffecom_integer_one_node,
14477     &ffecom_tree_subr_type,
14478     &ffecom_tree_ptr_to_subr_type,
14479     &ffecom_tree_blockdata_type,
14480     &ffecom_tree_xargc_,
14481     &ffecom_f2c_integer_type_node,
14482     &ffecom_f2c_ptr_to_integer_type_node,
14483     &ffecom_f2c_address_type_node,
14484     &ffecom_f2c_real_type_node,
14485     &ffecom_f2c_ptr_to_real_type_node,
14486     &ffecom_f2c_doublereal_type_node,
14487     &ffecom_f2c_complex_type_node,
14488     &ffecom_f2c_doublecomplex_type_node,
14489     &ffecom_f2c_longint_type_node,
14490     &ffecom_f2c_logical_type_node,
14491     &ffecom_f2c_flag_type_node,
14492     &ffecom_f2c_ftnlen_type_node,
14493     &ffecom_f2c_ftnlen_zero_node,
14494     &ffecom_f2c_ftnlen_one_node,
14495     &ffecom_f2c_ftnlen_two_node,
14496     &ffecom_f2c_ptr_to_ftnlen_type_node,
14497     &ffecom_f2c_ftnint_type_node,
14498     &ffecom_f2c_ptr_to_ftnint_type_node,
14499     &ffecom_outer_function_decl_,
14500     &ffecom_previous_function_decl_,
14501     &ffecom_which_entrypoint_decl_,
14502     &ffecom_float_zero_,
14503     &ffecom_float_half_,
14504     &ffecom_double_zero_,
14505     &ffecom_double_half_,
14506     &ffecom_func_result_,
14507     &ffecom_func_length_,
14508     &ffecom_multi_type_node_,
14509     &ffecom_multi_retval_,
14510     &named_labels,
14511     &shadowed_labels
14512   };
14513   size_t i;
14514
14515   malloc_init ();
14516
14517   /* Record our roots.  */
14518   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14519     ggc_add_tree_root (tree_roots[i], 1);
14520   ggc_add_tree_root (&ffecom_tree_type[0][0],
14521                      FFEINFO_basictype*FFEINFO_kindtype);
14522   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14523                      FFEINFO_basictype*FFEINFO_kindtype);
14524   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14525                      FFEINFO_basictype*FFEINFO_kindtype);
14526   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14527   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14528                 mark_binding_level);
14529   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14530                 mark_binding_level);
14531   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14532
14533   ffe_init_0 ();
14534 }
14535
14536 const char *
14537 init_parse (filename)
14538      const char *filename;
14539 {
14540   /* Open input file.  */
14541   if (filename == 0 || !strcmp (filename, "-"))
14542     {
14543       finput = stdin;
14544       filename = "stdin";
14545     }
14546   else
14547     finput = fopen (filename, "r");
14548   if (finput == 0)
14549     fatal_io_error ("can't open %s", filename);
14550
14551 #ifdef IO_BUFFER_SIZE
14552   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14553 #endif
14554
14555   /* Make identifier nodes long enough for the language-specific slots.  */
14556   set_identifier_size (sizeof (struct lang_identifier));
14557   decl_printable_name = lang_printable_name;
14558 #if BUILT_FOR_270
14559   print_error_function = lang_print_error_function;
14560 #endif
14561
14562   return filename;
14563 }
14564
14565 void
14566 finish_parse ()
14567 {
14568   fclose (finput);
14569 }
14570
14571 /* Delete the node BLOCK from the current binding level.
14572    This is used for the block inside a stmt expr ({...})
14573    so that the block can be reinserted where appropriate.  */
14574
14575 static void
14576 delete_block (block)
14577      tree block;
14578 {
14579   tree t;
14580   if (current_binding_level->blocks == block)
14581     current_binding_level->blocks = TREE_CHAIN (block);
14582   for (t = current_binding_level->blocks; t;)
14583     {
14584       if (TREE_CHAIN (t) == block)
14585         TREE_CHAIN (t) = TREE_CHAIN (block);
14586       else
14587         t = TREE_CHAIN (t);
14588     }
14589   TREE_CHAIN (block) = NULL;
14590   /* Clear TREE_USED which is always set by poplevel.
14591      The flag is set again if insert_block is called.  */
14592   TREE_USED (block) = 0;
14593 }
14594
14595 void
14596 insert_block (block)
14597      tree block;
14598 {
14599   TREE_USED (block) = 1;
14600   current_binding_level->blocks
14601     = chainon (current_binding_level->blocks, block);
14602 }
14603
14604 /* Each front end provides its own.  */
14605 static void ffe_init PARAMS ((void));
14606 static void ffe_finish PARAMS ((void));
14607 static void ffe_init_options PARAMS ((void));
14608
14609 struct lang_hooks lang_hooks = {ffe_init,
14610                                 ffe_finish,
14611                                 ffe_init_options,
14612                                 ffe_decode_option,
14613                                 NULL /* post_options */};
14614
14615 /* used by print-tree.c */
14616
14617 void
14618 lang_print_xnode (file, node, indent)
14619      FILE *file UNUSED;
14620      tree node UNUSED;
14621      int indent UNUSED;
14622 {
14623 }
14624
14625 static void
14626 ffe_finish ()
14627 {
14628   ffe_terminate_0 ();
14629
14630   if (ffe_is_ffedebug ())
14631     malloc_pool_display (malloc_pool_image ());
14632 }
14633
14634 const char *
14635 lang_identify ()
14636 {
14637   return "f77";
14638 }
14639
14640 /* Return the typed-based alias set for T, which may be an expression
14641    or a type.  Return -1 if we don't do anything special.  */
14642
14643 HOST_WIDE_INT
14644 lang_get_alias_set (t)
14645      tree t ATTRIBUTE_UNUSED;
14646 {
14647   /* We do not wish to use alias-set based aliasing at all.  Used in the
14648      extreme (every object with its own set, with equivalences recorded)
14649      it might be helpful, but there are problems when it comes to inlining.
14650      We get on ok with flag_argument_noalias, and alias-set aliasing does
14651      currently limit how stack slots can be reused, which is a lose.  */
14652   return 0;
14653 }
14654
14655 static void
14656 ffe_init_options ()
14657 {
14658   /* Set default options for Fortran.  */
14659   flag_move_all_movables = 1;
14660   flag_reduce_all_givs = 1;
14661   flag_argument_noalias = 2;
14662   flag_errno_math = 0;
14663   flag_complex_divide_method = 1;
14664 }
14665
14666 static void
14667 ffe_init ()
14668 {
14669   /* If the file is output from cpp, it should contain a first line
14670      `# 1 "real-filename"', and the current design of gcc (toplev.c
14671      in particular and the way it sets up information relied on by
14672      INCLUDE) requires that we read this now, and store the
14673      "real-filename" info in master_input_filename.  Ask the lexer
14674      to try doing this.  */
14675   ffelex_hash_kludge (finput);
14676 }
14677
14678 int
14679 mark_addressable (exp)
14680      tree exp;
14681 {
14682   register tree x = exp;
14683   while (1)
14684     switch (TREE_CODE (x))
14685       {
14686       case ADDR_EXPR:
14687       case COMPONENT_REF:
14688       case ARRAY_REF:
14689         x = TREE_OPERAND (x, 0);
14690         break;
14691
14692       case CONSTRUCTOR:
14693         TREE_ADDRESSABLE (x) = 1;
14694         return 1;
14695
14696       case VAR_DECL:
14697       case CONST_DECL:
14698       case PARM_DECL:
14699       case RESULT_DECL:
14700         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14701             && DECL_NONLOCAL (x))
14702           {
14703             if (TREE_PUBLIC (x))
14704               {
14705                 assert ("address of global register var requested" == NULL);
14706                 return 0;
14707               }
14708             assert ("address of register variable requested" == NULL);
14709           }
14710         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14711           {
14712             if (TREE_PUBLIC (x))
14713               {
14714                 assert ("address of global register var requested" == NULL);
14715                 return 0;
14716               }
14717             assert ("address of register var requested" == NULL);
14718           }
14719         put_var_into_stack (x);
14720
14721         /* drops in */
14722       case FUNCTION_DECL:
14723         TREE_ADDRESSABLE (x) = 1;
14724 #if 0                           /* poplevel deals with this now.  */
14725         if (DECL_CONTEXT (x) == 0)
14726           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14727 #endif
14728
14729       default:
14730         return 1;
14731       }
14732 }
14733
14734 /* If DECL has a cleanup, build and return that cleanup here.
14735    This is a callback called by expand_expr.  */
14736
14737 tree
14738 maybe_build_cleanup (decl)
14739      tree decl UNUSED;
14740 {
14741   /* There are no cleanups in Fortran.  */
14742   return NULL_TREE;
14743 }
14744
14745 /* Exit a binding level.
14746    Pop the level off, and restore the state of the identifier-decl mappings
14747    that were in effect when this level was entered.
14748
14749    If KEEP is nonzero, this level had explicit declarations, so
14750    and create a "block" (a BLOCK node) for the level
14751    to record its declarations and subblocks for symbol table output.
14752
14753    If FUNCTIONBODY is nonzero, this level is the body of a function,
14754    so create a block as if KEEP were set and also clear out all
14755    label names.
14756
14757    If REVERSE is nonzero, reverse the order of decls before putting
14758    them into the BLOCK.  */
14759
14760 tree
14761 poplevel (keep, reverse, functionbody)
14762      int keep;
14763      int reverse;
14764      int functionbody;
14765 {
14766   register tree link;
14767   /* The chain of decls was accumulated in reverse order.
14768      Put it into forward order, just for cleanliness.  */
14769   tree decls;
14770   tree subblocks = current_binding_level->blocks;
14771   tree block = 0;
14772   tree decl;
14773   int block_previously_created;
14774
14775   /* Get the decls in the order they were written.
14776      Usually current_binding_level->names is in reverse order.
14777      But parameter decls were previously put in forward order.  */
14778
14779   if (reverse)
14780     current_binding_level->names
14781       = decls = nreverse (current_binding_level->names);
14782   else
14783     decls = current_binding_level->names;
14784
14785   /* Output any nested inline functions within this block
14786      if they weren't already output.  */
14787
14788   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14789     if (TREE_CODE (decl) == FUNCTION_DECL
14790         && ! TREE_ASM_WRITTEN (decl)
14791         && DECL_INITIAL (decl) != 0
14792         && TREE_ADDRESSABLE (decl))
14793       {
14794         /* If this decl was copied from a file-scope decl
14795            on account of a block-scope extern decl,
14796            propagate TREE_ADDRESSABLE to the file-scope decl.
14797
14798            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14799            true, since then the decl goes through save_for_inline_copying.  */
14800         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14801             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14802           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14803         else if (DECL_SAVED_INSNS (decl) != 0)
14804           {
14805             push_function_context ();
14806             output_inline_function (decl);
14807             pop_function_context ();
14808           }
14809       }
14810
14811   /* If there were any declarations or structure tags in that level,
14812      or if this level is a function body,
14813      create a BLOCK to record them for the life of this function.  */
14814
14815   block = 0;
14816   block_previously_created = (current_binding_level->this_block != 0);
14817   if (block_previously_created)
14818     block = current_binding_level->this_block;
14819   else if (keep || functionbody)
14820     block = make_node (BLOCK);
14821   if (block != 0)
14822     {
14823       BLOCK_VARS (block) = decls;
14824       BLOCK_SUBBLOCKS (block) = subblocks;
14825     }
14826
14827   /* In each subblock, record that this is its superior.  */
14828
14829   for (link = subblocks; link; link = TREE_CHAIN (link))
14830     BLOCK_SUPERCONTEXT (link) = block;
14831
14832   /* Clear out the meanings of the local variables of this level.  */
14833
14834   for (link = decls; link; link = TREE_CHAIN (link))
14835     {
14836       if (DECL_NAME (link) != 0)
14837         {
14838           /* If the ident. was used or addressed via a local extern decl,
14839              don't forget that fact.  */
14840           if (DECL_EXTERNAL (link))
14841             {
14842               if (TREE_USED (link))
14843                 TREE_USED (DECL_NAME (link)) = 1;
14844               if (TREE_ADDRESSABLE (link))
14845                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14846             }
14847           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14848         }
14849     }
14850
14851   /* If the level being exited is the top level of a function,
14852      check over all the labels, and clear out the current
14853      (function local) meanings of their names.  */
14854
14855   if (functionbody)
14856     {
14857       /* If this is the top level block of a function,
14858          the vars are the function's parameters.
14859          Don't leave them in the BLOCK because they are
14860          found in the FUNCTION_DECL instead.  */
14861
14862       BLOCK_VARS (block) = 0;
14863     }
14864
14865   /* Pop the current level, and free the structure for reuse.  */
14866
14867   {
14868     register struct binding_level *level = current_binding_level;
14869     current_binding_level = current_binding_level->level_chain;
14870
14871     level->level_chain = free_binding_level;
14872     free_binding_level = level;
14873   }
14874
14875   /* Dispose of the block that we just made inside some higher level.  */
14876   if (functionbody
14877       && current_function_decl != error_mark_node)
14878     DECL_INITIAL (current_function_decl) = block;
14879   else if (block)
14880     {
14881       if (!block_previously_created)
14882         current_binding_level->blocks
14883           = chainon (current_binding_level->blocks, block);
14884     }
14885   /* If we did not make a block for the level just exited,
14886      any blocks made for inner levels
14887      (since they cannot be recorded as subblocks in that level)
14888      must be carried forward so they will later become subblocks
14889      of something else.  */
14890   else if (subblocks)
14891     current_binding_level->blocks
14892       = chainon (current_binding_level->blocks, subblocks);
14893
14894   if (block)
14895     TREE_USED (block) = 1;
14896   return block;
14897 }
14898
14899 void
14900 print_lang_decl (file, node, indent)
14901      FILE *file UNUSED;
14902      tree node UNUSED;
14903      int indent UNUSED;
14904 {
14905 }
14906
14907 void
14908 print_lang_identifier (file, node, indent)
14909      FILE *file;
14910      tree node;
14911      int indent;
14912 {
14913   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14914   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14915 }
14916
14917 void
14918 print_lang_statistics ()
14919 {
14920 }
14921
14922 void
14923 print_lang_type (file, node, indent)
14924      FILE *file UNUSED;
14925      tree node UNUSED;
14926      int indent UNUSED;
14927 {
14928 }
14929
14930 /* Record a decl-node X as belonging to the current lexical scope.
14931    Check for errors (such as an incompatible declaration for the same
14932    name already seen in the same scope).
14933
14934    Returns either X or an old decl for the same name.
14935    If an old decl is returned, it may have been smashed
14936    to agree with what X says.  */
14937
14938 tree
14939 pushdecl (x)
14940      tree x;
14941 {
14942   register tree t;
14943   register tree name = DECL_NAME (x);
14944   register struct binding_level *b = current_binding_level;
14945
14946   if ((TREE_CODE (x) == FUNCTION_DECL)
14947       && (DECL_INITIAL (x) == 0)
14948       && DECL_EXTERNAL (x))
14949     DECL_CONTEXT (x) = NULL_TREE;
14950   else
14951     DECL_CONTEXT (x) = current_function_decl;
14952
14953   if (name)
14954     {
14955       if (IDENTIFIER_INVENTED (name))
14956         {
14957 #if BUILT_FOR_270
14958           DECL_ARTIFICIAL (x) = 1;
14959 #endif
14960           DECL_IN_SYSTEM_HEADER (x) = 1;
14961         }
14962
14963       t = lookup_name_current_level (name);
14964
14965       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14966
14967       /* Don't push non-parms onto list for parms until we understand
14968          why we're doing this and whether it works.  */
14969
14970       assert ((b == global_binding_level)
14971               || !ffecom_transform_only_dummies_
14972               || TREE_CODE (x) == PARM_DECL);
14973
14974       if ((t != NULL_TREE) && duplicate_decls (x, t))
14975         return t;
14976
14977       /* If we are processing a typedef statement, generate a whole new
14978          ..._TYPE node (which will be just an variant of the existing
14979          ..._TYPE node with identical properties) and then install the
14980          TYPE_DECL node generated to represent the typedef name as the
14981          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14982
14983          The whole point here is to end up with a situation where each and every
14984          ..._TYPE node the compiler creates will be uniquely associated with
14985          AT MOST one node representing a typedef name. This way, even though
14986          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14987          (i.e. "typedef name") nodes very early on, later parts of the
14988          compiler can always do the reverse translation and get back the
14989          corresponding typedef name.  For example, given:
14990
14991          typedef struct S MY_TYPE; MY_TYPE object;
14992
14993          Later parts of the compiler might only know that `object' was of type
14994          `struct S' if it were not for code just below.  With this code
14995          however, later parts of the compiler see something like:
14996
14997          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14998
14999          And they can then deduce (from the node for type struct S') that the
15000          original object declaration was:
15001
15002          MY_TYPE object;
15003
15004          Being able to do this is important for proper support of protoize, and
15005          also for generating precise symbolic debugging information which
15006          takes full account of the programmer's (typedef) vocabulary.
15007
15008          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15009          TYPE_DECL node that we are now processing really represents a
15010          standard built-in type.
15011
15012          Since all standard types are effectively declared at line zero in the
15013          source file, we can easily check to see if we are working on a
15014          standard type by checking the current value of lineno.  */
15015
15016       if (TREE_CODE (x) == TYPE_DECL)
15017         {
15018           if (DECL_SOURCE_LINE (x) == 0)
15019             {
15020               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15021                 TYPE_NAME (TREE_TYPE (x)) = x;
15022             }
15023           else if (TREE_TYPE (x) != error_mark_node)
15024             {
15025               tree tt = TREE_TYPE (x);
15026
15027               tt = build_type_copy (tt);
15028               TYPE_NAME (tt) = x;
15029               TREE_TYPE (x) = tt;
15030             }
15031         }
15032
15033       /* This name is new in its binding level. Install the new declaration
15034          and return it.  */
15035       if (b == global_binding_level)
15036         IDENTIFIER_GLOBAL_VALUE (name) = x;
15037       else
15038         IDENTIFIER_LOCAL_VALUE (name) = x;
15039     }
15040
15041   /* Put decls on list in reverse order. We will reverse them later if
15042      necessary.  */
15043   TREE_CHAIN (x) = b->names;
15044   b->names = x;
15045
15046   return x;
15047 }
15048
15049 /* Nonzero if the current level needs to have a BLOCK made.  */
15050
15051 static int
15052 kept_level_p ()
15053 {
15054   tree decl;
15055
15056   for (decl = current_binding_level->names;
15057        decl;
15058        decl = TREE_CHAIN (decl))
15059     {
15060       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15061           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15062         /* Currently, there aren't supposed to be non-artificial names
15063            at other than the top block for a function -- they're
15064            believed to always be temps.  But it's wise to check anyway.  */
15065         return 1;
15066     }
15067   return 0;
15068 }
15069
15070 /* Enter a new binding level.
15071    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15072    not for that of tags.  */
15073
15074 void
15075 pushlevel (tag_transparent)
15076      int tag_transparent;
15077 {
15078   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15079
15080   assert (! tag_transparent);
15081
15082   if (current_binding_level == global_binding_level)
15083     {
15084       named_labels = 0;
15085     }
15086
15087   /* Reuse or create a struct for this binding level.  */
15088
15089   if (free_binding_level)
15090     {
15091       newlevel = free_binding_level;
15092       free_binding_level = free_binding_level->level_chain;
15093     }
15094   else
15095     {
15096       newlevel = make_binding_level ();
15097     }
15098
15099   /* Add this level to the front of the chain (stack) of levels that
15100      are active.  */
15101
15102   *newlevel = clear_binding_level;
15103   newlevel->level_chain = current_binding_level;
15104   current_binding_level = newlevel;
15105 }
15106
15107 /* Set the BLOCK node for the innermost scope
15108    (the one we are currently in).  */
15109
15110 void
15111 set_block (block)
15112      register tree block;
15113 {
15114   current_binding_level->this_block = block;
15115   current_binding_level->names = chainon (current_binding_level->names,
15116                                           BLOCK_VARS (block));
15117   current_binding_level->blocks = chainon (current_binding_level->blocks,
15118                                            BLOCK_SUBBLOCKS (block));
15119 }
15120
15121 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15122
15123 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15124
15125 void
15126 set_yydebug (value)
15127      int value;
15128 {
15129   if (value)
15130     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15131 }
15132
15133 tree
15134 signed_or_unsigned_type (unsignedp, type)
15135      int unsignedp;
15136      tree type;
15137 {
15138   tree type2;
15139
15140   if (! INTEGRAL_TYPE_P (type))
15141     return type;
15142   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15143     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15144   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15145     return unsignedp ? unsigned_type_node : integer_type_node;
15146   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15147     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15148   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15149     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15150   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15151     return (unsignedp ? long_long_unsigned_type_node
15152             : long_long_integer_type_node);
15153
15154   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15155   if (type2 == NULL_TREE)
15156     return type;
15157
15158   return type2;
15159 }
15160
15161 tree
15162 signed_type (type)
15163      tree type;
15164 {
15165   tree type1 = TYPE_MAIN_VARIANT (type);
15166   ffeinfoKindtype kt;
15167   tree type2;
15168
15169   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15170     return signed_char_type_node;
15171   if (type1 == unsigned_type_node)
15172     return integer_type_node;
15173   if (type1 == short_unsigned_type_node)
15174     return short_integer_type_node;
15175   if (type1 == long_unsigned_type_node)
15176     return long_integer_type_node;
15177   if (type1 == long_long_unsigned_type_node)
15178     return long_long_integer_type_node;
15179 #if 0   /* gcc/c-* files only */
15180   if (type1 == unsigned_intDI_type_node)
15181     return intDI_type_node;
15182   if (type1 == unsigned_intSI_type_node)
15183     return intSI_type_node;
15184   if (type1 == unsigned_intHI_type_node)
15185     return intHI_type_node;
15186   if (type1 == unsigned_intQI_type_node)
15187     return intQI_type_node;
15188 #endif
15189
15190   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15191   if (type2 != NULL_TREE)
15192     return type2;
15193
15194   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15195     {
15196       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15197
15198       if (type1 == type2)
15199         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15200     }
15201
15202   return type;
15203 }
15204
15205 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15206    or validate its data type for an `if' or `while' statement or ?..: exp.
15207
15208    This preparation consists of taking the ordinary
15209    representation of an expression expr and producing a valid tree
15210    boolean expression describing whether expr is nonzero.  We could
15211    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15212    but we optimize comparisons, &&, ||, and !.
15213
15214    The resulting type should always be `integer_type_node'.  */
15215
15216 tree
15217 truthvalue_conversion (expr)
15218      tree expr;
15219 {
15220   if (TREE_CODE (expr) == ERROR_MARK)
15221     return expr;
15222
15223 #if 0 /* This appears to be wrong for C++.  */
15224   /* These really should return error_mark_node after 2.4 is stable.
15225      But not all callers handle ERROR_MARK properly.  */
15226   switch (TREE_CODE (TREE_TYPE (expr)))
15227     {
15228     case RECORD_TYPE:
15229       error ("struct type value used where scalar is required");
15230       return integer_zero_node;
15231
15232     case UNION_TYPE:
15233       error ("union type value used where scalar is required");
15234       return integer_zero_node;
15235
15236     case ARRAY_TYPE:
15237       error ("array type value used where scalar is required");
15238       return integer_zero_node;
15239
15240     default:
15241       break;
15242     }
15243 #endif /* 0 */
15244
15245   switch (TREE_CODE (expr))
15246     {
15247       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15248          or comparison expressions as truth values at this level.  */
15249 #if 0
15250     case COMPONENT_REF:
15251       /* A one-bit unsigned bit-field is already acceptable.  */
15252       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15253           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15254         return expr;
15255       break;
15256 #endif
15257
15258     case EQ_EXPR:
15259       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15260          or comparison expressions as truth values at this level.  */
15261 #if 0
15262       if (integer_zerop (TREE_OPERAND (expr, 1)))
15263         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15264 #endif
15265     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15266     case TRUTH_ANDIF_EXPR:
15267     case TRUTH_ORIF_EXPR:
15268     case TRUTH_AND_EXPR:
15269     case TRUTH_OR_EXPR:
15270     case TRUTH_XOR_EXPR:
15271       TREE_TYPE (expr) = integer_type_node;
15272       return expr;
15273
15274     case ERROR_MARK:
15275       return expr;
15276
15277     case INTEGER_CST:
15278       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15279
15280     case REAL_CST:
15281       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15282
15283     case ADDR_EXPR:
15284       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15285         return build (COMPOUND_EXPR, integer_type_node,
15286                       TREE_OPERAND (expr, 0), integer_one_node);
15287       else
15288         return integer_one_node;
15289
15290     case COMPLEX_EXPR:
15291       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15292                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15293                        integer_type_node,
15294                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15295                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15296
15297     case NEGATE_EXPR:
15298     case ABS_EXPR:
15299     case FLOAT_EXPR:
15300     case FFS_EXPR:
15301       /* These don't change whether an object is non-zero or zero.  */
15302       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15303
15304     case LROTATE_EXPR:
15305     case RROTATE_EXPR:
15306       /* These don't change whether an object is zero or non-zero, but
15307          we can't ignore them if their second arg has side-effects.  */
15308       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15309         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15310                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15311       else
15312         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15313
15314     case COND_EXPR:
15315       /* Distribute the conversion into the arms of a COND_EXPR.  */
15316       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15317                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15318                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15319
15320     case CONVERT_EXPR:
15321       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15322          since that affects how `default_conversion' will behave.  */
15323       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15324           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15325         break;
15326       /* fall through... */
15327     case NOP_EXPR:
15328       /* If this is widening the argument, we can ignore it.  */
15329       if (TYPE_PRECISION (TREE_TYPE (expr))
15330           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15331         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15332       break;
15333
15334     case MINUS_EXPR:
15335       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15336          this case.  */
15337       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15338           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15339         break;
15340       /* fall through... */
15341     case BIT_XOR_EXPR:
15342       /* This and MINUS_EXPR can be changed into a comparison of the
15343          two objects.  */
15344       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15345           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15346         return ffecom_2 (NE_EXPR, integer_type_node,
15347                          TREE_OPERAND (expr, 0),
15348                          TREE_OPERAND (expr, 1));
15349       return ffecom_2 (NE_EXPR, integer_type_node,
15350                        TREE_OPERAND (expr, 0),
15351                        fold (build1 (NOP_EXPR,
15352                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15353                                      TREE_OPERAND (expr, 1))));
15354
15355     case BIT_AND_EXPR:
15356       if (integer_onep (TREE_OPERAND (expr, 1)))
15357         return expr;
15358       break;
15359
15360     case MODIFY_EXPR:
15361 #if 0                           /* No such thing in Fortran. */
15362       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15363         warning ("suggest parentheses around assignment used as truth value");
15364 #endif
15365       break;
15366
15367     default:
15368       break;
15369     }
15370
15371   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15372     return (ffecom_2
15373             ((TREE_SIDE_EFFECTS (expr)
15374               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15375              integer_type_node,
15376              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15377                                               TREE_TYPE (TREE_TYPE (expr)),
15378                                               expr)),
15379              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15380                                               TREE_TYPE (TREE_TYPE (expr)),
15381                                               expr))));
15382
15383   return ffecom_2 (NE_EXPR, integer_type_node,
15384                    expr,
15385                    convert (TREE_TYPE (expr), integer_zero_node));
15386 }
15387
15388 tree
15389 type_for_mode (mode, unsignedp)
15390      enum machine_mode mode;
15391      int unsignedp;
15392 {
15393   int i;
15394   int j;
15395   tree t;
15396
15397   if (mode == TYPE_MODE (integer_type_node))
15398     return unsignedp ? unsigned_type_node : integer_type_node;
15399
15400   if (mode == TYPE_MODE (signed_char_type_node))
15401     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15402
15403   if (mode == TYPE_MODE (short_integer_type_node))
15404     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15405
15406   if (mode == TYPE_MODE (long_integer_type_node))
15407     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15408
15409   if (mode == TYPE_MODE (long_long_integer_type_node))
15410     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15411
15412 #if HOST_BITS_PER_WIDE_INT >= 64
15413   if (mode == TYPE_MODE (intTI_type_node))
15414     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15415 #endif
15416
15417   if (mode == TYPE_MODE (float_type_node))
15418     return float_type_node;
15419
15420   if (mode == TYPE_MODE (double_type_node))
15421     return double_type_node;
15422
15423   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15424     return build_pointer_type (char_type_node);
15425
15426   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15427     return build_pointer_type (integer_type_node);
15428
15429   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15430     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15431       {
15432         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15433             && (mode == TYPE_MODE (t)))
15434           {
15435             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15436               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15437             else
15438               return t;
15439           }
15440       }
15441
15442   return 0;
15443 }
15444
15445 tree
15446 type_for_size (bits, unsignedp)
15447      unsigned bits;
15448      int unsignedp;
15449 {
15450   ffeinfoKindtype kt;
15451   tree type_node;
15452
15453   if (bits == TYPE_PRECISION (integer_type_node))
15454     return unsignedp ? unsigned_type_node : integer_type_node;
15455
15456   if (bits == TYPE_PRECISION (signed_char_type_node))
15457     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15458
15459   if (bits == TYPE_PRECISION (short_integer_type_node))
15460     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15461
15462   if (bits == TYPE_PRECISION (long_integer_type_node))
15463     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15464
15465   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15466     return (unsignedp ? long_long_unsigned_type_node
15467             : long_long_integer_type_node);
15468
15469   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15470     {
15471       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15472
15473       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15474         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15475           : type_node;
15476     }
15477
15478   return 0;
15479 }
15480
15481 tree
15482 unsigned_type (type)
15483      tree type;
15484 {
15485   tree type1 = TYPE_MAIN_VARIANT (type);
15486   ffeinfoKindtype kt;
15487   tree type2;
15488
15489   if (type1 == signed_char_type_node || type1 == char_type_node)
15490     return unsigned_char_type_node;
15491   if (type1 == integer_type_node)
15492     return unsigned_type_node;
15493   if (type1 == short_integer_type_node)
15494     return short_unsigned_type_node;
15495   if (type1 == long_integer_type_node)
15496     return long_unsigned_type_node;
15497   if (type1 == long_long_integer_type_node)
15498     return long_long_unsigned_type_node;
15499 #if 0   /* gcc/c-* files only */
15500   if (type1 == intDI_type_node)
15501     return unsigned_intDI_type_node;
15502   if (type1 == intSI_type_node)
15503     return unsigned_intSI_type_node;
15504   if (type1 == intHI_type_node)
15505     return unsigned_intHI_type_node;
15506   if (type1 == intQI_type_node)
15507     return unsigned_intQI_type_node;
15508 #endif
15509
15510   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15511   if (type2 != NULL_TREE)
15512     return type2;
15513
15514   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15515     {
15516       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15517
15518       if (type1 == type2)
15519         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15520     }
15521
15522   return type;
15523 }
15524
15525 void
15526 lang_mark_tree (t)
15527      union tree_node *t ATTRIBUTE_UNUSED;
15528 {
15529   if (TREE_CODE (t) == IDENTIFIER_NODE)
15530     {
15531       struct lang_identifier *i = (struct lang_identifier *) t;
15532       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15533       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15534       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15535     }
15536   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15537     ggc_mark (TYPE_LANG_SPECIFIC (t));
15538 }
15539
15540 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15541 \f
15542 #if FFECOM_GCC_INCLUDE
15543
15544 /* From gcc/cccp.c, the code to handle -I.  */
15545
15546 /* Skip leading "./" from a directory name.
15547    This may yield the empty string, which represents the current directory.  */
15548
15549 static const char *
15550 skip_redundant_dir_prefix (const char *dir)
15551 {
15552   while (dir[0] == '.' && dir[1] == '/')
15553     for (dir += 2; *dir == '/'; dir++)
15554       continue;
15555   if (dir[0] == '.' && !dir[1])
15556     dir++;
15557   return dir;
15558 }
15559
15560 /* The file_name_map structure holds a mapping of file names for a
15561    particular directory.  This mapping is read from the file named
15562    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15563    map filenames on a file system with severe filename restrictions,
15564    such as DOS.  The format of the file name map file is just a series
15565    of lines with two tokens on each line.  The first token is the name
15566    to map, and the second token is the actual name to use.  */
15567
15568 struct file_name_map
15569 {
15570   struct file_name_map *map_next;
15571   char *map_from;
15572   char *map_to;
15573 };
15574
15575 #define FILE_NAME_MAP_FILE "header.gcc"
15576
15577 /* Current maximum length of directory names in the search path
15578    for include files.  (Altered as we get more of them.)  */
15579
15580 static int max_include_len = 0;
15581
15582 struct file_name_list
15583   {
15584     struct file_name_list *next;
15585     char *fname;
15586     /* Mapping of file names for this directory.  */
15587     struct file_name_map *name_map;
15588     /* Non-zero if name_map is valid.  */
15589     int got_name_map;
15590   };
15591
15592 static struct file_name_list *include = NULL;   /* First dir to search */
15593 static struct file_name_list *last_include = NULL;      /* Last in chain */
15594
15595 /* I/O buffer structure.
15596    The `fname' field is nonzero for source files and #include files
15597    and for the dummy text used for -D and -U.
15598    It is zero for rescanning results of macro expansion
15599    and for expanding macro arguments.  */
15600 #define INPUT_STACK_MAX 400
15601 static struct file_buf {
15602   const char *fname;
15603   /* Filename specified with #line command.  */
15604   const char *nominal_fname;
15605   /* Record where in the search path this file was found.
15606      For #include_next.  */
15607   struct file_name_list *dir;
15608   ffewhereLine line;
15609   ffewhereColumn column;
15610 } instack[INPUT_STACK_MAX];
15611
15612 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15613 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15614
15615 /* Current nesting level of input sources.
15616    `instack[indepth]' is the level currently being read.  */
15617 static int indepth = -1;
15618
15619 typedef struct file_buf FILE_BUF;
15620
15621 typedef unsigned char U_CHAR;
15622
15623 /* table to tell if char can be part of a C identifier. */
15624 U_CHAR is_idchar[256];
15625 /* table to tell if char can be first char of a c identifier. */
15626 U_CHAR is_idstart[256];
15627 /* table to tell if c is horizontal space.  */
15628 U_CHAR is_hor_space[256];
15629 /* table to tell if c is horizontal or vertical space.  */
15630 static U_CHAR is_space[256];
15631
15632 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15633 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15634
15635 /* Nonzero means -I- has been seen,
15636    so don't look for #include "foo" the source-file directory.  */
15637 static int ignore_srcdir;
15638
15639 #ifndef INCLUDE_LEN_FUDGE
15640 #define INCLUDE_LEN_FUDGE 0
15641 #endif
15642
15643 static void append_include_chain (struct file_name_list *first,
15644                                   struct file_name_list *last);
15645 static FILE *open_include_file (char *filename,
15646                                 struct file_name_list *searchptr);
15647 static void print_containing_files (ffebadSeverity sev);
15648 static char *read_filename_string (int ch, FILE *f);
15649 static struct file_name_map *read_name_map (const char *dirname);
15650
15651 /* Append a chain of `struct file_name_list's
15652    to the end of the main include chain.
15653    FIRST is the beginning of the chain to append, and LAST is the end.  */
15654
15655 static void
15656 append_include_chain (first, last)
15657      struct file_name_list *first, *last;
15658 {
15659   struct file_name_list *dir;
15660
15661   if (!first || !last)
15662     return;
15663
15664   if (include == 0)
15665     include = first;
15666   else
15667     last_include->next = first;
15668
15669   for (dir = first; ; dir = dir->next) {
15670     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15671     if (len > max_include_len)
15672       max_include_len = len;
15673     if (dir == last)
15674       break;
15675   }
15676
15677   last->next = NULL;
15678   last_include = last;
15679 }
15680
15681 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15682    being tried from the include file search path.  This function maps
15683    filenames on file systems based on information read by
15684    read_name_map.  */
15685
15686 static FILE *
15687 open_include_file (filename, searchptr)
15688      char *filename;
15689      struct file_name_list *searchptr;
15690 {
15691   register struct file_name_map *map;
15692   register char *from;
15693   char *p, *dir;
15694
15695   if (searchptr && ! searchptr->got_name_map)
15696     {
15697       searchptr->name_map = read_name_map (searchptr->fname
15698                                            ? searchptr->fname : ".");
15699       searchptr->got_name_map = 1;
15700     }
15701
15702   /* First check the mapping for the directory we are using.  */
15703   if (searchptr && searchptr->name_map)
15704     {
15705       from = filename;
15706       if (searchptr->fname)
15707         from += strlen (searchptr->fname) + 1;
15708       for (map = searchptr->name_map; map; map = map->map_next)
15709         {
15710           if (! strcmp (map->map_from, from))
15711             {
15712               /* Found a match.  */
15713               return fopen (map->map_to, "r");
15714             }
15715         }
15716     }
15717
15718   /* Try to find a mapping file for the particular directory we are
15719      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15720      in /usr/include/header.gcc and look up types.h in
15721      /usr/include/sys/header.gcc.  */
15722   p = strrchr (filename, '/');
15723 #ifdef DIR_SEPARATOR
15724   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15725   else {
15726     char *tmp = strrchr (filename, DIR_SEPARATOR);
15727     if (tmp != NULL && tmp > p) p = tmp;
15728   }
15729 #endif
15730   if (! p)
15731     p = filename;
15732   if (searchptr
15733       && searchptr->fname
15734       && strlen (searchptr->fname) == (size_t) (p - filename)
15735       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15736     {
15737       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15738       return fopen (filename, "r");
15739     }
15740
15741   if (p == filename)
15742     {
15743       from = filename;
15744       map = read_name_map (".");
15745     }
15746   else
15747     {
15748       dir = (char *) xmalloc (p - filename + 1);
15749       memcpy (dir, filename, p - filename);
15750       dir[p - filename] = '\0';
15751       from = p + 1;
15752       map = read_name_map (dir);
15753       free (dir);
15754     }
15755   for (; map; map = map->map_next)
15756     if (! strcmp (map->map_from, from))
15757       return fopen (map->map_to, "r");
15758
15759   return fopen (filename, "r");
15760 }
15761
15762 /* Print the file names and line numbers of the #include
15763    commands which led to the current file.  */
15764
15765 static void
15766 print_containing_files (ffebadSeverity sev)
15767 {
15768   FILE_BUF *ip = NULL;
15769   int i;
15770   int first = 1;
15771   const char *str1;
15772   const char *str2;
15773
15774   /* If stack of files hasn't changed since we last printed
15775      this info, don't repeat it.  */
15776   if (last_error_tick == input_file_stack_tick)
15777     return;
15778
15779   for (i = indepth; i >= 0; i--)
15780     if (instack[i].fname != NULL) {
15781       ip = &instack[i];
15782       break;
15783     }
15784
15785   /* Give up if we don't find a source file.  */
15786   if (ip == NULL)
15787     return;
15788
15789   /* Find the other, outer source files.  */
15790   for (i--; i >= 0; i--)
15791     if (instack[i].fname != NULL)
15792       {
15793         ip = &instack[i];
15794         if (first)
15795           {
15796             first = 0;
15797             str1 = "In file included";
15798           }
15799         else
15800           {
15801             str1 = "...          ...";
15802           }
15803
15804         if (i == 1)
15805           str2 = ":";
15806         else
15807           str2 = "";
15808
15809         ffebad_start_msg ("%A from %B at %0%C", sev);
15810         ffebad_here (0, ip->line, ip->column);
15811         ffebad_string (str1);
15812         ffebad_string (ip->nominal_fname);
15813         ffebad_string (str2);
15814         ffebad_finish ();
15815       }
15816
15817   /* Record we have printed the status as of this time.  */
15818   last_error_tick = input_file_stack_tick;
15819 }
15820
15821 /* Read a space delimited string of unlimited length from a stdio
15822    file.  */
15823
15824 static char *
15825 read_filename_string (ch, f)
15826      int ch;
15827      FILE *f;
15828 {
15829   char *alloc, *set;
15830   int len;
15831
15832   len = 20;
15833   set = alloc = xmalloc (len + 1);
15834   if (! is_space[ch])
15835     {
15836       *set++ = ch;
15837       while ((ch = getc (f)) != EOF && ! is_space[ch])
15838         {
15839           if (set - alloc == len)
15840             {
15841               len *= 2;
15842               alloc = xrealloc (alloc, len + 1);
15843               set = alloc + len / 2;
15844             }
15845           *set++ = ch;
15846         }
15847     }
15848   *set = '\0';
15849   ungetc (ch, f);
15850   return alloc;
15851 }
15852
15853 /* Read the file name map file for DIRNAME.  */
15854
15855 static struct file_name_map *
15856 read_name_map (dirname)
15857      const char *dirname;
15858 {
15859   /* This structure holds a linked list of file name maps, one per
15860      directory.  */
15861   struct file_name_map_list
15862     {
15863       struct file_name_map_list *map_list_next;
15864       char *map_list_name;
15865       struct file_name_map *map_list_map;
15866     };
15867   static struct file_name_map_list *map_list;
15868   register struct file_name_map_list *map_list_ptr;
15869   char *name;
15870   FILE *f;
15871   size_t dirlen;
15872   int separator_needed;
15873
15874   dirname = skip_redundant_dir_prefix (dirname);
15875
15876   for (map_list_ptr = map_list; map_list_ptr;
15877        map_list_ptr = map_list_ptr->map_list_next)
15878     if (! strcmp (map_list_ptr->map_list_name, dirname))
15879       return map_list_ptr->map_list_map;
15880
15881   map_list_ptr = ((struct file_name_map_list *)
15882                   xmalloc (sizeof (struct file_name_map_list)));
15883   map_list_ptr->map_list_name = xstrdup (dirname);
15884   map_list_ptr->map_list_map = NULL;
15885
15886   dirlen = strlen (dirname);
15887   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15888   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15889   strcpy (name, dirname);
15890   name[dirlen] = '/';
15891   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15892   f = fopen (name, "r");
15893   free (name);
15894   if (!f)
15895     map_list_ptr->map_list_map = NULL;
15896   else
15897     {
15898       int ch;
15899
15900       while ((ch = getc (f)) != EOF)
15901         {
15902           char *from, *to;
15903           struct file_name_map *ptr;
15904
15905           if (is_space[ch])
15906             continue;
15907           from = read_filename_string (ch, f);
15908           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15909             ;
15910           to = read_filename_string (ch, f);
15911
15912           ptr = ((struct file_name_map *)
15913                  xmalloc (sizeof (struct file_name_map)));
15914           ptr->map_from = from;
15915
15916           /* Make the real filename absolute.  */
15917           if (*to == '/')
15918             ptr->map_to = to;
15919           else
15920             {
15921               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15922               strcpy (ptr->map_to, dirname);
15923               ptr->map_to[dirlen] = '/';
15924               strcpy (ptr->map_to + dirlen + separator_needed, to);
15925               free (to);
15926             }
15927
15928           ptr->map_next = map_list_ptr->map_list_map;
15929           map_list_ptr->map_list_map = ptr;
15930
15931           while ((ch = getc (f)) != '\n')
15932             if (ch == EOF)
15933               break;
15934         }
15935       fclose (f);
15936     }
15937
15938   map_list_ptr->map_list_next = map_list;
15939   map_list = map_list_ptr;
15940
15941   return map_list_ptr->map_list_map;
15942 }
15943
15944 static void
15945 ffecom_file_ (const char *name)
15946 {
15947   FILE_BUF *fp;
15948
15949   /* Do partial setup of input buffer for the sake of generating
15950      early #line directives (when -g is in effect).  */
15951
15952   fp = &instack[++indepth];
15953   memset ((char *) fp, 0, sizeof (FILE_BUF));
15954   if (name == NULL)
15955     name = "";
15956   fp->nominal_fname = fp->fname = name;
15957 }
15958
15959 /* Initialize syntactic classifications of characters.  */
15960
15961 static void
15962 ffecom_initialize_char_syntax_ ()
15963 {
15964   register int i;
15965
15966   /*
15967    * Set up is_idchar and is_idstart tables.  These should be
15968    * faster than saying (is_alpha (c) || c == '_'), etc.
15969    * Set up these things before calling any routines tthat
15970    * refer to them.
15971    */
15972   for (i = 'a'; i <= 'z'; i++) {
15973     is_idchar[i - 'a' + 'A'] = 1;
15974     is_idchar[i] = 1;
15975     is_idstart[i - 'a' + 'A'] = 1;
15976     is_idstart[i] = 1;
15977   }
15978   for (i = '0'; i <= '9'; i++)
15979     is_idchar[i] = 1;
15980   is_idchar['_'] = 1;
15981   is_idstart['_'] = 1;
15982
15983   /* horizontal space table */
15984   is_hor_space[' '] = 1;
15985   is_hor_space['\t'] = 1;
15986   is_hor_space['\v'] = 1;
15987   is_hor_space['\f'] = 1;
15988   is_hor_space['\r'] = 1;
15989
15990   is_space[' '] = 1;
15991   is_space['\t'] = 1;
15992   is_space['\v'] = 1;
15993   is_space['\f'] = 1;
15994   is_space['\n'] = 1;
15995   is_space['\r'] = 1;
15996 }
15997
15998 static void
15999 ffecom_close_include_ (FILE *f)
16000 {
16001   fclose (f);
16002
16003   indepth--;
16004   input_file_stack_tick++;
16005
16006   ffewhere_line_kill (instack[indepth].line);
16007   ffewhere_column_kill (instack[indepth].column);
16008 }
16009
16010 static int
16011 ffecom_decode_include_option_ (char *spec)
16012 {
16013   struct file_name_list *dirtmp;
16014
16015   if (! ignore_srcdir && !strcmp (spec, "-"))
16016     ignore_srcdir = 1;
16017   else
16018     {
16019       dirtmp = (struct file_name_list *)
16020         xmalloc (sizeof (struct file_name_list));
16021       dirtmp->next = 0;         /* New one goes on the end */
16022       dirtmp->fname = spec;
16023       dirtmp->got_name_map = 0;
16024       if (spec[0] == 0)
16025         error ("Directory name must immediately follow -I");
16026       else
16027         append_include_chain (dirtmp, dirtmp);
16028     }
16029   return 1;
16030 }
16031
16032 /* Open INCLUDEd file.  */
16033
16034 static FILE *
16035 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16036 {
16037   char *fbeg = name;
16038   size_t flen = strlen (fbeg);
16039   struct file_name_list *search_start = include; /* Chain of dirs to search */
16040   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16041   struct file_name_list *searchptr = 0;
16042   char *fname;          /* Dynamically allocated fname buffer */
16043   FILE *f;
16044   FILE_BUF *fp;
16045
16046   if (flen == 0)
16047     return NULL;
16048
16049   dsp[0].fname = NULL;
16050
16051   /* If -I- was specified, don't search current dir, only spec'd ones. */
16052   if (!ignore_srcdir)
16053     {
16054       for (fp = &instack[indepth]; fp >= instack; fp--)
16055         {
16056           int n;
16057           char *ep;
16058           const char *nam;
16059
16060           if ((nam = fp->nominal_fname) != NULL)
16061             {
16062               /* Found a named file.  Figure out dir of the file,
16063                  and put it in front of the search list.  */
16064               dsp[0].next = search_start;
16065               search_start = dsp;
16066 #ifndef VMS
16067               ep = strrchr (nam, '/');
16068 #ifdef DIR_SEPARATOR
16069             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16070             else {
16071               char *tmp = strrchr (nam, DIR_SEPARATOR);
16072               if (tmp != NULL && tmp > ep) ep = tmp;
16073             }
16074 #endif
16075 #else                           /* VMS */
16076               ep = strrchr (nam, ']');
16077               if (ep == NULL) ep = strrchr (nam, '>');
16078               if (ep == NULL) ep = strrchr (nam, ':');
16079               if (ep != NULL) ep++;
16080 #endif                          /* VMS */
16081               if (ep != NULL)
16082                 {
16083                   n = ep - nam;
16084                   dsp[0].fname = (char *) xmalloc (n + 1);
16085                   strncpy (dsp[0].fname, nam, n);
16086                   dsp[0].fname[n] = '\0';
16087                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16088                     max_include_len = n + INCLUDE_LEN_FUDGE;
16089                 }
16090               else
16091                 dsp[0].fname = NULL; /* Current directory */
16092               dsp[0].got_name_map = 0;
16093               break;
16094             }
16095         }
16096     }
16097
16098   /* Allocate this permanently, because it gets stored in the definitions
16099      of macros.  */
16100   fname = xmalloc (max_include_len + flen + 4);
16101   /* + 2 above for slash and terminating null.  */
16102   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16103      for g77 yet).  */
16104
16105   /* If specified file name is absolute, just open it.  */
16106
16107   if (*fbeg == '/'
16108 #ifdef DIR_SEPARATOR
16109       || *fbeg == DIR_SEPARATOR
16110 #endif
16111       )
16112     {
16113       strncpy (fname, (char *) fbeg, flen);
16114       fname[flen] = 0;
16115       f = open_include_file (fname, NULL);
16116     }
16117   else
16118     {
16119       f = NULL;
16120
16121       /* Search directory path, trying to open the file.
16122          Copy each filename tried into FNAME.  */
16123
16124       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16125         {
16126           if (searchptr->fname)
16127             {
16128               /* The empty string in a search path is ignored.
16129                  This makes it possible to turn off entirely
16130                  a standard piece of the list.  */
16131               if (searchptr->fname[0] == 0)
16132                 continue;
16133               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16134               if (fname[0] && fname[strlen (fname) - 1] != '/')
16135                 strcat (fname, "/");
16136               fname[strlen (fname) + flen] = 0;
16137             }
16138           else
16139             fname[0] = 0;
16140
16141           strncat (fname, fbeg, flen);
16142 #ifdef VMS
16143           /* Change this 1/2 Unix 1/2 VMS file specification into a
16144              full VMS file specification */
16145           if (searchptr->fname && (searchptr->fname[0] != 0))
16146             {
16147               /* Fix up the filename */
16148               hack_vms_include_specification (fname);
16149             }
16150           else
16151             {
16152               /* This is a normal VMS filespec, so use it unchanged.  */
16153               strncpy (fname, (char *) fbeg, flen);
16154               fname[flen] = 0;
16155 #if 0   /* Not for g77.  */
16156               /* if it's '#include filename', add the missing .h */
16157               if (strchr (fname, '.') == NULL)
16158                 strcat (fname, ".h");
16159 #endif
16160             }
16161 #endif /* VMS */
16162           f = open_include_file (fname, searchptr);
16163 #ifdef EACCES
16164           if (f == NULL && errno == EACCES)
16165             {
16166               print_containing_files (FFEBAD_severityWARNING);
16167               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16168                                 FFEBAD_severityWARNING);
16169               ffebad_string (fname);
16170               ffebad_here (0, l, c);
16171               ffebad_finish ();
16172             }
16173 #endif
16174           if (f != NULL)
16175             break;
16176         }
16177     }
16178
16179   if (f == NULL)
16180     {
16181       /* A file that was not found.  */
16182
16183       strncpy (fname, (char *) fbeg, flen);
16184       fname[flen] = 0;
16185       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16186       ffebad_start (FFEBAD_OPEN_INCLUDE);
16187       ffebad_here (0, l, c);
16188       ffebad_string (fname);
16189       ffebad_finish ();
16190     }
16191
16192   if (dsp[0].fname != NULL)
16193     free (dsp[0].fname);
16194
16195   if (f == NULL)
16196     return NULL;
16197
16198   if (indepth >= (INPUT_STACK_MAX - 1))
16199     {
16200       print_containing_files (FFEBAD_severityFATAL);
16201       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16202                         FFEBAD_severityFATAL);
16203       ffebad_string (fname);
16204       ffebad_here (0, l, c);
16205       ffebad_finish ();
16206       return NULL;
16207     }
16208
16209   instack[indepth].line = ffewhere_line_use (l);
16210   instack[indepth].column = ffewhere_column_use (c);
16211
16212   fp = &instack[indepth + 1];
16213   memset ((char *) fp, 0, sizeof (FILE_BUF));
16214   fp->nominal_fname = fp->fname = fname;
16215   fp->dir = searchptr;
16216
16217   indepth++;
16218   input_file_stack_tick++;
16219
16220   return f;
16221 }
16222 #endif  /* FFECOM_GCC_INCLUDE */
16223
16224 /**INDENT* (Do not reformat this comment even with -fca option.)
16225    Data-gathering files: Given the source file listed below, compiled with
16226    f2c I obtained the output file listed after that, and from the output
16227    file I derived the above code.
16228
16229 -------- (begin input file to f2c)
16230         implicit none
16231         character*10 A1,A2
16232         complex C1,C2
16233         integer I1,I2
16234         real R1,R2
16235         double precision D1,D2
16236 C
16237         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16238 c /
16239         call fooI(I1/I2)
16240         call fooR(R1/I1)
16241         call fooD(D1/I1)
16242         call fooC(C1/I1)
16243         call fooR(R1/R2)
16244         call fooD(R1/D1)
16245         call fooD(D1/D2)
16246         call fooD(D1/R1)
16247         call fooC(C1/C2)
16248         call fooC(C1/R1)
16249         call fooZ(C1/D1)
16250 c **
16251         call fooI(I1**I2)
16252         call fooR(R1**I1)
16253         call fooD(D1**I1)
16254         call fooC(C1**I1)
16255         call fooR(R1**R2)
16256         call fooD(R1**D1)
16257         call fooD(D1**D2)
16258         call fooD(D1**R1)
16259         call fooC(C1**C2)
16260         call fooC(C1**R1)
16261         call fooZ(C1**D1)
16262 c FFEINTRIN_impABS
16263         call fooR(ABS(R1))
16264 c FFEINTRIN_impACOS
16265         call fooR(ACOS(R1))
16266 c FFEINTRIN_impAIMAG
16267         call fooR(AIMAG(C1))
16268 c FFEINTRIN_impAINT
16269         call fooR(AINT(R1))
16270 c FFEINTRIN_impALOG
16271         call fooR(ALOG(R1))
16272 c FFEINTRIN_impALOG10
16273         call fooR(ALOG10(R1))
16274 c FFEINTRIN_impAMAX0
16275         call fooR(AMAX0(I1,I2))
16276 c FFEINTRIN_impAMAX1
16277         call fooR(AMAX1(R1,R2))
16278 c FFEINTRIN_impAMIN0
16279         call fooR(AMIN0(I1,I2))
16280 c FFEINTRIN_impAMIN1
16281         call fooR(AMIN1(R1,R2))
16282 c FFEINTRIN_impAMOD
16283         call fooR(AMOD(R1,R2))
16284 c FFEINTRIN_impANINT
16285         call fooR(ANINT(R1))
16286 c FFEINTRIN_impASIN
16287         call fooR(ASIN(R1))
16288 c FFEINTRIN_impATAN
16289         call fooR(ATAN(R1))
16290 c FFEINTRIN_impATAN2
16291         call fooR(ATAN2(R1,R2))
16292 c FFEINTRIN_impCABS
16293         call fooR(CABS(C1))
16294 c FFEINTRIN_impCCOS
16295         call fooC(CCOS(C1))
16296 c FFEINTRIN_impCEXP
16297         call fooC(CEXP(C1))
16298 c FFEINTRIN_impCHAR
16299         call fooA(CHAR(I1))
16300 c FFEINTRIN_impCLOG
16301         call fooC(CLOG(C1))
16302 c FFEINTRIN_impCONJG
16303         call fooC(CONJG(C1))
16304 c FFEINTRIN_impCOS
16305         call fooR(COS(R1))
16306 c FFEINTRIN_impCOSH
16307         call fooR(COSH(R1))
16308 c FFEINTRIN_impCSIN
16309         call fooC(CSIN(C1))
16310 c FFEINTRIN_impCSQRT
16311         call fooC(CSQRT(C1))
16312 c FFEINTRIN_impDABS
16313         call fooD(DABS(D1))
16314 c FFEINTRIN_impDACOS
16315         call fooD(DACOS(D1))
16316 c FFEINTRIN_impDASIN
16317         call fooD(DASIN(D1))
16318 c FFEINTRIN_impDATAN
16319         call fooD(DATAN(D1))
16320 c FFEINTRIN_impDATAN2
16321         call fooD(DATAN2(D1,D2))
16322 c FFEINTRIN_impDCOS
16323         call fooD(DCOS(D1))
16324 c FFEINTRIN_impDCOSH
16325         call fooD(DCOSH(D1))
16326 c FFEINTRIN_impDDIM
16327         call fooD(DDIM(D1,D2))
16328 c FFEINTRIN_impDEXP
16329         call fooD(DEXP(D1))
16330 c FFEINTRIN_impDIM
16331         call fooR(DIM(R1,R2))
16332 c FFEINTRIN_impDINT
16333         call fooD(DINT(D1))
16334 c FFEINTRIN_impDLOG
16335         call fooD(DLOG(D1))
16336 c FFEINTRIN_impDLOG10
16337         call fooD(DLOG10(D1))
16338 c FFEINTRIN_impDMAX1
16339         call fooD(DMAX1(D1,D2))
16340 c FFEINTRIN_impDMIN1
16341         call fooD(DMIN1(D1,D2))
16342 c FFEINTRIN_impDMOD
16343         call fooD(DMOD(D1,D2))
16344 c FFEINTRIN_impDNINT
16345         call fooD(DNINT(D1))
16346 c FFEINTRIN_impDPROD
16347         call fooD(DPROD(R1,R2))
16348 c FFEINTRIN_impDSIGN
16349         call fooD(DSIGN(D1,D2))
16350 c FFEINTRIN_impDSIN
16351         call fooD(DSIN(D1))
16352 c FFEINTRIN_impDSINH
16353         call fooD(DSINH(D1))
16354 c FFEINTRIN_impDSQRT
16355         call fooD(DSQRT(D1))
16356 c FFEINTRIN_impDTAN
16357         call fooD(DTAN(D1))
16358 c FFEINTRIN_impDTANH
16359         call fooD(DTANH(D1))
16360 c FFEINTRIN_impEXP
16361         call fooR(EXP(R1))
16362 c FFEINTRIN_impIABS
16363         call fooI(IABS(I1))
16364 c FFEINTRIN_impICHAR
16365         call fooI(ICHAR(A1))
16366 c FFEINTRIN_impIDIM
16367         call fooI(IDIM(I1,I2))
16368 c FFEINTRIN_impIDNINT
16369         call fooI(IDNINT(D1))
16370 c FFEINTRIN_impINDEX
16371         call fooI(INDEX(A1,A2))
16372 c FFEINTRIN_impISIGN
16373         call fooI(ISIGN(I1,I2))
16374 c FFEINTRIN_impLEN
16375         call fooI(LEN(A1))
16376 c FFEINTRIN_impLGE
16377         call fooL(LGE(A1,A2))
16378 c FFEINTRIN_impLGT
16379         call fooL(LGT(A1,A2))
16380 c FFEINTRIN_impLLE
16381         call fooL(LLE(A1,A2))
16382 c FFEINTRIN_impLLT
16383         call fooL(LLT(A1,A2))
16384 c FFEINTRIN_impMAX0
16385         call fooI(MAX0(I1,I2))
16386 c FFEINTRIN_impMAX1
16387         call fooI(MAX1(R1,R2))
16388 c FFEINTRIN_impMIN0
16389         call fooI(MIN0(I1,I2))
16390 c FFEINTRIN_impMIN1
16391         call fooI(MIN1(R1,R2))
16392 c FFEINTRIN_impMOD
16393         call fooI(MOD(I1,I2))
16394 c FFEINTRIN_impNINT
16395         call fooI(NINT(R1))
16396 c FFEINTRIN_impSIGN
16397         call fooR(SIGN(R1,R2))
16398 c FFEINTRIN_impSIN
16399         call fooR(SIN(R1))
16400 c FFEINTRIN_impSINH
16401         call fooR(SINH(R1))
16402 c FFEINTRIN_impSQRT
16403         call fooR(SQRT(R1))
16404 c FFEINTRIN_impTAN
16405         call fooR(TAN(R1))
16406 c FFEINTRIN_impTANH
16407         call fooR(TANH(R1))
16408 c FFEINTRIN_imp_CMPLX_C
16409         call fooC(cmplx(C1,C2))
16410 c FFEINTRIN_imp_CMPLX_D
16411         call fooZ(cmplx(D1,D2))
16412 c FFEINTRIN_imp_CMPLX_I
16413         call fooC(cmplx(I1,I2))
16414 c FFEINTRIN_imp_CMPLX_R
16415         call fooC(cmplx(R1,R2))
16416 c FFEINTRIN_imp_DBLE_C
16417         call fooD(dble(C1))
16418 c FFEINTRIN_imp_DBLE_D
16419         call fooD(dble(D1))
16420 c FFEINTRIN_imp_DBLE_I
16421         call fooD(dble(I1))
16422 c FFEINTRIN_imp_DBLE_R
16423         call fooD(dble(R1))
16424 c FFEINTRIN_imp_INT_C
16425         call fooI(int(C1))
16426 c FFEINTRIN_imp_INT_D
16427         call fooI(int(D1))
16428 c FFEINTRIN_imp_INT_I
16429         call fooI(int(I1))
16430 c FFEINTRIN_imp_INT_R
16431         call fooI(int(R1))
16432 c FFEINTRIN_imp_REAL_C
16433         call fooR(real(C1))
16434 c FFEINTRIN_imp_REAL_D
16435         call fooR(real(D1))
16436 c FFEINTRIN_imp_REAL_I
16437         call fooR(real(I1))
16438 c FFEINTRIN_imp_REAL_R
16439         call fooR(real(R1))
16440 c
16441 c FFEINTRIN_imp_INT_D:
16442 c
16443 c FFEINTRIN_specIDINT
16444         call fooI(IDINT(D1))
16445 c
16446 c FFEINTRIN_imp_INT_R:
16447 c
16448 c FFEINTRIN_specIFIX
16449         call fooI(IFIX(R1))
16450 c FFEINTRIN_specINT
16451         call fooI(INT(R1))
16452 c
16453 c FFEINTRIN_imp_REAL_D:
16454 c
16455 c FFEINTRIN_specSNGL
16456         call fooR(SNGL(D1))
16457 c
16458 c FFEINTRIN_imp_REAL_I:
16459 c
16460 c FFEINTRIN_specFLOAT
16461         call fooR(FLOAT(I1))
16462 c FFEINTRIN_specREAL
16463         call fooR(REAL(I1))
16464 c
16465         end
16466 -------- (end input file to f2c)
16467
16468 -------- (begin output from providing above input file as input to:
16469 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16470 --------     -e "s:^#.*$::g"')
16471
16472 //  -- translated by f2c (version 19950223).
16473    You must link the resulting object file with the libraries:
16474         -lf2c -lm   (in that order)
16475 //
16476
16477
16478 // f2c.h  --  Standard Fortran to C header file //
16479
16480 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16481
16482         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16483
16484
16485
16486
16487 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16488 // we assume short, float are OK //
16489 typedef long int // long int // integer;
16490 typedef char *address;
16491 typedef short int shortint;
16492 typedef float real;
16493 typedef double doublereal;
16494 typedef struct { real r, i; } complex;
16495 typedef struct { doublereal r, i; } doublecomplex;
16496 typedef long int // long int // logical;
16497 typedef short int shortlogical;
16498 typedef char logical1;
16499 typedef char integer1;
16500 // typedef long long longint; // // system-dependent //
16501
16502
16503
16504
16505 // Extern is for use with -E //
16506
16507
16508
16509
16510 // I/O stuff //
16511
16512
16513
16514
16515
16516
16517
16518
16519 typedef long int // int or long int // flag;
16520 typedef long int // int or long int // ftnlen;
16521 typedef long int // int or long int // ftnint;
16522
16523
16524 //external read, write//
16525 typedef struct
16526 {       flag cierr;
16527         ftnint ciunit;
16528         flag ciend;
16529         char *cifmt;
16530         ftnint cirec;
16531 } cilist;
16532
16533 //internal read, write//
16534 typedef struct
16535 {       flag icierr;
16536         char *iciunit;
16537         flag iciend;
16538         char *icifmt;
16539         ftnint icirlen;
16540         ftnint icirnum;
16541 } icilist;
16542
16543 //open//
16544 typedef struct
16545 {       flag oerr;
16546         ftnint ounit;
16547         char *ofnm;
16548         ftnlen ofnmlen;
16549         char *osta;
16550         char *oacc;
16551         char *ofm;
16552         ftnint orl;
16553         char *oblnk;
16554 } olist;
16555
16556 //close//
16557 typedef struct
16558 {       flag cerr;
16559         ftnint cunit;
16560         char *csta;
16561 } cllist;
16562
16563 //rewind, backspace, endfile//
16564 typedef struct
16565 {       flag aerr;
16566         ftnint aunit;
16567 } alist;
16568
16569 // inquire //
16570 typedef struct
16571 {       flag inerr;
16572         ftnint inunit;
16573         char *infile;
16574         ftnlen infilen;
16575         ftnint  *inex;  //parameters in standard's order//
16576         ftnint  *inopen;
16577         ftnint  *innum;
16578         ftnint  *innamed;
16579         char    *inname;
16580         ftnlen  innamlen;
16581         char    *inacc;
16582         ftnlen  inacclen;
16583         char    *inseq;
16584         ftnlen  inseqlen;
16585         char    *indir;
16586         ftnlen  indirlen;
16587         char    *infmt;
16588         ftnlen  infmtlen;
16589         char    *inform;
16590         ftnint  informlen;
16591         char    *inunf;
16592         ftnlen  inunflen;
16593         ftnint  *inrecl;
16594         ftnint  *innrec;
16595         char    *inblank;
16596         ftnlen  inblanklen;
16597 } inlist;
16598
16599
16600
16601 union Multitype {       // for multiple entry points //
16602         integer1 g;
16603         shortint h;
16604         integer i;
16605         // longint j; //
16606         real r;
16607         doublereal d;
16608         complex c;
16609         doublecomplex z;
16610         };
16611
16612 typedef union Multitype Multitype;
16613
16614 typedef long Long;      // No longer used; formerly in Namelist //
16615
16616 struct Vardesc {        // for Namelist //
16617         char *name;
16618         char *addr;
16619         ftnlen *dims;
16620         int  type;
16621         };
16622 typedef struct Vardesc Vardesc;
16623
16624 struct Namelist {
16625         char *name;
16626         Vardesc **vars;
16627         int nvars;
16628         };
16629 typedef struct Namelist Namelist;
16630
16631
16632
16633
16634
16635
16636
16637
16638 // procedure parameter types for -A and -C++ //
16639
16640
16641
16642
16643 typedef int // Unknown procedure type // (*U_fp)();
16644 typedef shortint (*J_fp)();
16645 typedef integer (*I_fp)();
16646 typedef real (*R_fp)();
16647 typedef doublereal (*D_fp)(), (*E_fp)();
16648 typedef // Complex // void  (*C_fp)();
16649 typedef // Double Complex // void  (*Z_fp)();
16650 typedef logical (*L_fp)();
16651 typedef shortlogical (*K_fp)();
16652 typedef // Character // void  (*H_fp)();
16653 typedef // Subroutine // int (*S_fp)();
16654
16655 // E_fp is for real functions when -R is not specified //
16656 typedef void  C_f;      // complex function //
16657 typedef void  H_f;      // character function //
16658 typedef void  Z_f;      // double complex function //
16659 typedef doublereal E_f; // real function with -R not specified //
16660
16661 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16662
16663
16664 // (No such symbols should be defined in a strict ANSI C compiler.
16665    We can avoid trouble with f2c-translated code by using
16666    gcc -ansi [-traditional].) //
16667
16668
16669
16670
16671
16672
16673
16674
16675
16676
16677
16678
16679
16680
16681
16682
16683
16684
16685
16686
16687
16688
16689
16690 // Main program // MAIN__()
16691 {
16692     // System generated locals //
16693     integer i__1;
16694     real r__1, r__2;
16695     doublereal d__1, d__2;
16696     complex q__1;
16697     doublecomplex z__1, z__2, z__3;
16698     logical L__1;
16699     char ch__1[1];
16700
16701     // Builtin functions //
16702     void c_div();
16703     integer pow_ii();
16704     double pow_ri(), pow_di();
16705     void pow_ci();
16706     double pow_dd();
16707     void pow_zz();
16708     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16709             asin(), atan(), atan2(), c_abs();
16710     void c_cos(), c_exp(), c_log(), r_cnjg();
16711     double cos(), cosh();
16712     void c_sin(), c_sqrt();
16713     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16714             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16715     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16716     logical l_ge(), l_gt(), l_le(), l_lt();
16717     integer i_nint();
16718     double r_sign();
16719
16720     // Local variables //
16721     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16722             fool_(), fooz_(), getem_();
16723     static char a1[10], a2[10];
16724     static complex c1, c2;
16725     static doublereal d1, d2;
16726     static integer i1, i2;
16727     static real r1, r2;
16728
16729
16730     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16731 // / //
16732     i__1 = i1 / i2;
16733     fooi_(&i__1);
16734     r__1 = r1 / i1;
16735     foor_(&r__1);
16736     d__1 = d1 / i1;
16737     food_(&d__1);
16738     d__1 = (doublereal) i1;
16739     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16740     fooc_(&q__1);
16741     r__1 = r1 / r2;
16742     foor_(&r__1);
16743     d__1 = r1 / d1;
16744     food_(&d__1);
16745     d__1 = d1 / d2;
16746     food_(&d__1);
16747     d__1 = d1 / r1;
16748     food_(&d__1);
16749     c_div(&q__1, &c1, &c2);
16750     fooc_(&q__1);
16751     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16752     fooc_(&q__1);
16753     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16754     fooz_(&z__1);
16755 // ** //
16756     i__1 = pow_ii(&i1, &i2);
16757     fooi_(&i__1);
16758     r__1 = pow_ri(&r1, &i1);
16759     foor_(&r__1);
16760     d__1 = pow_di(&d1, &i1);
16761     food_(&d__1);
16762     pow_ci(&q__1, &c1, &i1);
16763     fooc_(&q__1);
16764     d__1 = (doublereal) r1;
16765     d__2 = (doublereal) r2;
16766     r__1 = pow_dd(&d__1, &d__2);
16767     foor_(&r__1);
16768     d__2 = (doublereal) r1;
16769     d__1 = pow_dd(&d__2, &d1);
16770     food_(&d__1);
16771     d__1 = pow_dd(&d1, &d2);
16772     food_(&d__1);
16773     d__2 = (doublereal) r1;
16774     d__1 = pow_dd(&d1, &d__2);
16775     food_(&d__1);
16776     z__2.r = c1.r, z__2.i = c1.i;
16777     z__3.r = c2.r, z__3.i = c2.i;
16778     pow_zz(&z__1, &z__2, &z__3);
16779     q__1.r = z__1.r, q__1.i = z__1.i;
16780     fooc_(&q__1);
16781     z__2.r = c1.r, z__2.i = c1.i;
16782     z__3.r = r1, z__3.i = 0.;
16783     pow_zz(&z__1, &z__2, &z__3);
16784     q__1.r = z__1.r, q__1.i = z__1.i;
16785     fooc_(&q__1);
16786     z__2.r = c1.r, z__2.i = c1.i;
16787     z__3.r = d1, z__3.i = 0.;
16788     pow_zz(&z__1, &z__2, &z__3);
16789     fooz_(&z__1);
16790 // FFEINTRIN_impABS //
16791     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16792     foor_(&r__1);
16793 // FFEINTRIN_impACOS //
16794     r__1 = acos(r1);
16795     foor_(&r__1);
16796 // FFEINTRIN_impAIMAG //
16797     r__1 = r_imag(&c1);
16798     foor_(&r__1);
16799 // FFEINTRIN_impAINT //
16800     r__1 = r_int(&r1);
16801     foor_(&r__1);
16802 // FFEINTRIN_impALOG //
16803     r__1 = log(r1);
16804     foor_(&r__1);
16805 // FFEINTRIN_impALOG10 //
16806     r__1 = r_lg10(&r1);
16807     foor_(&r__1);
16808 // FFEINTRIN_impAMAX0 //
16809     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16810     foor_(&r__1);
16811 // FFEINTRIN_impAMAX1 //
16812     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16813     foor_(&r__1);
16814 // FFEINTRIN_impAMIN0 //
16815     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16816     foor_(&r__1);
16817 // FFEINTRIN_impAMIN1 //
16818     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16819     foor_(&r__1);
16820 // FFEINTRIN_impAMOD //
16821     r__1 = r_mod(&r1, &r2);
16822     foor_(&r__1);
16823 // FFEINTRIN_impANINT //
16824     r__1 = r_nint(&r1);
16825     foor_(&r__1);
16826 // FFEINTRIN_impASIN //
16827     r__1 = asin(r1);
16828     foor_(&r__1);
16829 // FFEINTRIN_impATAN //
16830     r__1 = atan(r1);
16831     foor_(&r__1);
16832 // FFEINTRIN_impATAN2 //
16833     r__1 = atan2(r1, r2);
16834     foor_(&r__1);
16835 // FFEINTRIN_impCABS //
16836     r__1 = c_abs(&c1);
16837     foor_(&r__1);
16838 // FFEINTRIN_impCCOS //
16839     c_cos(&q__1, &c1);
16840     fooc_(&q__1);
16841 // FFEINTRIN_impCEXP //
16842     c_exp(&q__1, &c1);
16843     fooc_(&q__1);
16844 // FFEINTRIN_impCHAR //
16845     *(unsigned char *)&ch__1[0] = i1;
16846     fooa_(ch__1, 1L);
16847 // FFEINTRIN_impCLOG //
16848     c_log(&q__1, &c1);
16849     fooc_(&q__1);
16850 // FFEINTRIN_impCONJG //
16851     r_cnjg(&q__1, &c1);
16852     fooc_(&q__1);
16853 // FFEINTRIN_impCOS //
16854     r__1 = cos(r1);
16855     foor_(&r__1);
16856 // FFEINTRIN_impCOSH //
16857     r__1 = cosh(r1);
16858     foor_(&r__1);
16859 // FFEINTRIN_impCSIN //
16860     c_sin(&q__1, &c1);
16861     fooc_(&q__1);
16862 // FFEINTRIN_impCSQRT //
16863     c_sqrt(&q__1, &c1);
16864     fooc_(&q__1);
16865 // FFEINTRIN_impDABS //
16866     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16867     food_(&d__1);
16868 // FFEINTRIN_impDACOS //
16869     d__1 = acos(d1);
16870     food_(&d__1);
16871 // FFEINTRIN_impDASIN //
16872     d__1 = asin(d1);
16873     food_(&d__1);
16874 // FFEINTRIN_impDATAN //
16875     d__1 = atan(d1);
16876     food_(&d__1);
16877 // FFEINTRIN_impDATAN2 //
16878     d__1 = atan2(d1, d2);
16879     food_(&d__1);
16880 // FFEINTRIN_impDCOS //
16881     d__1 = cos(d1);
16882     food_(&d__1);
16883 // FFEINTRIN_impDCOSH //
16884     d__1 = cosh(d1);
16885     food_(&d__1);
16886 // FFEINTRIN_impDDIM //
16887     d__1 = d_dim(&d1, &d2);
16888     food_(&d__1);
16889 // FFEINTRIN_impDEXP //
16890     d__1 = exp(d1);
16891     food_(&d__1);
16892 // FFEINTRIN_impDIM //
16893     r__1 = r_dim(&r1, &r2);
16894     foor_(&r__1);
16895 // FFEINTRIN_impDINT //
16896     d__1 = d_int(&d1);
16897     food_(&d__1);
16898 // FFEINTRIN_impDLOG //
16899     d__1 = log(d1);
16900     food_(&d__1);
16901 // FFEINTRIN_impDLOG10 //
16902     d__1 = d_lg10(&d1);
16903     food_(&d__1);
16904 // FFEINTRIN_impDMAX1 //
16905     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16906     food_(&d__1);
16907 // FFEINTRIN_impDMIN1 //
16908     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16909     food_(&d__1);
16910 // FFEINTRIN_impDMOD //
16911     d__1 = d_mod(&d1, &d2);
16912     food_(&d__1);
16913 // FFEINTRIN_impDNINT //
16914     d__1 = d_nint(&d1);
16915     food_(&d__1);
16916 // FFEINTRIN_impDPROD //
16917     d__1 = (doublereal) r1 * r2;
16918     food_(&d__1);
16919 // FFEINTRIN_impDSIGN //
16920     d__1 = d_sign(&d1, &d2);
16921     food_(&d__1);
16922 // FFEINTRIN_impDSIN //
16923     d__1 = sin(d1);
16924     food_(&d__1);
16925 // FFEINTRIN_impDSINH //
16926     d__1 = sinh(d1);
16927     food_(&d__1);
16928 // FFEINTRIN_impDSQRT //
16929     d__1 = sqrt(d1);
16930     food_(&d__1);
16931 // FFEINTRIN_impDTAN //
16932     d__1 = tan(d1);
16933     food_(&d__1);
16934 // FFEINTRIN_impDTANH //
16935     d__1 = tanh(d1);
16936     food_(&d__1);
16937 // FFEINTRIN_impEXP //
16938     r__1 = exp(r1);
16939     foor_(&r__1);
16940 // FFEINTRIN_impIABS //
16941     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16942     fooi_(&i__1);
16943 // FFEINTRIN_impICHAR //
16944     i__1 = *(unsigned char *)a1;
16945     fooi_(&i__1);
16946 // FFEINTRIN_impIDIM //
16947     i__1 = i_dim(&i1, &i2);
16948     fooi_(&i__1);
16949 // FFEINTRIN_impIDNINT //
16950     i__1 = i_dnnt(&d1);
16951     fooi_(&i__1);
16952 // FFEINTRIN_impINDEX //
16953     i__1 = i_indx(a1, a2, 10L, 10L);
16954     fooi_(&i__1);
16955 // FFEINTRIN_impISIGN //
16956     i__1 = i_sign(&i1, &i2);
16957     fooi_(&i__1);
16958 // FFEINTRIN_impLEN //
16959     i__1 = i_len(a1, 10L);
16960     fooi_(&i__1);
16961 // FFEINTRIN_impLGE //
16962     L__1 = l_ge(a1, a2, 10L, 10L);
16963     fool_(&L__1);
16964 // FFEINTRIN_impLGT //
16965     L__1 = l_gt(a1, a2, 10L, 10L);
16966     fool_(&L__1);
16967 // FFEINTRIN_impLLE //
16968     L__1 = l_le(a1, a2, 10L, 10L);
16969     fool_(&L__1);
16970 // FFEINTRIN_impLLT //
16971     L__1 = l_lt(a1, a2, 10L, 10L);
16972     fool_(&L__1);
16973 // FFEINTRIN_impMAX0 //
16974     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16975     fooi_(&i__1);
16976 // FFEINTRIN_impMAX1 //
16977     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16978     fooi_(&i__1);
16979 // FFEINTRIN_impMIN0 //
16980     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16981     fooi_(&i__1);
16982 // FFEINTRIN_impMIN1 //
16983     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16984     fooi_(&i__1);
16985 // FFEINTRIN_impMOD //
16986     i__1 = i1 % i2;
16987     fooi_(&i__1);
16988 // FFEINTRIN_impNINT //
16989     i__1 = i_nint(&r1);
16990     fooi_(&i__1);
16991 // FFEINTRIN_impSIGN //
16992     r__1 = r_sign(&r1, &r2);
16993     foor_(&r__1);
16994 // FFEINTRIN_impSIN //
16995     r__1 = sin(r1);
16996     foor_(&r__1);
16997 // FFEINTRIN_impSINH //
16998     r__1 = sinh(r1);
16999     foor_(&r__1);
17000 // FFEINTRIN_impSQRT //
17001     r__1 = sqrt(r1);
17002     foor_(&r__1);
17003 // FFEINTRIN_impTAN //
17004     r__1 = tan(r1);
17005     foor_(&r__1);
17006 // FFEINTRIN_impTANH //
17007     r__1 = tanh(r1);
17008     foor_(&r__1);
17009 // FFEINTRIN_imp_CMPLX_C //
17010     r__1 = c1.r;
17011     r__2 = c2.r;
17012     q__1.r = r__1, q__1.i = r__2;
17013     fooc_(&q__1);
17014 // FFEINTRIN_imp_CMPLX_D //
17015     z__1.r = d1, z__1.i = d2;
17016     fooz_(&z__1);
17017 // FFEINTRIN_imp_CMPLX_I //
17018     r__1 = (real) i1;
17019     r__2 = (real) i2;
17020     q__1.r = r__1, q__1.i = r__2;
17021     fooc_(&q__1);
17022 // FFEINTRIN_imp_CMPLX_R //
17023     q__1.r = r1, q__1.i = r2;
17024     fooc_(&q__1);
17025 // FFEINTRIN_imp_DBLE_C //
17026     d__1 = (doublereal) c1.r;
17027     food_(&d__1);
17028 // FFEINTRIN_imp_DBLE_D //
17029     d__1 = d1;
17030     food_(&d__1);
17031 // FFEINTRIN_imp_DBLE_I //
17032     d__1 = (doublereal) i1;
17033     food_(&d__1);
17034 // FFEINTRIN_imp_DBLE_R //
17035     d__1 = (doublereal) r1;
17036     food_(&d__1);
17037 // FFEINTRIN_imp_INT_C //
17038     i__1 = (integer) c1.r;
17039     fooi_(&i__1);
17040 // FFEINTRIN_imp_INT_D //
17041     i__1 = (integer) d1;
17042     fooi_(&i__1);
17043 // FFEINTRIN_imp_INT_I //
17044     i__1 = i1;
17045     fooi_(&i__1);
17046 // FFEINTRIN_imp_INT_R //
17047     i__1 = (integer) r1;
17048     fooi_(&i__1);
17049 // FFEINTRIN_imp_REAL_C //
17050     r__1 = c1.r;
17051     foor_(&r__1);
17052 // FFEINTRIN_imp_REAL_D //
17053     r__1 = (real) d1;
17054     foor_(&r__1);
17055 // FFEINTRIN_imp_REAL_I //
17056     r__1 = (real) i1;
17057     foor_(&r__1);
17058 // FFEINTRIN_imp_REAL_R //
17059     r__1 = r1;
17060     foor_(&r__1);
17061
17062 // FFEINTRIN_imp_INT_D: //
17063
17064 // FFEINTRIN_specIDINT //
17065     i__1 = (integer) d1;
17066     fooi_(&i__1);
17067
17068 // FFEINTRIN_imp_INT_R: //
17069
17070 // FFEINTRIN_specIFIX //
17071     i__1 = (integer) r1;
17072     fooi_(&i__1);
17073 // FFEINTRIN_specINT //
17074     i__1 = (integer) r1;
17075     fooi_(&i__1);
17076
17077 // FFEINTRIN_imp_REAL_D: //
17078
17079 // FFEINTRIN_specSNGL //
17080     r__1 = (real) d1;
17081     foor_(&r__1);
17082
17083 // FFEINTRIN_imp_REAL_I: //
17084
17085 // FFEINTRIN_specFLOAT //
17086     r__1 = (real) i1;
17087     foor_(&r__1);
17088 // FFEINTRIN_specREAL //
17089     r__1 = (real) i1;
17090     foor_(&r__1);
17091
17092 } // MAIN__ //
17093
17094 -------- (end output file from f2c)
17095
17096 */