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 = xmalloc (strlen (array_name) + 20);
 698         sprintf (var, "%s[%s-substring]",
 699                  array_name,
 700                  dim ? "end" : "start");
 701         len = strlen (var) + 1;
 702         arg1 = build_string (len, var);
 703         free (var);
 704         break;
 705
 706       case 1:
 707         len = strlen (array_name) + 1;
 708         arg1 = build_string (len, array_name);
 709         break;
 710
 711       default:
 712         var = xmalloc (strlen (array_name) + 40);
 713         sprintf (var, "%s[subscript-%d-of-%d]",
 714                  array_name,
 715                  dim + 1, total_dims);
 716         len = strlen (var) + 1;
 717         arg1 = build_string (len, var);
 718         free (var);
 719         break;
 720       }
 721
 722     TREE_TYPE (arg1)
 723       = build_type_variant (build_array_type (char_type_node,
 724                                               build_range_type
 725                                               (integer_type_node,
 726                                                integer_one_node,
 727                                                build_int_2 (len, 0))),
 728                             1, 0);
 729     TREE_CONSTANT (arg1) = 1;
 730     TREE_STATIC (arg1) = 1;
 731     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 732                      arg1);
 733
 734     /* s_rnge adds one to the element to print it, so bias against
 735        that -- want to print a faithful *subscript* value.  */
 736     arg2 = convert (ffecom_f2c_ftnint_type_node,
 737                     ffecom_2 (MINUS_EXPR,
 738                               TREE_TYPE (element),
 739                               element,
 740                               convert (TREE_TYPE (element),
 741                                        integer_one_node)));
 742
 743     proc = xmalloc ((len = strlen (input_filename)
 744                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 745                      + 2));
 746
 747     sprintf (&proc[0], "%s/%s",
 748              input_filename,
 749              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 750     arg3 = build_string (len, proc);
 751
 752     free (proc);
 753
 754     TREE_TYPE (arg3)
 755       = build_type_variant (build_array_type (char_type_node,
 756                                               build_range_type
 757                                               (integer_type_node,
 758                                                integer_one_node,
 759                                                build_int_2 (len, 0))),
 760                             1, 0);
 761     TREE_CONSTANT (arg3) = 1;
 762     TREE_STATIC (arg3) = 1;
 763     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 764                      arg3);
 765
 766     arg4 = convert (ffecom_f2c_ftnint_type_node,
 767                     build_int_2 (lineno, 0));
 768
 769     arg1 = build_tree_list (NULL_TREE, arg1);
 770     arg2 = build_tree_list (NULL_TREE, arg2);
 771     arg3 = build_tree_list (NULL_TREE, arg3);
 772     arg4 = build_tree_list (NULL_TREE, arg4);
 773     TREE_CHAIN (arg3) = arg4;
 774     TREE_CHAIN (arg2) = arg3;
 775     TREE_CHAIN (arg1) = arg2;
 776
 777     args = arg1;
 778   }
 779   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 780                           args, NULL_TREE);
 781   TREE_SIDE_EFFECTS (die) = 1;
 782
 783   element = ffecom_3 (COND_EXPR,
 784                       TREE_TYPE (element),
 785                       cond,
 786                       element,
 787                       die);
 788
 789   return element;
 790 }
 791
 792 /* Return the computed element of an array reference.
 793
 794    `item' is NULL_TREE, or the transformed pointer to the array.
 795    `expr' is the original opARRAYREF expression, which is transformed
 796      if `item' is NULL_TREE.
 797    `want_ptr' is non-zero if a pointer to the element, instead of
 798      the element itself, is to be returned.  */
 799
 800 static tree
 801 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 802 {
 803   ffebld dims[FFECOM_dimensionsMAX];
 804   int i;
 805   int total_dims;
 806   int flatten = ffe_is_flatten_arrays ();
 807   int need_ptr;
 808   tree array;
 809   tree element;
 810   tree tree_type;
 811   tree tree_type_x;
 812   const char *array_name;
 813   ffetype type;
 814   ffebld list;
 815
 816   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 817     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 818   else
 819     array_name = "[expr?]";
 820
 821   /* Build up ARRAY_REFs in reverse order (since we're column major
 822      here in Fortran land). */
 823
 824   for (i = 0, list = ffebld_right (expr);
 825        list != NULL;
 826        ++i, list = ffebld_trail (list))
 827     {
 828       dims[i] = ffebld_head (list);
 829       type = ffeinfo_type (ffebld_basictype (dims[i]),
 830                            ffebld_kindtype (dims[i]));
 831       if (! flatten
 832           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 833           && ffetype_size (type) > ffecom_typesize_integer1_)
 834         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 835            pointers and 32-bit integers.  Do the full 64-bit pointer
 836            arithmetic, for codes using arrays for nonstandard heap-like
 837            work.  */
 838         flatten = 1;
 839     }
 840
 841   total_dims = i;
 842
 843   need_ptr = want_ptr || flatten;
 844
 845   if (! item)
 846     {
 847       if (need_ptr)
 848         item = ffecom_ptr_to_expr (ffebld_left (expr));
 849       else
 850         item = ffecom_expr (ffebld_left (expr));
 851
 852       if (item == error_mark_node)
 853         return item;
 854
 855       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 856           && ! mark_addressable (item))
 857         return error_mark_node;
 858     }
 859
 860   if (item == error_mark_node)
 861     return item;
 862
 863   if (need_ptr)
 864     {
 865       tree min;
 866
 867       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 868            i >= 0;
 869            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 870         {
 871           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 872           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 873           if (flag_bounds_check)
 874             element = ffecom_subscript_check_ (array, element, i, total_dims,
 875                                                array_name);
 876           if (element == error_mark_node)
 877             return element;
 878
 879           /* Widen integral arithmetic as desired while preserving
 880              signedness.  */
 881           tree_type = TREE_TYPE (element);
 882           tree_type_x = tree_type;
 883           if (tree_type
 884               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 885               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 886             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 887
 888           if (TREE_TYPE (min) != tree_type_x)
 889             min = convert (tree_type_x, min);
 890           if (TREE_TYPE (element) != tree_type_x)
 891             element = convert (tree_type_x, element);
 892
 893           item = ffecom_2 (PLUS_EXPR,
 894                            build_pointer_type (TREE_TYPE (array)),
 895                            item,
 896                            size_binop (MULT_EXPR,
 897                                        size_in_bytes (TREE_TYPE (array)),
 898                                        convert (sizetype,
 899                                                 fold (build (MINUS_EXPR,
 900                                                              tree_type_x,
 901                                                              element, min)))));
 902         }
 903       if (! want_ptr)
 904         {
 905           item = ffecom_1 (INDIRECT_REF,
 906                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 907                            item);
 908         }
 909     }
 910   else
 911     {
 912       for (--i;
 913            i >= 0;
 914            --i)
 915         {
 916           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 917
 918           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 919           if (flag_bounds_check)
 920             element = ffecom_subscript_check_ (array, element, i, total_dims,
 921                                                array_name);
 922           if (element == error_mark_node)
 923             return element;
 924
 925           /* Widen integral arithmetic as desired while preserving
 926              signedness.  */
 927           tree_type = TREE_TYPE (element);
 928           tree_type_x = tree_type;
 929           if (tree_type
 930               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 931               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 932             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 933
 934           element = convert (tree_type_x, element);
 935
 936           item = ffecom_2 (ARRAY_REF,
 937                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 938                            item,
 939                            element);
 940         }
 941     }
 942
 943   return item;
 944 }
 945
 946 /* This is like gcc's stabilize_reference -- in fact, most of the code
 947    comes from that -- but it handles the situation where the reference
 948    is going to have its subparts picked at, and it shouldn't change
 949    (or trigger extra invocations of functions in the subtrees) due to
 950    this.  save_expr is a bit overzealous, because we don't need the
 951    entire thing calculated and saved like a temp.  So, for DECLs, no
 952    change is needed, because these are stable aggregates, and ARRAY_REF
 953    and such might well be stable too, but for things like calculations,
 954    we do need to calculate a snapshot of a value before picking at it.  */
 955
 956 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 957 static tree
 958 ffecom_stabilize_aggregate_ (tree ref)
 959 {
 960   tree result;
 961   enum tree_code code = TREE_CODE (ref);
 962
 963   switch (code)
 964     {
 965     case VAR_DECL:
 966     case PARM_DECL:
 967     case RESULT_DECL:
 968       /* No action is needed in this case.  */
 969       return ref;
 970
 971     case NOP_EXPR:
 972     case CONVERT_EXPR:
 973     case FLOAT_EXPR:
 974     case FIX_TRUNC_EXPR:
 975     case FIX_FLOOR_EXPR:
 976     case FIX_ROUND_EXPR:
 977     case FIX_CEIL_EXPR:
 978       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 979       break;
 980
 981     case INDIRECT_REF:
 982       result = build_nt (INDIRECT_REF,
 983                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 984       break;
 985
 986     case COMPONENT_REF:
 987       result = build_nt (COMPONENT_REF,
 988                          stabilize_reference (TREE_OPERAND (ref, 0)),
 989                          TREE_OPERAND (ref, 1));
 990       break;
 991
 992     case BIT_FIELD_REF:
 993       result = build_nt (BIT_FIELD_REF,
 994                          stabilize_reference (TREE_OPERAND (ref, 0)),
 995                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 996                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 997       break;
 998
 999     case ARRAY_REF:
1000       result = build_nt (ARRAY_REF,
1001                          stabilize_reference (TREE_OPERAND (ref, 0)),
1002                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1003       break;
1004
1005     case COMPOUND_EXPR:
1006       result = build_nt (COMPOUND_EXPR,
1007                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1008                          stabilize_reference (TREE_OPERAND (ref, 1)));
1009       break;
1010
1011     case RTL_EXPR:
1012       abort ();
1013
1014
1015     default:
1016       return save_expr (ref);
1017
1018     case ERROR_MARK:
1019       return error_mark_node;
1020     }
1021
1022   TREE_TYPE (result) = TREE_TYPE (ref);
1023   TREE_READONLY (result) = TREE_READONLY (ref);
1024   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1025   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1026
1027   return result;
1028 }
1029 #endif
1030
1031 /* A rip-off of gcc's convert.c convert_to_complex function,
1032    reworked to handle complex implemented as C structures
1033    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1034
1035 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1036 static tree
1037 ffecom_convert_to_complex_ (tree type, tree expr)
1038 {
1039   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1040   tree subtype;
1041
1042   assert (TREE_CODE (type) == RECORD_TYPE);
1043
1044   subtype = TREE_TYPE (TYPE_FIELDS (type));
1045
1046   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1047     {
1048       expr = convert (subtype, expr);
1049       return ffecom_2 (COMPLEX_EXPR, type, expr,
1050                        convert (subtype, integer_zero_node));
1051     }
1052
1053   if (form == RECORD_TYPE)
1054     {
1055       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1056       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1057         return expr;
1058       else
1059         {
1060           expr = save_expr (expr);
1061           return ffecom_2 (COMPLEX_EXPR,
1062                            type,
1063                            convert (subtype,
1064                                     ffecom_1 (REALPART_EXPR,
1065                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1066                                               expr)),
1067                            convert (subtype,
1068                                     ffecom_1 (IMAGPART_EXPR,
1069                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1070                                               expr)));
1071         }
1072     }
1073
1074   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1075     error ("pointer value used where a complex was expected");
1076   else
1077     error ("aggregate value used where a complex was expected");
1078
1079   return ffecom_2 (COMPLEX_EXPR, type,
1080                    convert (subtype, integer_zero_node),
1081                    convert (subtype, integer_zero_node));
1082 }
1083 #endif
1084
1085 /* Like gcc's convert(), but crashes if widening might happen.  */
1086
1087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1088 static tree
1089 ffecom_convert_narrow_ (type, expr)
1090      tree type, expr;
1091 {
1092   register tree e = expr;
1093   register enum tree_code code = TREE_CODE (type);
1094
1095   if (type == TREE_TYPE (e)
1096       || TREE_CODE (e) == ERROR_MARK)
1097     return e;
1098   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1099     return fold (build1 (NOP_EXPR, type, e));
1100   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1101       || code == ERROR_MARK)
1102     return error_mark_node;
1103   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1104     {
1105       assert ("void value not ignored as it ought to be" == NULL);
1106       return error_mark_node;
1107     }
1108   assert (code != VOID_TYPE);
1109   if ((code != RECORD_TYPE)
1110       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1111     assert ("converting COMPLEX to REAL" == NULL);
1112   assert (code != ENUMERAL_TYPE);
1113   if (code == INTEGER_TYPE)
1114     {
1115       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1116                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1117               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1118                   && (TYPE_PRECISION (type)
1119                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1120       return fold (convert_to_integer (type, e));
1121     }
1122   if (code == POINTER_TYPE)
1123     {
1124       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1125       return fold (convert_to_pointer (type, e));
1126     }
1127   if (code == REAL_TYPE)
1128     {
1129       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1130       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1131       return fold (convert_to_real (type, e));
1132     }
1133   if (code == COMPLEX_TYPE)
1134     {
1135       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1136       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1137       return fold (convert_to_complex (type, e));
1138     }
1139   if (code == RECORD_TYPE)
1140     {
1141       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1142       /* Check that at least the first field name agrees.  */
1143       assert (DECL_NAME (TYPE_FIELDS (type))
1144               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1145       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1146               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1147       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1148           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1149         return e;
1150       return fold (ffecom_convert_to_complex_ (type, e));
1151     }
1152
1153   assert ("conversion to non-scalar type requested" == NULL);
1154   return error_mark_node;
1155 }
1156 #endif
1157
1158 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1159
1160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1161 static tree
1162 ffecom_convert_widen_ (type, expr)
1163      tree type, expr;
1164 {
1165   register tree e = expr;
1166   register enum tree_code code = TREE_CODE (type);
1167
1168   if (type == TREE_TYPE (e)
1169       || TREE_CODE (e) == ERROR_MARK)
1170     return e;
1171   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1172     return fold (build1 (NOP_EXPR, type, e));
1173   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1174       || code == ERROR_MARK)
1175     return error_mark_node;
1176   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1177     {
1178       assert ("void value not ignored as it ought to be" == NULL);
1179       return error_mark_node;
1180     }
1181   assert (code != VOID_TYPE);
1182   if ((code != RECORD_TYPE)
1183       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1184     assert ("narrowing COMPLEX to REAL" == NULL);
1185   assert (code != ENUMERAL_TYPE);
1186   if (code == INTEGER_TYPE)
1187     {
1188       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1189                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1190               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1191                   && (TYPE_PRECISION (type)
1192                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1193       return fold (convert_to_integer (type, e));
1194     }
1195   if (code == POINTER_TYPE)
1196     {
1197       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1198       return fold (convert_to_pointer (type, e));
1199     }
1200   if (code == REAL_TYPE)
1201     {
1202       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1203       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1204       return fold (convert_to_real (type, e));
1205     }
1206   if (code == COMPLEX_TYPE)
1207     {
1208       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1209       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1210       return fold (convert_to_complex (type, e));
1211     }
1212   if (code == RECORD_TYPE)
1213     {
1214       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1215       /* Check that at least the first field name agrees.  */
1216       assert (DECL_NAME (TYPE_FIELDS (type))
1217               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1218       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1219               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1220       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1221           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1222         return e;
1223       return fold (ffecom_convert_to_complex_ (type, e));
1224     }
1225
1226   assert ("conversion to non-scalar type requested" == NULL);
1227   return error_mark_node;
1228 }
1229 #endif
1230
1231 /* Handles making a COMPLEX type, either the standard
1232    (but buggy?) gbe way, or the safer (but less elegant?)
1233    f2c way.  */
1234
1235 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1236 static tree
1237 ffecom_make_complex_type_ (tree subtype)
1238 {
1239   tree type;
1240   tree realfield;
1241   tree imagfield;
1242
1243   if (ffe_is_emulate_complex ())
1244     {
1245       type = make_node (RECORD_TYPE);
1246       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1247       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1248       TYPE_FIELDS (type) = realfield;
1249       layout_type (type);
1250     }
1251   else
1252     {
1253       type = make_node (COMPLEX_TYPE);
1254       TREE_TYPE (type) = subtype;
1255       layout_type (type);
1256     }
1257
1258   return type;
1259 }
1260 #endif
1261
1262 /* Chooses either the gbe or the f2c way to build a
1263    complex constant.  */
1264
1265 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1266 static tree
1267 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1268 {
1269   tree bothparts;
1270
1271   if (ffe_is_emulate_complex ())
1272     {
1273       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1274       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1275       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1276     }
1277   else
1278     {
1279       bothparts = build_complex (type, realpart, imagpart);
1280     }
1281
1282   return bothparts;
1283 }
1284 #endif
1285
1286 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1287 static tree
1288 ffecom_arglist_expr_ (const char *c, ffebld expr)
1289 {
1290   tree list;
1291   tree *plist = &list;
1292   tree trail = NULL_TREE;       /* Append char length args here. */
1293   tree *ptrail = &trail;
1294   tree length;
1295   ffebld exprh;
1296   tree item;
1297   bool ptr = FALSE;
1298   tree wanted = NULL_TREE;
1299   static char zed[] = "0";
1300
1301   if (c == NULL)
1302     c = &zed[0];
1303
1304   while (expr != NULL)
1305     {
1306       if (*c != '\0')
1307         {
1308           ptr = FALSE;
1309           if (*c == '&')
1310             {
1311               ptr = TRUE;
1312               ++c;
1313             }
1314           switch (*(c++))
1315             {
1316             case '\0':
1317               ptr = TRUE;
1318               wanted = NULL_TREE;
1319               break;
1320
1321             case 'a':
1322               assert (ptr);
1323               wanted = NULL_TREE;
1324               break;
1325
1326             case 'c':
1327               wanted = ffecom_f2c_complex_type_node;
1328               break;
1329
1330             case 'd':
1331               wanted = ffecom_f2c_doublereal_type_node;
1332               break;
1333
1334             case 'e':
1335               wanted = ffecom_f2c_doublecomplex_type_node;
1336               break;
1337
1338             case 'f':
1339               wanted = ffecom_f2c_real_type_node;
1340               break;
1341
1342             case 'i':
1343               wanted = ffecom_f2c_integer_type_node;
1344               break;
1345
1346             case 'j':
1347               wanted = ffecom_f2c_longint_type_node;
1348               break;
1349
1350             default:
1351               assert ("bad argstring code" == NULL);
1352               wanted = NULL_TREE;
1353               break;
1354             }
1355         }
1356
1357       exprh = ffebld_head (expr);
1358       if (exprh == NULL)
1359         wanted = NULL_TREE;
1360
1361       if ((wanted == NULL_TREE)
1362           || (ptr
1363               && (TYPE_MODE
1364                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1365                    [ffeinfo_kindtype (ffebld_info (exprh))])
1366                    == TYPE_MODE (wanted))))
1367         *plist
1368           = build_tree_list (NULL_TREE,
1369                              ffecom_arg_ptr_to_expr (exprh,
1370                                                      &length));
1371       else
1372         {
1373           item = ffecom_arg_expr (exprh, &length);
1374           item = ffecom_convert_widen_ (wanted, item);
1375           if (ptr)
1376             {
1377               item = ffecom_1 (ADDR_EXPR,
1378                                build_pointer_type (TREE_TYPE (item)),
1379                                item);
1380             }
1381           *plist
1382             = build_tree_list (NULL_TREE,
1383                                item);
1384         }
1385
1386       plist = &TREE_CHAIN (*plist);
1387       expr = ffebld_trail (expr);
1388       if (length != NULL_TREE)
1389         {
1390           *ptrail = build_tree_list (NULL_TREE, length);
1391           ptrail = &TREE_CHAIN (*ptrail);
1392         }
1393     }
1394
1395   /* We've run out of args in the call; if the implementation expects
1396      more, supply null pointers for them, which the implementation can
1397      check to see if an arg was omitted. */
1398
1399   while (*c != '\0' && *c != '0')
1400     {
1401       if (*c == '&')
1402         ++c;
1403       else
1404         assert ("missing arg to run-time routine!" == NULL);
1405
1406       switch (*(c++))
1407         {
1408         case '\0':
1409         case 'a':
1410         case 'c':
1411         case 'd':
1412         case 'e':
1413         case 'f':
1414         case 'i':
1415         case 'j':
1416           break;
1417
1418         default:
1419           assert ("bad arg string code" == NULL);
1420           break;
1421         }
1422       *plist
1423         = build_tree_list (NULL_TREE,
1424                            null_pointer_node);
1425       plist = &TREE_CHAIN (*plist);
1426     }
1427
1428   *plist = trail;
1429
1430   return list;
1431 }
1432 #endif
1433
1434 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1435 static tree
1436 ffecom_widest_expr_type_ (ffebld list)
1437 {
1438   ffebld item;
1439   ffebld widest = NULL;
1440   ffetype type;
1441   ffetype widest_type = NULL;
1442   tree t;
1443
1444   for (; list != NULL; list = ffebld_trail (list))
1445     {
1446       item = ffebld_head (list);
1447       if (item == NULL)
1448         continue;
1449       if ((widest != NULL)
1450           && (ffeinfo_basictype (ffebld_info (item))
1451               != ffeinfo_basictype (ffebld_info (widest))))
1452         continue;
1453       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1454                            ffeinfo_kindtype (ffebld_info (item)));
1455       if ((widest == FFEINFO_kindtypeNONE)
1456           || (ffetype_size (type)
1457               > ffetype_size (widest_type)))
1458         {
1459           widest = item;
1460           widest_type = type;
1461         }
1462     }
1463
1464   assert (widest != NULL);
1465   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1466     [ffeinfo_kindtype (ffebld_info (widest))];
1467   assert (t != NULL_TREE);
1468   return t;
1469 }
1470 #endif
1471
1472 /* Check whether a partial overlap between two expressions is possible.
1473
1474    Can *starting* to write a portion of expr1 change the value
1475    computed (perhaps already, *partially*) by expr2?
1476
1477    Currently, this is a concern only for a COMPLEX expr1.  But if it
1478    isn't in COMMON or local EQUIVALENCE, since we don't support
1479    aliasing of arguments, it isn't a concern.  */
1480
1481 static bool
1482 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1483 {
1484   ffesymbol sym;
1485   ffestorag st;
1486
1487   switch (ffebld_op (expr1))
1488     {
1489     case FFEBLD_opSYMTER:
1490       sym = ffebld_symter (expr1);
1491       break;
1492
1493     case FFEBLD_opARRAYREF:
1494       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1495         return FALSE;
1496       sym = ffebld_symter (ffebld_left (expr1));
1497       break;
1498
1499     default:
1500       return FALSE;
1501     }
1502
1503   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1504       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1505           || ! (st = ffesymbol_storage (sym))
1506           || ! ffestorag_parent (st)))
1507     return FALSE;
1508
1509   /* It's in COMMON or local EQUIVALENCE.  */
1510
1511   return TRUE;
1512 }
1513
1514 /* Check whether dest and source might overlap.  ffebld versions of these
1515    might or might not be passed, will be NULL if not.
1516
1517    The test is really whether source_tree is modifiable and, if modified,
1518    might overlap destination such that the value(s) in the destination might
1519    change before it is finally modified.  dest_* are the canonized
1520    destination itself.  */
1521
1522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1523 static bool
1524 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1525                  tree source_tree, ffebld source UNUSED,
1526                  bool scalar_arg)
1527 {
1528   tree source_decl;
1529   tree source_offset;
1530   tree source_size;
1531   tree t;
1532
1533   if (source_tree == NULL_TREE)
1534     return FALSE;
1535
1536   switch (TREE_CODE (source_tree))
1537     {
1538     case ERROR_MARK:
1539     case IDENTIFIER_NODE:
1540     case INTEGER_CST:
1541     case REAL_CST:
1542     case COMPLEX_CST:
1543     case STRING_CST:
1544     case CONST_DECL:
1545     case VAR_DECL:
1546     case RESULT_DECL:
1547     case FIELD_DECL:
1548     case MINUS_EXPR:
1549     case MULT_EXPR:
1550     case TRUNC_DIV_EXPR:
1551     case CEIL_DIV_EXPR:
1552     case FLOOR_DIV_EXPR:
1553     case ROUND_DIV_EXPR:
1554     case TRUNC_MOD_EXPR:
1555     case CEIL_MOD_EXPR:
1556     case FLOOR_MOD_EXPR:
1557     case ROUND_MOD_EXPR:
1558     case RDIV_EXPR:
1559     case EXACT_DIV_EXPR:
1560     case FIX_TRUNC_EXPR:
1561     case FIX_CEIL_EXPR:
1562     case FIX_FLOOR_EXPR:
1563     case FIX_ROUND_EXPR:
1564     case FLOAT_EXPR:
1565     case EXPON_EXPR:
1566     case NEGATE_EXPR:
1567     case MIN_EXPR:
1568     case MAX_EXPR:
1569     case ABS_EXPR:
1570     case FFS_EXPR:
1571     case LSHIFT_EXPR:
1572     case RSHIFT_EXPR:
1573     case LROTATE_EXPR:
1574     case RROTATE_EXPR:
1575     case BIT_IOR_EXPR:
1576     case BIT_XOR_EXPR:
1577     case BIT_AND_EXPR:
1578     case BIT_ANDTC_EXPR:
1579     case BIT_NOT_EXPR:
1580     case TRUTH_ANDIF_EXPR:
1581     case TRUTH_ORIF_EXPR:
1582     case TRUTH_AND_EXPR:
1583     case TRUTH_OR_EXPR:
1584     case TRUTH_XOR_EXPR:
1585     case TRUTH_NOT_EXPR:
1586     case LT_EXPR:
1587     case LE_EXPR:
1588     case GT_EXPR:
1589     case GE_EXPR:
1590     case EQ_EXPR:
1591     case NE_EXPR:
1592     case COMPLEX_EXPR:
1593     case CONJ_EXPR:
1594     case REALPART_EXPR:
1595     case IMAGPART_EXPR:
1596     case LABEL_EXPR:
1597     case COMPONENT_REF:
1598       return FALSE;
1599
1600     case COMPOUND_EXPR:
1601       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1602                               TREE_OPERAND (source_tree, 1), NULL,
1603                               scalar_arg);
1604
1605     case MODIFY_EXPR:
1606       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1607                               TREE_OPERAND (source_tree, 0), NULL,
1608                               scalar_arg);
1609
1610     case CONVERT_EXPR:
1611     case NOP_EXPR:
1612     case NON_LVALUE_EXPR:
1613     case PLUS_EXPR:
1614       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1615         return TRUE;
1616
1617       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1618                                  source_tree);
1619       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1620       break;
1621
1622     case COND_EXPR:
1623       return
1624         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1625                          TREE_OPERAND (source_tree, 1), NULL,
1626                          scalar_arg)
1627           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1628                               TREE_OPERAND (source_tree, 2), NULL,
1629                               scalar_arg);
1630
1631
1632     case ADDR_EXPR:
1633       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1634                                  &source_size,
1635                                  TREE_OPERAND (source_tree, 0));
1636       break;
1637
1638     case PARM_DECL:
1639       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1640         return TRUE;
1641
1642       source_decl = source_tree;
1643       source_offset = bitsize_zero_node;
1644       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1645       break;
1646
1647     case SAVE_EXPR:
1648     case REFERENCE_EXPR:
1649     case PREDECREMENT_EXPR:
1650     case PREINCREMENT_EXPR:
1651     case POSTDECREMENT_EXPR:
1652     case POSTINCREMENT_EXPR:
1653     case INDIRECT_REF:
1654     case ARRAY_REF:
1655     case CALL_EXPR:
1656     default:
1657       return TRUE;
1658     }
1659
1660   /* Come here when source_decl, source_offset, and source_size filled
1661      in appropriately.  */
1662
1663   if (source_decl == NULL_TREE)
1664     return FALSE;               /* No decl involved, so no overlap. */
1665
1666   if (source_decl != dest_decl)
1667     return FALSE;               /* Different decl, no overlap. */
1668
1669   if (TREE_CODE (dest_size) == ERROR_MARK)
1670     return TRUE;                /* Assignment into entire assumed-size
1671                                    array?  Shouldn't happen.... */
1672
1673   t = ffecom_2 (LE_EXPR, integer_type_node,
1674                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1675                           dest_offset,
1676                           convert (TREE_TYPE (dest_offset),
1677                                    dest_size)),
1678                 convert (TREE_TYPE (dest_offset),
1679                          source_offset));
1680
1681   if (integer_onep (t))
1682     return FALSE;               /* Destination precedes source. */
1683
1684   if (!scalar_arg
1685       || (source_size == NULL_TREE)
1686       || (TREE_CODE (source_size) == ERROR_MARK)
1687       || integer_zerop (source_size))
1688     return TRUE;                /* No way to tell if dest follows source. */
1689
1690   t = ffecom_2 (LE_EXPR, integer_type_node,
1691                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1692                           source_offset,
1693                           convert (TREE_TYPE (source_offset),
1694                                    source_size)),
1695                 convert (TREE_TYPE (source_offset),
1696                          dest_offset));
1697
1698   if (integer_onep (t))
1699     return FALSE;               /* Destination follows source. */
1700
1701   return TRUE;          /* Destination and source overlap. */
1702 }
1703 #endif
1704
1705 /* Check whether dest might overlap any of a list of arguments or is
1706    in a COMMON area the callee might know about (and thus modify).  */
1707
1708 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1709 static bool
1710 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1711                           tree args, tree callee_commons,
1712                           bool scalar_args)
1713 {
1714   tree arg;
1715   tree dest_decl;
1716   tree dest_offset;
1717   tree dest_size;
1718
1719   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1720                              dest_tree);
1721
1722   if (dest_decl == NULL_TREE)
1723     return FALSE;               /* Seems unlikely! */
1724
1725   /* If the decl cannot be determined reliably, or if its in COMMON
1726      and the callee isn't known to not futz with COMMON via other
1727      means, overlap might happen.  */
1728
1729   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1730       || ((callee_commons != NULL_TREE)
1731           && TREE_PUBLIC (dest_decl)))
1732     return TRUE;
1733
1734   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1735     {
1736       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1737           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1738                               arg, NULL, scalar_args))
1739         return TRUE;
1740     }
1741
1742   return FALSE;
1743 }
1744 #endif
1745
1746 /* Build a string for a variable name as used by NAMELIST.  This means that
1747    if we're using the f2c library, we build an uppercase string, since
1748    f2c does this.  */
1749
1750 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1751 static tree
1752 ffecom_build_f2c_string_ (int i, const char *s)
1753 {
1754   if (!ffe_is_f2c_library ())
1755     return build_string (i, s);
1756
1757   {
1758     char *tmp;
1759     const char *p;
1760     char *q;
1761     char space[34];
1762     tree t;
1763
1764     if (((size_t) i) > ARRAY_SIZE (space))
1765       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1766     else
1767       tmp = &space[0];
1768
1769     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1770       *q = TOUPPER (*p);
1771     *q = '\0';
1772
1773     t = build_string (i, tmp);
1774
1775     if (((size_t) i) > ARRAY_SIZE (space))
1776       malloc_kill_ks (malloc_pool_image (), tmp, i);
1777
1778     return t;
1779   }
1780 }
1781
1782 #endif
1783 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1784    type to just get whatever the function returns), handling the
1785    f2c value-returning convention, if required, by prepending
1786    to the arglist a pointer to a temporary to receive the return value.  */
1787
1788 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1789 static tree
1790 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1791               tree type, tree args, tree dest_tree,
1792               ffebld dest, bool *dest_used, tree callee_commons,
1793               bool scalar_args, tree hook)
1794 {
1795   tree item;
1796   tree tempvar;
1797
1798   if (dest_used != NULL)
1799     *dest_used = FALSE;
1800
1801   if (is_f2c_complex)
1802     {
1803       if ((dest_used == NULL)
1804           || (dest == NULL)
1805           || (ffeinfo_basictype (ffebld_info (dest))
1806               != FFEINFO_basictypeCOMPLEX)
1807           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1808           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1809           || ffecom_args_overlapping_ (dest_tree, dest, args,
1810                                        callee_commons,
1811                                        scalar_args))
1812         {
1813 #ifdef HOHO
1814           tempvar = ffecom_make_tempvar (ffecom_tree_type
1815                                          [FFEINFO_basictypeCOMPLEX][kt],
1816                                          FFETARGET_charactersizeNONE,
1817                                          -1);
1818 #else
1819           tempvar = hook;
1820           assert (tempvar);
1821 #endif
1822         }
1823       else
1824         {
1825           *dest_used = TRUE;
1826           tempvar = dest_tree;
1827           type = NULL_TREE;
1828         }
1829
1830       item
1831         = build_tree_list (NULL_TREE,
1832                            ffecom_1 (ADDR_EXPR,
1833                                      build_pointer_type (TREE_TYPE (tempvar)),
1834                                      tempvar));
1835       TREE_CHAIN (item) = args;
1836
1837       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1838                         item, NULL_TREE);
1839
1840       if (tempvar != dest_tree)
1841         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1842     }
1843   else
1844     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1845                       args, NULL_TREE);
1846
1847   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1848     item = ffecom_convert_narrow_ (type, item);
1849
1850   return item;
1851 }
1852 #endif
1853
1854 /* Given two arguments, transform them and make a call to the given
1855    function via ffecom_call_.  */
1856
1857 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1858 static tree
1859 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1860                     tree type, ffebld left, ffebld right,
1861                     tree dest_tree, ffebld dest, bool *dest_used,
1862                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1863 {
1864   tree left_tree;
1865   tree right_tree;
1866   tree left_length;
1867   tree right_length;
1868
1869   if (ref)
1870     {
1871       /* Pass arguments by reference.  */
1872       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1873       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1874     }
1875   else
1876     {
1877       /* Pass arguments by value.  */
1878       left_tree = ffecom_arg_expr (left, &left_length);
1879       right_tree = ffecom_arg_expr (right, &right_length);
1880     }
1881
1882
1883   left_tree = build_tree_list (NULL_TREE, left_tree);
1884   right_tree = build_tree_list (NULL_TREE, right_tree);
1885   TREE_CHAIN (left_tree) = right_tree;
1886
1887   if (left_length != NULL_TREE)
1888     {
1889       left_length = build_tree_list (NULL_TREE, left_length);
1890       TREE_CHAIN (right_tree) = left_length;
1891     }
1892
1893   if (right_length != NULL_TREE)
1894     {
1895       right_length = build_tree_list (NULL_TREE, right_length);
1896       if (left_length != NULL_TREE)
1897         TREE_CHAIN (left_length) = right_length;
1898       else
1899         TREE_CHAIN (right_tree) = right_length;
1900     }
1901
1902   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1903                        dest_tree, dest, dest_used, callee_commons,
1904                        scalar_args, hook);
1905 }
1906 #endif
1907
1908 /* Return ptr/length args for char subexpression
1909
1910    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1911    subexpressions by constructing the appropriate trees for the ptr-to-
1912    character-text and length-of-character-text arguments in a calling
1913    sequence.
1914
1915    Note that if with_null is TRUE, and the expression is an opCONTER,
1916    a null byte is appended to the string.  */
1917
1918 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1919 static void
1920 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1921 {
1922   tree item;
1923   tree high;
1924   ffetargetCharacter1 val;
1925   ffetargetCharacterSize newlen;
1926
1927   switch (ffebld_op (expr))
1928     {
1929     case FFEBLD_opCONTER:
1930       val = ffebld_constant_character1 (ffebld_conter (expr));
1931       newlen = ffetarget_length_character1 (val);
1932       if (with_null)
1933         {
1934           /* Begin FFETARGET-NULL-KLUDGE.  */
1935           if (newlen != 0)
1936             ++newlen;
1937         }
1938       *length = build_int_2 (newlen, 0);
1939       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1940       high = build_int_2 (newlen, 0);
1941       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1942       item = build_string (newlen,
1943                            ffetarget_text_character1 (val));
1944       /* End FFETARGET-NULL-KLUDGE.  */
1945       TREE_TYPE (item)
1946         = build_type_variant
1947           (build_array_type
1948            (char_type_node,
1949             build_range_type
1950             (ffecom_f2c_ftnlen_type_node,
1951              ffecom_f2c_ftnlen_one_node,
1952              high)),
1953            1, 0);
1954       TREE_CONSTANT (item) = 1;
1955       TREE_STATIC (item) = 1;
1956       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1957                        item);
1958       break;
1959
1960     case FFEBLD_opSYMTER:
1961       {
1962         ffesymbol s = ffebld_symter (expr);
1963
1964         item = ffesymbol_hook (s).decl_tree;
1965         if (item == NULL_TREE)
1966           {
1967             s = ffecom_sym_transform_ (s);
1968             item = ffesymbol_hook (s).decl_tree;
1969           }
1970         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1971           {
1972             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1973               *length = ffesymbol_hook (s).length_tree;
1974             else
1975               {
1976                 *length = build_int_2 (ffesymbol_size (s), 0);
1977                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1978               }
1979           }
1980         else if (item == error_mark_node)
1981           *length = error_mark_node;
1982         else
1983           /* FFEINFO_kindFUNCTION.  */
1984           *length = NULL_TREE;
1985         if (!ffesymbol_hook (s).addr
1986             && (item != error_mark_node))
1987           item = ffecom_1 (ADDR_EXPR,
1988                            build_pointer_type (TREE_TYPE (item)),
1989                            item);
1990       }
1991       break;
1992
1993     case FFEBLD_opARRAYREF:
1994       {
1995         ffecom_char_args_ (&item, length, ffebld_left (expr));
1996
1997         if (item == error_mark_node || *length == error_mark_node)
1998           {
1999             item = *length = error_mark_node;
2000             break;
2001           }
2002
2003         item = ffecom_arrayref_ (item, expr, 1);
2004       }
2005       break;
2006
2007     case FFEBLD_opSUBSTR:
2008       {
2009         ffebld start;
2010         ffebld end;
2011         ffebld thing = ffebld_right (expr);
2012         tree start_tree;
2013         tree end_tree;
2014         const char *char_name;
2015         ffebld left_symter;
2016         tree array;
2017
2018         assert (ffebld_op (thing) == FFEBLD_opITEM);
2019         start = ffebld_head (thing);
2020         thing = ffebld_trail (thing);
2021         assert (ffebld_trail (thing) == NULL);
2022         end = ffebld_head (thing);
2023
2024         /* Determine name for pretty-printing range-check errors.  */
2025         for (left_symter = ffebld_left (expr);
2026              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2027              left_symter = ffebld_left (left_symter))
2028           ;
2029         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2030           char_name = ffesymbol_text (ffebld_symter (left_symter));
2031         else
2032           char_name = "[expr?]";
2033
2034         ffecom_char_args_ (&item, length, ffebld_left (expr));
2035
2036         if (item == error_mark_node || *length == error_mark_node)
2037           {
2038             item = *length = error_mark_node;
2039             break;
2040           }
2041
2042         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2043
2044         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2045
2046         if (start == NULL)
2047           {
2048             if (end == NULL)
2049               ;
2050             else
2051               {
2052                 end_tree = ffecom_expr (end);
2053                 if (flag_bounds_check)
2054                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2055                                                       char_name);
2056                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2057                                     end_tree);
2058
2059                 if (end_tree == error_mark_node)
2060                   {
2061                     item = *length = error_mark_node;
2062                     break;
2063                   }
2064
2065                 *length = end_tree;
2066               }
2067           }
2068         else
2069           {
2070             start_tree = ffecom_expr (start);
2071             if (flag_bounds_check)
2072               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2073                                                     char_name);
2074             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2075                                   start_tree);
2076
2077             if (start_tree == error_mark_node)
2078               {
2079                 item = *length = error_mark_node;
2080                 break;
2081               }
2082
2083             start_tree = ffecom_save_tree (start_tree);
2084
2085             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2086                              item,
2087                              ffecom_2 (MINUS_EXPR,
2088                                        TREE_TYPE (start_tree),
2089                                        start_tree,
2090                                        ffecom_f2c_ftnlen_one_node));
2091
2092             if (end == NULL)
2093               {
2094                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2095                                     ffecom_f2c_ftnlen_one_node,
2096                                     ffecom_2 (MINUS_EXPR,
2097                                               ffecom_f2c_ftnlen_type_node,
2098                                               *length,
2099                                               start_tree));
2100               }
2101             else
2102               {
2103                 end_tree = ffecom_expr (end);
2104                 if (flag_bounds_check)
2105                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2106                                                       char_name);
2107                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2108                                     end_tree);
2109
2110                 if (end_tree == error_mark_node)
2111                   {
2112                     item = *length = error_mark_node;
2113                     break;
2114                   }
2115
2116                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2117                                     ffecom_f2c_ftnlen_one_node,
2118                                     ffecom_2 (MINUS_EXPR,
2119                                               ffecom_f2c_ftnlen_type_node,
2120                                               end_tree, start_tree));
2121               }
2122           }
2123       }
2124       break;
2125
2126     case FFEBLD_opFUNCREF:
2127       {
2128         ffesymbol s = ffebld_symter (ffebld_left (expr));
2129         tree tempvar;
2130         tree args;
2131         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2132         ffecomGfrt ix;
2133
2134         if (size == FFETARGET_charactersizeNONE)
2135           /* ~~Kludge alert!  This should someday be fixed. */
2136           size = 24;
2137
2138         *length = build_int_2 (size, 0);
2139         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2140
2141         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2142             == FFEINFO_whereINTRINSIC)
2143           {
2144             if (size == 1)
2145               {
2146                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2147                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2148                                                NULL, NULL);
2149                 break;
2150               }
2151             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2152             assert (ix != FFECOM_gfrt);
2153             item = ffecom_gfrt_tree_ (ix);
2154           }
2155         else
2156           {
2157             ix = FFECOM_gfrt;
2158             item = ffesymbol_hook (s).decl_tree;
2159             if (item == NULL_TREE)
2160               {
2161                 s = ffecom_sym_transform_ (s);
2162                 item = ffesymbol_hook (s).decl_tree;
2163               }
2164             if (item == error_mark_node)
2165               {
2166                 item = *length = error_mark_node;
2167                 break;
2168               }
2169
2170             if (!ffesymbol_hook (s).addr)
2171               item = ffecom_1_fn (item);
2172           }
2173
2174 #ifdef HOHO
2175         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2176 #else
2177         tempvar = ffebld_nonter_hook (expr);
2178         assert (tempvar);
2179 #endif
2180         tempvar = ffecom_1 (ADDR_EXPR,
2181                             build_pointer_type (TREE_TYPE (tempvar)),
2182                             tempvar);
2183
2184         args = build_tree_list (NULL_TREE, tempvar);
2185
2186         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2187           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2188         else
2189           {
2190             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2191             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2192               {
2193                 TREE_CHAIN (TREE_CHAIN (args))
2194                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2195                                           ffebld_right (expr));
2196               }
2197             else
2198               {
2199                 TREE_CHAIN (TREE_CHAIN (args))
2200                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2201               }
2202           }
2203
2204         item = ffecom_3s (CALL_EXPR,
2205                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2206                           item, args, NULL_TREE);
2207         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2208                          tempvar);
2209       }
2210       break;
2211
2212     case FFEBLD_opCONVERT:
2213
2214       ffecom_char_args_ (&item, length, ffebld_left (expr));
2215
2216       if (item == error_mark_node || *length == error_mark_node)
2217         {
2218           item = *length = error_mark_node;
2219           break;
2220         }
2221
2222       if ((ffebld_size_known (ffebld_left (expr))
2223            == FFETARGET_charactersizeNONE)
2224           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2225         {                       /* Possible blank-padding needed, copy into
2226                                    temporary. */
2227           tree tempvar;
2228           tree args;
2229           tree newlen;
2230
2231 #ifdef HOHO
2232           tempvar = ffecom_make_tempvar (char_type_node,
2233                                          ffebld_size (expr), -1);
2234 #else
2235           tempvar = ffebld_nonter_hook (expr);
2236           assert (tempvar);
2237 #endif
2238           tempvar = ffecom_1 (ADDR_EXPR,
2239                               build_pointer_type (TREE_TYPE (tempvar)),
2240                               tempvar);
2241
2242           newlen = build_int_2 (ffebld_size (expr), 0);
2243           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2244
2245           args = build_tree_list (NULL_TREE, tempvar);
2246           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2247           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2248           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2249             = build_tree_list (NULL_TREE, *length);
2250
2251           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2252           TREE_SIDE_EFFECTS (item) = 1;
2253           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2254                            tempvar);
2255           *length = newlen;
2256         }
2257       else
2258         {                       /* Just truncate the length. */
2259           *length = build_int_2 (ffebld_size (expr), 0);
2260           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2261         }
2262       break;
2263
2264     default:
2265       assert ("bad op for single char arg expr" == NULL);
2266       item = NULL_TREE;
2267       break;
2268     }
2269
2270   *xitem = item;
2271 }
2272 #endif
2273
2274 /* Check the size of the type to be sure it doesn't overflow the
2275    "portable" capacities of the compiler back end.  `dummy' types
2276    can generally overflow the normal sizes as long as the computations
2277    themselves don't overflow.  A particular target of the back end
2278    must still enforce its size requirements, though, and the back
2279    end takes care of this in stor-layout.c.  */
2280
2281 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2282 static tree
2283 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2284 {
2285   if (TREE_CODE (type) == ERROR_MARK)
2286     return type;
2287
2288   if (TYPE_SIZE (type) == NULL_TREE)
2289     return type;
2290
2291   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2292     return type;
2293
2294   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2295       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2296                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2297     {
2298       ffebad_start (FFEBAD_ARRAY_LARGE);
2299       ffebad_string (ffesymbol_text (s));
2300       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2301       ffebad_finish ();
2302
2303       return error_mark_node;
2304     }
2305
2306   return type;
2307 }
2308 #endif
2309
2310 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2311    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2312    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2313
2314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2315 static tree
2316 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2317 {
2318   ffetargetCharacterSize sz = ffesymbol_size (s);
2319   tree highval;
2320   tree tlen;
2321   tree type = *xtype;
2322
2323   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2324     tlen = NULL_TREE;           /* A statement function, no length passed. */
2325   else
2326     {
2327       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2328         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2329                                                ffesymbol_text (s));
2330       else
2331         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2332       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2333 #if BUILT_FOR_270
2334       DECL_ARTIFICIAL (tlen) = 1;
2335 #endif
2336     }
2337
2338   if (sz == FFETARGET_charactersizeNONE)
2339     {
2340       assert (tlen != NULL_TREE);
2341       highval = variable_size (tlen);
2342     }
2343   else
2344     {
2345       highval = build_int_2 (sz, 0);
2346       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2347     }
2348
2349   type = build_array_type (type,
2350                            build_range_type (ffecom_f2c_ftnlen_type_node,
2351                                              ffecom_f2c_ftnlen_one_node,
2352                                              highval));
2353
2354   *xtype = type;
2355   return tlen;
2356 }
2357
2358 #endif
2359 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2360
2361    ffecomConcatList_ catlist;
2362    ffebld expr;  // expr of CHARACTER basictype.
2363    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2364    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2365
2366    Scans expr for character subexpressions, updates and returns catlist
2367    accordingly.  */
2368
2369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2370 static ffecomConcatList_
2371 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2372                             ffetargetCharacterSize max)
2373 {
2374   ffetargetCharacterSize sz;
2375
2376 recurse:                        /* :::::::::::::::::::: */
2377
2378   if (expr == NULL)
2379     return catlist;
2380
2381   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2382     return catlist;             /* Don't append any more items. */
2383
2384   switch (ffebld_op (expr))
2385     {
2386     case FFEBLD_opCONTER:
2387     case FFEBLD_opSYMTER:
2388     case FFEBLD_opARRAYREF:
2389     case FFEBLD_opFUNCREF:
2390     case FFEBLD_opSUBSTR:
2391     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2392                                    if they don't need to preserve it. */
2393       if (catlist.count == catlist.max)
2394         {                       /* Make a (larger) list. */
2395           ffebld *newx;
2396           int newmax;
2397
2398           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2399           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2400                                 newmax * sizeof (newx[0]));
2401           if (catlist.max != 0)
2402             {
2403               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2404               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2405                               catlist.max * sizeof (newx[0]));
2406             }
2407           catlist.max = newmax;
2408           catlist.exprs = newx;
2409         }
2410       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2411         catlist.minlen += sz;
2412       else
2413         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2414       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2415         catlist.maxlen = sz;
2416       else
2417         catlist.maxlen += sz;
2418       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2419         {                       /* This item overlaps (or is beyond) the end
2420                                    of the destination. */
2421           switch (ffebld_op (expr))
2422             {
2423             case FFEBLD_opCONTER:
2424             case FFEBLD_opSYMTER:
2425             case FFEBLD_opARRAYREF:
2426             case FFEBLD_opFUNCREF:
2427             case FFEBLD_opSUBSTR:
2428               /* ~~Do useful truncations here. */
2429               break;
2430
2431             default:
2432               assert ("op changed or inconsistent switches!" == NULL);
2433               break;
2434             }
2435         }
2436       catlist.exprs[catlist.count++] = expr;
2437       return catlist;
2438
2439     case FFEBLD_opPAREN:
2440       expr = ffebld_left (expr);
2441       goto recurse;             /* :::::::::::::::::::: */
2442
2443     case FFEBLD_opCONCATENATE:
2444       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2445       expr = ffebld_right (expr);
2446       goto recurse;             /* :::::::::::::::::::: */
2447
2448 #if 0                           /* Breaks passing small actual arg to larger
2449                                    dummy arg of sfunc */
2450     case FFEBLD_opCONVERT:
2451       expr = ffebld_left (expr);
2452       {
2453         ffetargetCharacterSize cmax;
2454
2455         cmax = catlist.len + ffebld_size_known (expr);
2456
2457         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2458           max = cmax;
2459       }
2460       goto recurse;             /* :::::::::::::::::::: */
2461 #endif
2462
2463     case FFEBLD_opANY:
2464       return catlist;
2465
2466     default:
2467       assert ("bad op in _gather_" == NULL);
2468       return catlist;
2469     }
2470 }
2471
2472 #endif
2473 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2474
2475    ffecomConcatList_ catlist;
2476    ffecom_concat_list_kill_(catlist);
2477
2478    Anything allocated within the list info is deallocated.  */
2479
2480 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2481 static void
2482 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2483 {
2484   if (catlist.max != 0)
2485     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2486                     catlist.max * sizeof (catlist.exprs[0]));
2487 }
2488
2489 #endif
2490 /* Make list of concatenated string exprs.
2491
2492    Returns a flattened list of concatenated subexpressions given a
2493    tree of such expressions.  */
2494
2495 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2496 static ffecomConcatList_
2497 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2498 {
2499   ffecomConcatList_ catlist;
2500
2501   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2502   return ffecom_concat_list_gather_ (catlist, expr, max);
2503 }
2504
2505 #endif
2506
2507 /* Provide some kind of useful info on member of aggregate area,
2508    since current g77/gcc technology does not provide debug info
2509    on these members.  */
2510
2511 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2512 static void
2513 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2514                       tree member_type UNUSED, ffetargetOffset offset)
2515 {
2516   tree value;
2517   tree decl;
2518   int len;
2519   char *buff;
2520   char space[120];
2521 #if 0
2522   tree type_id;
2523
2524   for (type_id = member_type;
2525        TREE_CODE (type_id) != IDENTIFIER_NODE;
2526        )
2527     {
2528       switch (TREE_CODE (type_id))
2529         {
2530         case INTEGER_TYPE:
2531         case REAL_TYPE:
2532           type_id = TYPE_NAME (type_id);
2533           break;
2534
2535         case ARRAY_TYPE:
2536         case COMPLEX_TYPE:
2537           type_id = TREE_TYPE (type_id);
2538           break;
2539
2540         default:
2541           assert ("no IDENTIFIER_NODE for type!" == NULL);
2542           type_id = error_mark_node;
2543           break;
2544         }
2545     }
2546 #endif
2547
2548   if (ffecom_transform_only_dummies_
2549       || !ffe_is_debug_kludge ())
2550     return;     /* Can't do this yet, maybe later. */
2551
2552   len = 60
2553     + strlen (aggr_type)
2554     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2555 #if 0
2556     + IDENTIFIER_LENGTH (type_id);
2557 #endif
2558
2559   if (((size_t) len) >= ARRAY_SIZE (space))
2560     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2561   else
2562     buff = &space[0];
2563
2564   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2565            aggr_type,
2566            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2567            (long int) offset);
2568
2569   value = build_string (len, buff);
2570   TREE_TYPE (value)
2571     = build_type_variant (build_array_type (char_type_node,
2572                                             build_range_type
2573                                             (integer_type_node,
2574                                              integer_one_node,
2575                                              build_int_2 (strlen (buff), 0))),
2576                           1, 0);
2577   decl = build_decl (VAR_DECL,
2578                      ffecom_get_identifier_ (ffesymbol_text (member)),
2579                      TREE_TYPE (value));
2580   TREE_CONSTANT (decl) = 1;
2581   TREE_STATIC (decl) = 1;
2582   DECL_INITIAL (decl) = error_mark_node;
2583   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2584   decl = start_decl (decl, FALSE);
2585   finish_decl (decl, value, FALSE);
2586
2587   if (buff != &space[0])
2588     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2589 }
2590 #endif
2591
2592 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2593
2594    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2595    int i;  // entry# for this entrypoint (used by master fn)
2596    ffecom_do_entrypoint_(s,i);
2597
2598    Makes a public entry point that calls our private master fn (already
2599    compiled).  */
2600
2601 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2602 static void
2603 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2604 {
2605   ffebld item;
2606   tree type;                    /* Type of function. */
2607   tree multi_retval;            /* Var holding return value (union). */
2608   tree result;                  /* Var holding result. */
2609   ffeinfoBasictype bt;
2610   ffeinfoKindtype kt;
2611   ffeglobal g;
2612   ffeglobalType gt;
2613   bool charfunc;                /* All entry points return same type
2614                                    CHARACTER. */
2615   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2616   bool multi;                   /* Master fn has multiple return types. */
2617   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2618   int old_lineno = lineno;
2619   const char *old_input_filename = input_filename;
2620
2621   input_filename = ffesymbol_where_filename (fn);
2622   lineno = ffesymbol_where_filelinenum (fn);
2623
2624   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2625
2626   switch (ffecom_primary_entry_kind_)
2627     {
2628     case FFEINFO_kindFUNCTION:
2629
2630       /* Determine actual return type for function. */
2631
2632       gt = FFEGLOBAL_typeFUNC;
2633       bt = ffesymbol_basictype (fn);
2634       kt = ffesymbol_kindtype (fn);
2635       if (bt == FFEINFO_basictypeNONE)
2636         {
2637           ffeimplic_establish_symbol (fn);
2638           if (ffesymbol_funcresult (fn) != NULL)
2639             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2640           bt = ffesymbol_basictype (fn);
2641           kt = ffesymbol_kindtype (fn);
2642         }
2643
2644       if (bt == FFEINFO_basictypeCHARACTER)
2645         charfunc = TRUE, cmplxfunc = FALSE;
2646       else if ((bt == FFEINFO_basictypeCOMPLEX)
2647                && ffesymbol_is_f2c (fn))
2648         charfunc = FALSE, cmplxfunc = TRUE;
2649       else
2650         charfunc = cmplxfunc = FALSE;
2651
2652       if (charfunc)
2653         type = ffecom_tree_fun_type_void;
2654       else if (ffesymbol_is_f2c (fn))
2655         type = ffecom_tree_fun_type[bt][kt];
2656       else
2657         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2658
2659       if ((type == NULL_TREE)
2660           || (TREE_TYPE (type) == NULL_TREE))
2661         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2662
2663       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2664       break;
2665
2666     case FFEINFO_kindSUBROUTINE:
2667       gt = FFEGLOBAL_typeSUBR;
2668       bt = FFEINFO_basictypeNONE;
2669       kt = FFEINFO_kindtypeNONE;
2670       if (ffecom_is_altreturning_)
2671         {                       /* Am _I_ altreturning? */
2672           for (item = ffesymbol_dummyargs (fn);
2673                item != NULL;
2674                item = ffebld_trail (item))
2675             {
2676               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2677                 {
2678                   altreturning = TRUE;
2679                   break;
2680                 }
2681             }
2682           if (altreturning)
2683             type = ffecom_tree_subr_type;
2684           else
2685             type = ffecom_tree_fun_type_void;
2686         }
2687       else
2688         type = ffecom_tree_fun_type_void;
2689       charfunc = FALSE;
2690       cmplxfunc = FALSE;
2691       multi = FALSE;
2692       break;
2693
2694     default:
2695       assert ("say what??" == NULL);
2696       /* Fall through. */
2697     case FFEINFO_kindANY:
2698       gt = FFEGLOBAL_typeANY;
2699       bt = FFEINFO_basictypeNONE;
2700       kt = FFEINFO_kindtypeNONE;
2701       type = error_mark_node;
2702       charfunc = FALSE;
2703       cmplxfunc = FALSE;
2704       multi = FALSE;
2705       break;
2706     }
2707
2708   /* build_decl uses the current lineno and input_filename to set the decl
2709      source info.  So, I've putzed with ffestd and ffeste code to update that
2710      source info to point to the appropriate statement just before calling
2711      ffecom_do_entrypoint (which calls this fn).  */
2712
2713   start_function (ffecom_get_external_identifier_ (fn),
2714                   type,
2715                   0,            /* nested/inline */
2716                   1);           /* TREE_PUBLIC */
2717
2718   if (((g = ffesymbol_global (fn)) != NULL)
2719       && ((ffeglobal_type (g) == gt)
2720           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2721     {
2722       ffeglobal_set_hook (g, current_function_decl);
2723     }
2724
2725   /* Reset args in master arg list so they get retransitioned. */
2726
2727   for (item = ffecom_master_arglist_;
2728        item != NULL;
2729        item = ffebld_trail (item))
2730     {
2731       ffebld arg;
2732       ffesymbol s;
2733
2734       arg = ffebld_head (item);
2735       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2736         continue;               /* Alternate return or some such thing. */
2737       s = ffebld_symter (arg);
2738       ffesymbol_hook (s).decl_tree = NULL_TREE;
2739       ffesymbol_hook (s).length_tree = NULL_TREE;
2740     }
2741
2742   /* Build dummy arg list for this entry point. */
2743
2744   if (charfunc || cmplxfunc)
2745     {                           /* Prepend arg for where result goes. */
2746       tree type;
2747       tree length;
2748
2749       if (charfunc)
2750         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2751       else
2752         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2753
2754       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2755
2756       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2757
2758       if (charfunc)
2759         length = ffecom_char_enhance_arg_ (&type, fn);
2760       else
2761         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2762
2763       type = build_pointer_type (type);
2764       result = build_decl (PARM_DECL, result, type);
2765
2766       push_parm_decl (result);
2767       ffecom_func_result_ = result;
2768
2769       if (charfunc)
2770         {
2771           push_parm_decl (length);
2772           ffecom_func_length_ = length;
2773         }
2774     }
2775   else
2776     result = DECL_RESULT (current_function_decl);
2777
2778   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2779
2780   store_parm_decls (0);
2781
2782   ffecom_start_compstmt ();
2783   /* Disallow temp vars at this level.  */
2784   current_binding_level->prep_state = 2;
2785
2786   /* Make local var to hold return type for multi-type master fn. */
2787
2788   if (multi)
2789     {
2790       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2791                                                      "multi_retval");
2792       multi_retval = build_decl (VAR_DECL, multi_retval,
2793                                  ffecom_multi_type_node_);
2794       multi_retval = start_decl (multi_retval, FALSE);
2795       finish_decl (multi_retval, NULL_TREE, FALSE);
2796     }
2797   else
2798     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2799
2800   /* Here we emit the actual code for the entry point. */
2801
2802   {
2803     ffebld list;
2804     ffebld arg;
2805     ffesymbol s;
2806     tree arglist = NULL_TREE;
2807     tree *plist = &arglist;
2808     tree prepend;
2809     tree call;
2810     tree actarg;
2811     tree master_fn;
2812
2813     /* Prepare actual arg list based on master arg list. */
2814
2815     for (list = ffecom_master_arglist_;
2816          list != NULL;
2817          list = ffebld_trail (list))
2818       {
2819         arg = ffebld_head (list);
2820         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2821           continue;
2822         s = ffebld_symter (arg);
2823         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2824             || ffesymbol_hook (s).decl_tree == error_mark_node)
2825           actarg = null_pointer_node;   /* We don't have this arg. */
2826         else
2827           actarg = ffesymbol_hook (s).decl_tree;
2828         *plist = build_tree_list (NULL_TREE, actarg);
2829         plist = &TREE_CHAIN (*plist);
2830       }
2831
2832     /* This code appends the length arguments for character
2833        variables/arrays.  */
2834
2835     for (list = ffecom_master_arglist_;
2836          list != NULL;
2837          list = ffebld_trail (list))
2838       {
2839         arg = ffebld_head (list);
2840         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2841           continue;
2842         s = ffebld_symter (arg);
2843         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2844           continue;             /* Only looking for CHARACTER arguments. */
2845         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2846           continue;             /* Only looking for variables and arrays. */
2847         if (ffesymbol_hook (s).length_tree == NULL_TREE
2848             || ffesymbol_hook (s).length_tree == error_mark_node)
2849           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2850         else
2851           actarg = ffesymbol_hook (s).length_tree;
2852         *plist = build_tree_list (NULL_TREE, actarg);
2853         plist = &TREE_CHAIN (*plist);
2854       }
2855
2856     /* Prepend character-value return info to actual arg list. */
2857
2858     if (charfunc)
2859       {
2860         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2861         TREE_CHAIN (prepend)
2862           = build_tree_list (NULL_TREE, ffecom_func_length_);
2863         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2864         arglist = prepend;
2865       }
2866
2867     /* Prepend multi-type return value to actual arg list. */
2868
2869     if (multi)
2870       {
2871         prepend
2872           = build_tree_list (NULL_TREE,
2873                              ffecom_1 (ADDR_EXPR,
2874                               build_pointer_type (TREE_TYPE (multi_retval)),
2875                                        multi_retval));
2876         TREE_CHAIN (prepend) = arglist;
2877         arglist = prepend;
2878       }
2879
2880     /* Prepend my entry-point number to the actual arg list. */
2881
2882     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2883     TREE_CHAIN (prepend) = arglist;
2884     arglist = prepend;
2885
2886     /* Build the call to the master function. */
2887
2888     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2889     call = ffecom_3s (CALL_EXPR,
2890                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2891                       master_fn, arglist, NULL_TREE);
2892
2893     /* Decide whether the master function is a function or subroutine, and
2894        handle the return value for my entry point. */
2895
2896     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2897                      && !altreturning))
2898       {
2899         expand_expr_stmt (call);
2900         expand_null_return ();
2901       }
2902     else if (multi && cmplxfunc)
2903       {
2904         expand_expr_stmt (call);
2905         result
2906           = ffecom_1 (INDIRECT_REF,
2907                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2908                       result);
2909         result = ffecom_modify (NULL_TREE, result,
2910                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2911                                           multi_retval,
2912                                           ffecom_multi_fields_[bt][kt]));
2913         expand_expr_stmt (result);
2914         expand_null_return ();
2915       }
2916     else if (multi)
2917       {
2918         expand_expr_stmt (call);
2919         result
2920           = ffecom_modify (NULL_TREE, result,
2921                            convert (TREE_TYPE (result),
2922                                     ffecom_2 (COMPONENT_REF,
2923                                               ffecom_tree_type[bt][kt],
2924                                               multi_retval,
2925                                               ffecom_multi_fields_[bt][kt])));
2926         expand_return (result);
2927       }
2928     else if (cmplxfunc)
2929       {
2930         result
2931           = ffecom_1 (INDIRECT_REF,
2932                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2933                       result);
2934         result = ffecom_modify (NULL_TREE, result, call);
2935         expand_expr_stmt (result);
2936         expand_null_return ();
2937       }
2938     else
2939       {
2940         result = ffecom_modify (NULL_TREE,
2941                                 result,
2942                                 convert (TREE_TYPE (result),
2943                                          call));
2944         expand_return (result);
2945       }
2946   }
2947
2948   ffecom_end_compstmt ();
2949
2950   finish_function (0);
2951
2952   lineno = old_lineno;
2953   input_filename = old_input_filename;
2954
2955   ffecom_doing_entry_ = FALSE;
2956 }
2957
2958 #endif
2959 /* Transform expr into gcc tree with possible destination
2960
2961    Recursive descent on expr while making corresponding tree nodes and
2962    attaching type info and such.  If destination supplied and compatible
2963    with temporary that would be made in certain cases, temporary isn't
2964    made, destination used instead, and dest_used flag set TRUE.  */
2965
2966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2967 static tree
2968 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2969               bool *dest_used, bool assignp, bool widenp)
2970 {
2971   tree item;
2972   tree list;
2973   tree args;
2974   ffeinfoBasictype bt;
2975   ffeinfoKindtype kt;
2976   tree t;
2977   tree dt;                      /* decl_tree for an ffesymbol. */
2978   tree tree_type, tree_type_x;
2979   tree left, right;
2980   ffesymbol s;
2981   enum tree_code code;
2982
2983   assert (expr != NULL);
2984
2985   if (dest_used != NULL)
2986     *dest_used = FALSE;
2987
2988   bt = ffeinfo_basictype (ffebld_info (expr));
2989   kt = ffeinfo_kindtype (ffebld_info (expr));
2990   tree_type = ffecom_tree_type[bt][kt];
2991
2992   /* Widen integral arithmetic as desired while preserving signedness.  */
2993   tree_type_x = NULL_TREE;
2994   if (widenp && tree_type
2995       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2996       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2997     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2998
2999   switch (ffebld_op (expr))
3000     {
3001     case FFEBLD_opACCTER:
3002       {
3003         ffebitCount i;
3004         ffebit bits = ffebld_accter_bits (expr);
3005         ffetargetOffset source_offset = 0;
3006         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3007         tree purpose;
3008
3009         assert (dest_offset == 0
3010                 || (bt == FFEINFO_basictypeCHARACTER
3011                     && kt == FFEINFO_kindtypeCHARACTER1));
3012
3013         list = item = NULL;
3014         for (;;)
3015           {
3016             ffebldConstantUnion cu;
3017             ffebitCount length;
3018             bool value;
3019             ffebldConstantArray ca = ffebld_accter (expr);
3020
3021             ffebit_test (bits, source_offset, &value, &length);
3022             if (length == 0)
3023               break;
3024
3025             if (value)
3026               {
3027                 for (i = 0; i < length; ++i)
3028                   {
3029                     cu = ffebld_constantarray_get (ca, bt, kt,
3030                                                    source_offset + i);
3031
3032                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3033
3034                     if (i == 0
3035                         && dest_offset != 0)
3036                       purpose = build_int_2 (dest_offset, 0);
3037                     else
3038                       purpose = NULL_TREE;
3039
3040                     if (list == NULL_TREE)
3041                       list = item = build_tree_list (purpose, t);
3042                     else
3043                       {
3044                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3045                         item = TREE_CHAIN (item);
3046                       }
3047                   }
3048               }
3049             source_offset += length;
3050             dest_offset += length;
3051           }
3052       }
3053
3054       item = build_int_2 ((ffebld_accter_size (expr)
3055                            + ffebld_accter_pad (expr)) - 1, 0);
3056       ffebit_kill (ffebld_accter_bits (expr));
3057       TREE_TYPE (item) = ffecom_integer_type_node;
3058       item
3059         = build_array_type
3060           (tree_type,
3061            build_range_type (ffecom_integer_type_node,
3062                              ffecom_integer_zero_node,
3063                              item));
3064       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3065       TREE_CONSTANT (list) = 1;
3066       TREE_STATIC (list) = 1;
3067       return list;
3068
3069     case FFEBLD_opARRTER:
3070       {
3071         ffetargetOffset i;
3072
3073         list = NULL_TREE;
3074         if (ffebld_arrter_pad (expr) == 0)
3075           item = NULL_TREE;
3076         else
3077           {
3078             assert (bt == FFEINFO_basictypeCHARACTER
3079                     && kt == FFEINFO_kindtypeCHARACTER1);
3080
3081             /* Becomes PURPOSE first time through loop.  */
3082             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3083           }
3084
3085         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3086           {
3087             ffebldConstantUnion cu
3088             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3089
3090             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3091
3092             if (list == NULL_TREE)
3093               /* Assume item is PURPOSE first time through loop.  */
3094               list = item = build_tree_list (item, t);
3095             else
3096               {
3097                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3098                 item = TREE_CHAIN (item);
3099               }
3100           }
3101       }
3102
3103       item = build_int_2 ((ffebld_arrter_size (expr)
3104                           + ffebld_arrter_pad (expr)) - 1, 0);
3105       TREE_TYPE (item) = ffecom_integer_type_node;
3106       item
3107         = build_array_type
3108           (tree_type,
3109            build_range_type (ffecom_integer_type_node,
3110                              ffecom_integer_zero_node,
3111                              item));
3112       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3113       TREE_CONSTANT (list) = 1;
3114       TREE_STATIC (list) = 1;
3115       return list;
3116
3117     case FFEBLD_opCONTER:
3118       assert (ffebld_conter_pad (expr) == 0);
3119       item
3120         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3121                                 bt, kt, tree_type);
3122       return item;
3123
3124     case FFEBLD_opSYMTER:
3125       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3126           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3127         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3128       s = ffebld_symter (expr);
3129       t = ffesymbol_hook (s).decl_tree;
3130
3131       if (assignp)
3132         {                       /* ASSIGN'ed-label expr. */
3133           if (ffe_is_ugly_assign ())
3134             {
3135               /* User explicitly wants ASSIGN'ed variables to be at the same
3136                  memory address as the variables when used in non-ASSIGN
3137                  contexts.  That can make old, arcane, non-standard code
3138                  work, but don't try to do it when a pointer wouldn't fit
3139                  in the normal variable (take other approach, and warn,
3140                  instead).  */
3141
3142               if (t == NULL_TREE)
3143                 {
3144                   s = ffecom_sym_transform_ (s);
3145                   t = ffesymbol_hook (s).decl_tree;
3146                   assert (t != NULL_TREE);
3147                 }
3148
3149               if (t == error_mark_node)
3150                 return t;
3151
3152               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3153                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3154                 {
3155                   if (ffesymbol_hook (s).addr)
3156                     t = ffecom_1 (INDIRECT_REF,
3157                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3158                   return t;
3159                 }
3160
3161               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3162                 {
3163                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3164                                     FFEBAD_severityWARNING);
3165                   ffebad_string (ffesymbol_text (s));
3166                   ffebad_here (0, ffesymbol_where_line (s),
3167                                ffesymbol_where_column (s));
3168                   ffebad_finish ();
3169                 }
3170             }
3171
3172           /* Don't use the normal variable's tree for ASSIGN, though mark
3173              it as in the system header (housekeeping).  Use an explicit,
3174              specially created sibling that is known to be wide enough
3175              to hold pointers to labels.  */
3176
3177           if (t != NULL_TREE
3178               && TREE_CODE (t) == VAR_DECL)
3179             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3180
3181           t = ffesymbol_hook (s).assign_tree;
3182           if (t == NULL_TREE)
3183             {
3184               s = ffecom_sym_transform_assign_ (s);
3185               t = ffesymbol_hook (s).assign_tree;
3186               assert (t != NULL_TREE);
3187             }
3188         }
3189       else
3190         {
3191           if (t == NULL_TREE)
3192             {
3193               s = ffecom_sym_transform_ (s);
3194               t = ffesymbol_hook (s).decl_tree;
3195               assert (t != NULL_TREE);
3196             }
3197           if (ffesymbol_hook (s).addr)
3198             t = ffecom_1 (INDIRECT_REF,
3199                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3200         }
3201       return t;
3202
3203     case FFEBLD_opARRAYREF:
3204       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3205
3206     case FFEBLD_opUPLUS:
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_opPAREN:
3211       /* ~~~Make sure Fortran rules respected here */
3212       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3213       return ffecom_1 (NOP_EXPR, tree_type, left);
3214
3215     case FFEBLD_opUMINUS:
3216       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3217       if (tree_type_x)
3218         {
3219           tree_type = tree_type_x;
3220           left = convert (tree_type, left);
3221         }
3222       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3223
3224     case FFEBLD_opADD:
3225       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3226       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3227       if (tree_type_x)
3228         {
3229           tree_type = tree_type_x;
3230           left = convert (tree_type, left);
3231           right = convert (tree_type, right);
3232         }
3233       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3234
3235     case FFEBLD_opSUBTRACT:
3236       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3237       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3238       if (tree_type_x)
3239         {
3240           tree_type = tree_type_x;
3241           left = convert (tree_type, left);
3242           right = convert (tree_type, right);
3243         }
3244       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3245
3246     case FFEBLD_opMULTIPLY:
3247       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3248       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3249       if (tree_type_x)
3250         {
3251           tree_type = tree_type_x;
3252           left = convert (tree_type, left);
3253           right = convert (tree_type, right);
3254         }
3255       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3256
3257     case FFEBLD_opDIVIDE:
3258       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3259       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3260       if (tree_type_x)
3261         {
3262           tree_type = tree_type_x;
3263           left = convert (tree_type, left);
3264           right = convert (tree_type, right);
3265         }
3266       return ffecom_tree_divide_ (tree_type, left, right,
3267                                   dest_tree, dest, dest_used,
3268                                   ffebld_nonter_hook (expr));
3269
3270     case FFEBLD_opPOWER:
3271       {
3272         ffebld left = ffebld_left (expr);
3273         ffebld right = ffebld_right (expr);
3274         ffecomGfrt code;
3275         ffeinfoKindtype rtkt;
3276         ffeinfoKindtype ltkt;
3277         bool ref = TRUE;
3278
3279         switch (ffeinfo_basictype (ffebld_info (right)))
3280           {
3281
3282           case FFEINFO_basictypeINTEGER:
3283             if (1 || optimize)
3284               {
3285                 item = ffecom_expr_power_integer_ (expr);
3286                 if (item != NULL_TREE)
3287                   return item;
3288               }
3289
3290             rtkt = FFEINFO_kindtypeINTEGER1;
3291             switch (ffeinfo_basictype (ffebld_info (left)))
3292               {
3293               case FFEINFO_basictypeINTEGER:
3294                 if ((ffeinfo_kindtype (ffebld_info (left))
3295                     == FFEINFO_kindtypeINTEGER4)
3296                     || (ffeinfo_kindtype (ffebld_info (right))
3297                         == FFEINFO_kindtypeINTEGER4))
3298                   {
3299                     code = FFECOM_gfrtPOW_QQ;
3300                     ltkt = FFEINFO_kindtypeINTEGER4;
3301                     rtkt = FFEINFO_kindtypeINTEGER4;
3302                   }
3303                 else
3304                   {
3305                     code = FFECOM_gfrtPOW_II;
3306                     ltkt = FFEINFO_kindtypeINTEGER1;
3307                   }
3308                 break;
3309
3310               case FFEINFO_basictypeREAL:
3311                 if (ffeinfo_kindtype (ffebld_info (left))
3312                     == FFEINFO_kindtypeREAL1)
3313                   {
3314                     code = FFECOM_gfrtPOW_RI;
3315                     ltkt = FFEINFO_kindtypeREAL1;
3316                   }
3317                 else
3318                   {
3319                     code = FFECOM_gfrtPOW_DI;
3320                     ltkt = FFEINFO_kindtypeREAL2;
3321                   }
3322                 break;
3323
3324               case FFEINFO_basictypeCOMPLEX:
3325                 if (ffeinfo_kindtype (ffebld_info (left))
3326                     == FFEINFO_kindtypeREAL1)
3327                   {
3328                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3329                     ltkt = FFEINFO_kindtypeREAL1;
3330                   }
3331                 else
3332                   {
3333                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3334                     ltkt = FFEINFO_kindtypeREAL2;
3335                   }
3336                 break;
3337
3338               default:
3339                 assert ("bad pow_*i" == NULL);
3340                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3341                 ltkt = FFEINFO_kindtypeREAL1;
3342                 break;
3343               }
3344             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3345               left = ffeexpr_convert (left, NULL, NULL,
3346                                       ffeinfo_basictype (ffebld_info (left)),
3347                                       ltkt, 0,
3348                                       FFETARGET_charactersizeNONE,
3349                                       FFEEXPR_contextLET);
3350             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3351               right = ffeexpr_convert (right, NULL, NULL,
3352                                        FFEINFO_basictypeINTEGER,
3353                                        rtkt, 0,
3354                                        FFETARGET_charactersizeNONE,
3355                                        FFEEXPR_contextLET);
3356             break;
3357
3358           case FFEINFO_basictypeREAL:
3359             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3360               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3361                                       FFEINFO_kindtypeREALDOUBLE, 0,
3362                                       FFETARGET_charactersizeNONE,
3363                                       FFEEXPR_contextLET);
3364             if (ffeinfo_kindtype (ffebld_info (right))
3365                 == FFEINFO_kindtypeREAL1)
3366               right = ffeexpr_convert (right, NULL, NULL,
3367                                        FFEINFO_basictypeREAL,
3368                                        FFEINFO_kindtypeREALDOUBLE, 0,
3369                                        FFETARGET_charactersizeNONE,
3370                                        FFEEXPR_contextLET);
3371             /* We used to call FFECOM_gfrtPOW_DD here,
3372                which passes arguments by reference.  */
3373             code = FFECOM_gfrtL_POW;
3374             /* Pass arguments by value. */
3375             ref  = FALSE;
3376             break;
3377
3378           case FFEINFO_basictypeCOMPLEX:
3379             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3380               left = ffeexpr_convert (left, NULL, NULL,
3381                                       FFEINFO_basictypeCOMPLEX,
3382                                       FFEINFO_kindtypeREALDOUBLE, 0,
3383                                       FFETARGET_charactersizeNONE,
3384                                       FFEEXPR_contextLET);
3385             if (ffeinfo_kindtype (ffebld_info (right))
3386                 == FFEINFO_kindtypeREAL1)
3387               right = ffeexpr_convert (right, NULL, NULL,
3388                                        FFEINFO_basictypeCOMPLEX,
3389                                        FFEINFO_kindtypeREALDOUBLE, 0,
3390                                        FFETARGET_charactersizeNONE,
3391                                        FFEEXPR_contextLET);
3392             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3393             ref = TRUE;                 /* Pass arguments by reference. */
3394             break;
3395
3396           default:
3397             assert ("bad pow_x*" == NULL);
3398             code = FFECOM_gfrtPOW_II;
3399             break;
3400           }
3401         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3402                                    ffecom_gfrt_kindtype (code),
3403                                    (ffe_is_f2c_library ()
3404                                     && ffecom_gfrt_complex_[code]),
3405                                    tree_type, left, right,
3406                                    dest_tree, dest, dest_used,
3407                                    NULL_TREE, FALSE, ref,
3408                                    ffebld_nonter_hook (expr));
3409       }
3410
3411     case FFEBLD_opNOT:
3412       switch (bt)
3413         {
3414         case FFEINFO_basictypeLOGICAL:
3415           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3416           return convert (tree_type, item);
3417
3418         case FFEINFO_basictypeINTEGER:
3419           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3420                            ffecom_expr (ffebld_left (expr)));
3421
3422         default:
3423           assert ("NOT bad basictype" == NULL);
3424           /* Fall through. */
3425         case FFEINFO_basictypeANY:
3426           return error_mark_node;
3427         }
3428       break;
3429
3430     case FFEBLD_opFUNCREF:
3431       assert (ffeinfo_basictype (ffebld_info (expr))
3432               != FFEINFO_basictypeCHARACTER);
3433       /* Fall through.   */
3434     case FFEBLD_opSUBRREF:
3435       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3436           == FFEINFO_whereINTRINSIC)
3437         {                       /* Invocation of an intrinsic. */
3438           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3439                                          dest_used);
3440           return item;
3441         }
3442       s = ffebld_symter (ffebld_left (expr));
3443       dt = ffesymbol_hook (s).decl_tree;
3444       if (dt == NULL_TREE)
3445         {
3446           s = ffecom_sym_transform_ (s);
3447           dt = ffesymbol_hook (s).decl_tree;
3448         }
3449       if (dt == error_mark_node)
3450         return dt;
3451
3452       if (ffesymbol_hook (s).addr)
3453         item = dt;
3454       else
3455         item = ffecom_1_fn (dt);
3456
3457       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3458         args = ffecom_list_expr (ffebld_right (expr));
3459       else
3460         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3461
3462       if (args == error_mark_node)
3463         return error_mark_node;
3464
3465       item = ffecom_call_ (item, kt,
3466                            ffesymbol_is_f2c (s)
3467                            && (bt == FFEINFO_basictypeCOMPLEX)
3468                            && (ffesymbol_where (s)
3469                                != FFEINFO_whereCONSTANT),
3470                            tree_type,
3471                            args,
3472                            dest_tree, dest, dest_used,
3473                            error_mark_node, FALSE,
3474                            ffebld_nonter_hook (expr));
3475       TREE_SIDE_EFFECTS (item) = 1;
3476       return item;
3477
3478     case FFEBLD_opAND:
3479       switch (bt)
3480         {
3481         case FFEINFO_basictypeLOGICAL:
3482           item
3483             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3484                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3485                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3486           return convert (tree_type, item);
3487
3488         case FFEINFO_basictypeINTEGER:
3489           return ffecom_2 (BIT_AND_EXPR, tree_type,
3490                            ffecom_expr (ffebld_left (expr)),
3491                            ffecom_expr (ffebld_right (expr)));
3492
3493         default:
3494           assert ("AND bad basictype" == NULL);
3495           /* Fall through. */
3496         case FFEINFO_basictypeANY:
3497           return error_mark_node;
3498         }
3499       break;
3500
3501     case FFEBLD_opOR:
3502       switch (bt)
3503         {
3504         case FFEINFO_basictypeLOGICAL:
3505           item
3506             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3507                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3508                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3509           return convert (tree_type, item);
3510
3511         case FFEINFO_basictypeINTEGER:
3512           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3513                            ffecom_expr (ffebld_left (expr)),
3514                            ffecom_expr (ffebld_right (expr)));
3515
3516         default:
3517           assert ("OR bad basictype" == NULL);
3518           /* Fall through. */
3519         case FFEINFO_basictypeANY:
3520           return error_mark_node;
3521         }
3522       break;
3523
3524     case FFEBLD_opXOR:
3525     case FFEBLD_opNEQV:
3526       switch (bt)
3527         {
3528         case FFEINFO_basictypeLOGICAL:
3529           item
3530             = ffecom_2 (NE_EXPR, integer_type_node,
3531                         ffecom_expr (ffebld_left (expr)),
3532                         ffecom_expr (ffebld_right (expr)));
3533           return convert (tree_type, ffecom_truth_value (item));
3534
3535         case FFEINFO_basictypeINTEGER:
3536           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3537                            ffecom_expr (ffebld_left (expr)),
3538                            ffecom_expr (ffebld_right (expr)));
3539
3540         default:
3541           assert ("XOR/NEQV bad basictype" == NULL);
3542           /* Fall through. */
3543         case FFEINFO_basictypeANY:
3544           return error_mark_node;
3545         }
3546       break;
3547
3548     case FFEBLD_opEQV:
3549       switch (bt)
3550         {
3551         case FFEINFO_basictypeLOGICAL:
3552           item
3553             = ffecom_2 (EQ_EXPR, integer_type_node,
3554                         ffecom_expr (ffebld_left (expr)),
3555                         ffecom_expr (ffebld_right (expr)));
3556           return convert (tree_type, ffecom_truth_value (item));
3557
3558         case FFEINFO_basictypeINTEGER:
3559           return
3560             ffecom_1 (BIT_NOT_EXPR, tree_type,
3561                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3562                                 ffecom_expr (ffebld_left (expr)),
3563                                 ffecom_expr (ffebld_right (expr))));
3564
3565         default:
3566           assert ("EQV bad basictype" == NULL);
3567           /* Fall through. */
3568         case FFEINFO_basictypeANY:
3569           return error_mark_node;
3570         }
3571       break;
3572
3573     case FFEBLD_opCONVERT:
3574       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3575         return error_mark_node;
3576
3577       switch (bt)
3578         {
3579         case FFEINFO_basictypeLOGICAL:
3580         case FFEINFO_basictypeINTEGER:
3581         case FFEINFO_basictypeREAL:
3582           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3583
3584         case FFEINFO_basictypeCOMPLEX:
3585           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3586             {
3587             case FFEINFO_basictypeINTEGER:
3588             case FFEINFO_basictypeLOGICAL:
3589             case FFEINFO_basictypeREAL:
3590               item = ffecom_expr (ffebld_left (expr));
3591               if (item == error_mark_node)
3592                 return error_mark_node;
3593               /* convert() takes care of converting to the subtype first,
3594                  at least in gcc-2.7.2. */
3595               item = convert (tree_type, item);
3596               return item;
3597
3598             case FFEINFO_basictypeCOMPLEX:
3599               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3600
3601             default:
3602               assert ("CONVERT COMPLEX bad basictype" == NULL);
3603               /* Fall through. */
3604             case FFEINFO_basictypeANY:
3605               return error_mark_node;
3606             }
3607           break;
3608
3609         default:
3610           assert ("CONVERT bad basictype" == NULL);
3611           /* Fall through. */
3612         case FFEINFO_basictypeANY:
3613           return error_mark_node;
3614         }
3615       break;
3616
3617     case FFEBLD_opLT:
3618       code = LT_EXPR;
3619       goto relational;          /* :::::::::::::::::::: */
3620
3621     case FFEBLD_opLE:
3622       code = LE_EXPR;
3623       goto relational;          /* :::::::::::::::::::: */
3624
3625     case FFEBLD_opEQ:
3626       code = EQ_EXPR;
3627       goto relational;          /* :::::::::::::::::::: */
3628
3629     case FFEBLD_opNE:
3630       code = NE_EXPR;
3631       goto relational;          /* :::::::::::::::::::: */
3632
3633     case FFEBLD_opGT:
3634       code = GT_EXPR;
3635       goto relational;          /* :::::::::::::::::::: */
3636
3637     case FFEBLD_opGE:
3638       code = GE_EXPR;
3639
3640     relational:         /* :::::::::::::::::::: */
3641       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3642         {
3643         case FFEINFO_basictypeLOGICAL:
3644         case FFEINFO_basictypeINTEGER:
3645         case FFEINFO_basictypeREAL:
3646           item = ffecom_2 (code, integer_type_node,
3647                            ffecom_expr (ffebld_left (expr)),
3648                            ffecom_expr (ffebld_right (expr)));
3649           return convert (tree_type, item);
3650
3651         case FFEINFO_basictypeCOMPLEX:
3652           assert (code == EQ_EXPR || code == NE_EXPR);
3653           {
3654             tree real_type;
3655             tree arg1 = ffecom_expr (ffebld_left (expr));
3656             tree arg2 = ffecom_expr (ffebld_right (expr));
3657
3658             if (arg1 == error_mark_node || arg2 == error_mark_node)
3659               return error_mark_node;
3660
3661             arg1 = ffecom_save_tree (arg1);
3662             arg2 = ffecom_save_tree (arg2);
3663
3664             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3665               {
3666                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3667                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3668               }
3669             else
3670               {
3671                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3672                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3673               }
3674
3675             item
3676               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3677                           ffecom_2 (EQ_EXPR, integer_type_node,
3678                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3679                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3680                           ffecom_2 (EQ_EXPR, integer_type_node,
3681                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3682                                     ffecom_1 (IMAGPART_EXPR, real_type,
3683                                               arg2)));
3684             if (code == EQ_EXPR)
3685               item = ffecom_truth_value (item);
3686             else
3687               item = ffecom_truth_value_invert (item);
3688             return convert (tree_type, item);
3689           }
3690
3691         case FFEINFO_basictypeCHARACTER:
3692           {
3693             ffebld left = ffebld_left (expr);
3694             ffebld right = ffebld_right (expr);
3695             tree left_tree;
3696             tree right_tree;
3697             tree left_length;
3698             tree right_length;
3699
3700             /* f2c run-time functions do the implicit blank-padding for us,
3701                so we don't usually have to implement blank-padding ourselves.
3702                (The exception is when we pass an argument to a separately
3703                compiled statement function -- if we know the arg is not the
3704                same length as the dummy, we must truncate or extend it.  If
3705                we "inline" statement functions, that necessity goes away as
3706                well.)
3707
3708                Strip off the CONVERT operators that blank-pad.  (Truncation by
3709                CONVERT shouldn't happen here, but it can happen in
3710                assignments.) */
3711
3712             while (ffebld_op (left) == FFEBLD_opCONVERT)
3713               left = ffebld_left (left);
3714             while (ffebld_op (right) == FFEBLD_opCONVERT)
3715               right = ffebld_left (right);
3716
3717             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3718             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3719
3720             if (left_tree == error_mark_node || left_length == error_mark_node
3721                 || right_tree == error_mark_node
3722                 || right_length == error_mark_node)
3723               return error_mark_node;
3724
3725             if ((ffebld_size_known (left) == 1)
3726                 && (ffebld_size_known (right) == 1))
3727               {
3728                 left_tree
3729                   = ffecom_1 (INDIRECT_REF,
3730                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3731                               left_tree);
3732                 right_tree
3733                   = ffecom_1 (INDIRECT_REF,
3734                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3735                               right_tree);
3736
3737                 item
3738                   = ffecom_2 (code, integer_type_node,
3739                               ffecom_2 (ARRAY_REF,
3740                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3741                                         left_tree,
3742                                         integer_one_node),
3743                               ffecom_2 (ARRAY_REF,
3744                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3745                                         right_tree,
3746                                         integer_one_node));
3747               }
3748             else
3749               {
3750                 item = build_tree_list (NULL_TREE, left_tree);
3751                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3752                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3753                                                                left_length);
3754                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3755                   = build_tree_list (NULL_TREE, right_length);
3756                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3757                 item = ffecom_2 (code, integer_type_node,
3758                                  item,
3759                                  convert (TREE_TYPE (item),
3760                                           integer_zero_node));
3761               }
3762             item = convert (tree_type, item);
3763           }
3764
3765           return item;
3766
3767         default:
3768           assert ("relational bad basictype" == NULL);
3769           /* Fall through. */
3770         case FFEINFO_basictypeANY:
3771           return error_mark_node;
3772         }
3773       break;
3774
3775     case FFEBLD_opPERCENT_LOC:
3776       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3777       return convert (tree_type, item);
3778
3779     case FFEBLD_opITEM:
3780     case FFEBLD_opSTAR:
3781     case FFEBLD_opBOUNDS:
3782     case FFEBLD_opREPEAT:
3783     case FFEBLD_opLABTER:
3784     case FFEBLD_opLABTOK:
3785     case FFEBLD_opIMPDO:
3786     case FFEBLD_opCONCATENATE:
3787     case FFEBLD_opSUBSTR:
3788     default:
3789       assert ("bad op" == NULL);
3790       /* Fall through. */
3791     case FFEBLD_opANY:
3792       return error_mark_node;
3793     }
3794
3795 #if 1
3796   assert ("didn't think anything got here anymore!!" == NULL);
3797 #else
3798   switch (ffebld_arity (expr))
3799     {
3800     case 2:
3801       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3802       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3803       if (TREE_OPERAND (item, 0) == error_mark_node
3804           || TREE_OPERAND (item, 1) == error_mark_node)
3805         return error_mark_node;
3806       break;
3807
3808     case 1:
3809       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3810       if (TREE_OPERAND (item, 0) == error_mark_node)
3811         return error_mark_node;
3812       break;
3813
3814     default:
3815       break;
3816     }
3817
3818   return fold (item);
3819 #endif
3820 }
3821
3822 #endif
3823 /* Returns the tree that does the intrinsic invocation.
3824
3825    Note: this function applies only to intrinsics returning
3826    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3827    subroutines.  */
3828
3829 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3830 static tree
3831 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3832                         ffebld dest, bool *dest_used)
3833 {
3834   tree expr_tree;
3835   tree saved_expr1;             /* For those who need it. */
3836   tree saved_expr2;             /* For those who need it. */
3837   ffeinfoBasictype bt;
3838   ffeinfoKindtype kt;
3839   tree tree_type;
3840   tree arg1_type;
3841   tree real_type;               /* REAL type corresponding to COMPLEX. */
3842   tree tempvar;
3843   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3844   ffebld arg1;                  /* For handy reference. */
3845   ffebld arg2;
3846   ffebld arg3;
3847   ffeintrinImp codegen_imp;
3848   ffecomGfrt gfrt;
3849
3850   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3851
3852   if (dest_used != NULL)
3853     *dest_used = FALSE;
3854
3855   bt = ffeinfo_basictype (ffebld_info (expr));
3856   kt = ffeinfo_kindtype (ffebld_info (expr));
3857   tree_type = ffecom_tree_type[bt][kt];
3858
3859   if (list != NULL)
3860     {
3861       arg1 = ffebld_head (list);
3862       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3863         return error_mark_node;
3864       if ((list = ffebld_trail (list)) != NULL)
3865         {
3866           arg2 = ffebld_head (list);
3867           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3868             return error_mark_node;
3869           if ((list = ffebld_trail (list)) != NULL)
3870             {
3871               arg3 = ffebld_head (list);
3872               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3873                 return error_mark_node;
3874             }
3875           else
3876             arg3 = NULL;
3877         }
3878       else
3879         arg2 = arg3 = NULL;
3880     }
3881   else
3882     arg1 = arg2 = arg3 = NULL;
3883
3884   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3885      args.  This is used by the MAX/MIN expansions. */
3886
3887   if (arg1 != NULL)
3888     arg1_type = ffecom_tree_type
3889       [ffeinfo_basictype (ffebld_info (arg1))]
3890       [ffeinfo_kindtype (ffebld_info (arg1))];
3891   else
3892     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3893                                    here. */
3894
3895   /* There are several ways for each of the cases in the following switch
3896      statements to exit (from simplest to use to most complicated):
3897
3898      break;  (when expr_tree == NULL)
3899
3900      A standard call is made to the specific intrinsic just as if it had been
3901      passed in as a dummy procedure and called as any old procedure.  This
3902      method can produce slower code but in some cases it's the easiest way for
3903      now.  However, if a (presumably faster) direct call is available,
3904      that is used, so this is the easiest way in many more cases now.
3905
3906      gfrt = FFECOM_gfrtWHATEVER;
3907      break;
3908
3909      gfrt contains the gfrt index of a library function to call, passing the
3910      argument(s) by value rather than by reference.  Used when a more
3911      careful choice of library function is needed than that provided
3912      by the vanilla `break;'.
3913
3914      return expr_tree;
3915
3916      The expr_tree has been completely set up and is ready to be returned
3917      as is.  No further actions are taken.  Use this when the tree is not
3918      in the simple form for one of the arity_n labels.   */
3919
3920   /* For info on how the switch statement cases were written, see the files
3921      enclosed in comments below the switch statement. */
3922
3923   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3924   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3925   if (gfrt == FFECOM_gfrt)
3926     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3927
3928   switch (codegen_imp)
3929     {
3930     case FFEINTRIN_impABS:
3931     case FFEINTRIN_impCABS:
3932     case FFEINTRIN_impCDABS:
3933     case FFEINTRIN_impDABS:
3934     case FFEINTRIN_impIABS:
3935       if (ffeinfo_basictype (ffebld_info (arg1))
3936           == FFEINFO_basictypeCOMPLEX)
3937         {
3938           if (kt == FFEINFO_kindtypeREAL1)
3939             gfrt = FFECOM_gfrtCABS;
3940           else if (kt == FFEINFO_kindtypeREAL2)
3941             gfrt = FFECOM_gfrtCDABS;
3942           break;
3943         }
3944       return ffecom_1 (ABS_EXPR, tree_type,
3945                        convert (tree_type, ffecom_expr (arg1)));
3946
3947     case FFEINTRIN_impACOS:
3948     case FFEINTRIN_impDACOS:
3949       break;
3950
3951     case FFEINTRIN_impAIMAG:
3952     case FFEINTRIN_impDIMAG:
3953     case FFEINTRIN_impIMAGPART:
3954       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3955         arg1_type = TREE_TYPE (arg1_type);
3956       else
3957         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3958
3959       return
3960         convert (tree_type,
3961                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3962                            ffecom_expr (arg1)));
3963
3964     case FFEINTRIN_impAINT:
3965     case FFEINTRIN_impDINT:
3966 #if 0
3967       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3968       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3969 #else /* in the meantime, must use floor to avoid range problems with ints */
3970       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3971       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3972       return
3973         convert (tree_type,
3974                  ffecom_3 (COND_EXPR, double_type_node,
3975                            ffecom_truth_value
3976                            (ffecom_2 (GE_EXPR, integer_type_node,
3977                                       saved_expr1,
3978                                       convert (arg1_type,
3979                                                ffecom_float_zero_))),
3980                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3981                                              build_tree_list (NULL_TREE,
3982                                                   convert (double_type_node,
3983                                                            saved_expr1)),
3984                                              NULL_TREE),
3985                            ffecom_1 (NEGATE_EXPR, double_type_node,
3986                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3987                                                  build_tree_list (NULL_TREE,
3988                                                   convert (double_type_node,
3989                                                       ffecom_1 (NEGATE_EXPR,
3990                                                                 arg1_type,
3991                                                                saved_expr1))),
3992                                                        NULL_TREE)
3993                                      ))
3994                  );
3995 #endif
3996
3997     case FFEINTRIN_impANINT:
3998     case FFEINTRIN_impDNINT:
3999 #if 0                           /* This way of doing it won't handle real
4000                                    numbers of large magnitudes. */
4001       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4002       expr_tree = convert (tree_type,
4003                            convert (integer_type_node,
4004                                     ffecom_3 (COND_EXPR, tree_type,
4005                                               ffecom_truth_value
4006                                               (ffecom_2 (GE_EXPR,
4007                                                          integer_type_node,
4008                                                          saved_expr1,
4009                                                        ffecom_float_zero_)),
4010                                               ffecom_2 (PLUS_EXPR,
4011                                                         tree_type,
4012                                                         saved_expr1,
4013                                                         ffecom_float_half_),
4014                                               ffecom_2 (MINUS_EXPR,
4015                                                         tree_type,
4016                                                         saved_expr1,
4017                                                      ffecom_float_half_))));
4018       return expr_tree;
4019 #else /* So we instead call floor. */
4020       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4021       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4022       return
4023         convert (tree_type,
4024                  ffecom_3 (COND_EXPR, double_type_node,
4025                            ffecom_truth_value
4026                            (ffecom_2 (GE_EXPR, integer_type_node,
4027                                       saved_expr1,
4028                                       convert (arg1_type,
4029                                                ffecom_float_zero_))),
4030                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4031                                              build_tree_list (NULL_TREE,
4032                                                   convert (double_type_node,
4033                                                            ffecom_2 (PLUS_EXPR,
4034                                                                      arg1_type,
4035                                                                      saved_expr1,
4036                                                                      convert (arg1_type,
4037                                                                               ffecom_float_half_)))),
4038                                              NULL_TREE),
4039                            ffecom_1 (NEGATE_EXPR, double_type_node,
4040                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4041                                                        build_tree_list (NULL_TREE,
4042                                                                         convert (double_type_node,
4043                                                                                  ffecom_2 (MINUS_EXPR,
4044                                                                                            arg1_type,
4045                                                                                            convert (arg1_type,
4046                                                                                                     ffecom_float_half_),
4047                                                                                            saved_expr1))),
4048                                                        NULL_TREE))
4049                            )
4050                  );
4051 #endif
4052
4053     case FFEINTRIN_impASIN:
4054     case FFEINTRIN_impDASIN:
4055     case FFEINTRIN_impATAN:
4056     case FFEINTRIN_impDATAN:
4057     case FFEINTRIN_impATAN2:
4058     case FFEINTRIN_impDATAN2:
4059       break;
4060
4061     case FFEINTRIN_impCHAR:
4062     case FFEINTRIN_impACHAR:
4063 #ifdef HOHO
4064       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4065 #else
4066       tempvar = ffebld_nonter_hook (expr);
4067       assert (tempvar);
4068 #endif
4069       {
4070         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4071
4072         expr_tree = ffecom_modify (tmv,
4073                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4074                                              integer_one_node),
4075                                    convert (tmv, ffecom_expr (arg1)));
4076       }
4077       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4078                             expr_tree,
4079                             tempvar);
4080       expr_tree = ffecom_1 (ADDR_EXPR,
4081                             build_pointer_type (TREE_TYPE (expr_tree)),
4082                             expr_tree);
4083       return expr_tree;
4084
4085     case FFEINTRIN_impCMPLX:
4086     case FFEINTRIN_impDCMPLX:
4087       if (arg2 == NULL)
4088         return
4089           convert (tree_type, ffecom_expr (arg1));
4090
4091       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4092       return
4093         ffecom_2 (COMPLEX_EXPR, tree_type,
4094                   convert (real_type, ffecom_expr (arg1)),
4095                   convert (real_type,
4096                            ffecom_expr (arg2)));
4097
4098     case FFEINTRIN_impCOMPLEX:
4099       return
4100         ffecom_2 (COMPLEX_EXPR, tree_type,
4101                   ffecom_expr (arg1),
4102                   ffecom_expr (arg2));
4103
4104     case FFEINTRIN_impCONJG:
4105     case FFEINTRIN_impDCONJG:
4106       {
4107         tree arg1_tree;
4108
4109         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4110         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4111         return
4112           ffecom_2 (COMPLEX_EXPR, tree_type,
4113                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4114                     ffecom_1 (NEGATE_EXPR, real_type,
4115                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4116       }
4117
4118     case FFEINTRIN_impCOS:
4119     case FFEINTRIN_impCCOS:
4120     case FFEINTRIN_impCDCOS:
4121     case FFEINTRIN_impDCOS:
4122       if (bt == FFEINFO_basictypeCOMPLEX)
4123         {
4124           if (kt == FFEINFO_kindtypeREAL1)
4125             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4126           else if (kt == FFEINFO_kindtypeREAL2)
4127             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4128         }
4129       break;
4130
4131     case FFEINTRIN_impCOSH:
4132     case FFEINTRIN_impDCOSH:
4133       break;
4134
4135     case FFEINTRIN_impDBLE:
4136     case FFEINTRIN_impDFLOAT:
4137     case FFEINTRIN_impDREAL:
4138     case FFEINTRIN_impFLOAT:
4139     case FFEINTRIN_impIDINT:
4140     case FFEINTRIN_impIFIX:
4141     case FFEINTRIN_impINT2:
4142     case FFEINTRIN_impINT8:
4143     case FFEINTRIN_impINT:
4144     case FFEINTRIN_impLONG:
4145     case FFEINTRIN_impREAL:
4146     case FFEINTRIN_impSHORT:
4147     case FFEINTRIN_impSNGL:
4148       return convert (tree_type, ffecom_expr (arg1));
4149
4150     case FFEINTRIN_impDIM:
4151     case FFEINTRIN_impDDIM:
4152     case FFEINTRIN_impIDIM:
4153       saved_expr1 = ffecom_save_tree (convert (tree_type,
4154                                                ffecom_expr (arg1)));
4155       saved_expr2 = ffecom_save_tree (convert (tree_type,
4156                                                ffecom_expr (arg2)));
4157       return
4158         ffecom_3 (COND_EXPR, tree_type,
4159                   ffecom_truth_value
4160                   (ffecom_2 (GT_EXPR, integer_type_node,
4161                              saved_expr1,
4162                              saved_expr2)),
4163                   ffecom_2 (MINUS_EXPR, tree_type,
4164                             saved_expr1,
4165                             saved_expr2),
4166                   convert (tree_type, ffecom_float_zero_));
4167
4168     case FFEINTRIN_impDPROD:
4169       return
4170         ffecom_2 (MULT_EXPR, tree_type,
4171                   convert (tree_type, ffecom_expr (arg1)),
4172                   convert (tree_type, ffecom_expr (arg2)));
4173
4174     case FFEINTRIN_impEXP:
4175     case FFEINTRIN_impCDEXP:
4176     case FFEINTRIN_impCEXP:
4177     case FFEINTRIN_impDEXP:
4178       if (bt == FFEINFO_basictypeCOMPLEX)
4179         {
4180           if (kt == FFEINFO_kindtypeREAL1)
4181             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4182           else if (kt == FFEINFO_kindtypeREAL2)
4183             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4184         }
4185       break;
4186
4187     case FFEINTRIN_impICHAR:
4188     case FFEINTRIN_impIACHAR:
4189 #if 0                           /* The simple approach. */
4190       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4191       expr_tree
4192         = ffecom_1 (INDIRECT_REF,
4193                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4194                     expr_tree);
4195       expr_tree
4196         = ffecom_2 (ARRAY_REF,
4197                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4198                     expr_tree,
4199                     integer_one_node);
4200       return convert (tree_type, expr_tree);
4201 #else /* The more interesting (and more optimal) approach. */
4202       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4203       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4204                             saved_expr1,
4205                             expr_tree,
4206                             convert (tree_type, integer_zero_node));
4207       return expr_tree;
4208 #endif
4209
4210     case FFEINTRIN_impINDEX:
4211       break;
4212
4213     case FFEINTRIN_impLEN:
4214 #if 0
4215       break;                                    /* The simple approach. */
4216 #else
4217       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4218 #endif
4219
4220     case FFEINTRIN_impLGE:
4221     case FFEINTRIN_impLGT:
4222     case FFEINTRIN_impLLE:
4223     case FFEINTRIN_impLLT:
4224       break;
4225
4226     case FFEINTRIN_impLOG:
4227     case FFEINTRIN_impALOG:
4228     case FFEINTRIN_impCDLOG:
4229     case FFEINTRIN_impCLOG:
4230     case FFEINTRIN_impDLOG:
4231       if (bt == FFEINFO_basictypeCOMPLEX)
4232         {
4233           if (kt == FFEINFO_kindtypeREAL1)
4234             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4235           else if (kt == FFEINFO_kindtypeREAL2)
4236             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4237         }
4238       break;
4239
4240     case FFEINTRIN_impLOG10:
4241     case FFEINTRIN_impALOG10:
4242     case FFEINTRIN_impDLOG10:
4243       if (gfrt != FFECOM_gfrt)
4244         break;  /* Already picked one, stick with it. */
4245
4246       if (kt == FFEINFO_kindtypeREAL1)
4247         /* We used to call FFECOM_gfrtALOG10 here.  */
4248         gfrt = FFECOM_gfrtL_LOG10;
4249       else if (kt == FFEINFO_kindtypeREAL2)
4250         /* We used to call FFECOM_gfrtDLOG10 here.  */
4251         gfrt = FFECOM_gfrtL_LOG10;
4252       break;
4253
4254     case FFEINTRIN_impMAX:
4255     case FFEINTRIN_impAMAX0:
4256     case FFEINTRIN_impAMAX1:
4257     case FFEINTRIN_impDMAX1:
4258     case FFEINTRIN_impMAX0:
4259     case FFEINTRIN_impMAX1:
4260       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4261         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4262       else
4263         arg1_type = tree_type;
4264       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4265                             convert (arg1_type, ffecom_expr (arg1)),
4266                             convert (arg1_type, ffecom_expr (arg2)));
4267       for (; list != NULL; list = ffebld_trail (list))
4268         {
4269           if ((ffebld_head (list) == NULL)
4270               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4271             continue;
4272           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4273                                 expr_tree,
4274                                 convert (arg1_type,
4275                                          ffecom_expr (ffebld_head (list))));
4276         }
4277       return convert (tree_type, expr_tree);
4278
4279     case FFEINTRIN_impMIN:
4280     case FFEINTRIN_impAMIN0:
4281     case FFEINTRIN_impAMIN1:
4282     case FFEINTRIN_impDMIN1:
4283     case FFEINTRIN_impMIN0:
4284     case FFEINTRIN_impMIN1:
4285       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4286         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4287       else
4288         arg1_type = tree_type;
4289       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4290                             convert (arg1_type, ffecom_expr (arg1)),
4291                             convert (arg1_type, ffecom_expr (arg2)));
4292       for (; list != NULL; list = ffebld_trail (list))
4293         {
4294           if ((ffebld_head (list) == NULL)
4295               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4296             continue;
4297           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4298                                 expr_tree,
4299                                 convert (arg1_type,
4300                                          ffecom_expr (ffebld_head (list))));
4301         }
4302       return convert (tree_type, expr_tree);
4303
4304     case FFEINTRIN_impMOD:
4305     case FFEINTRIN_impAMOD:
4306     case FFEINTRIN_impDMOD:
4307       if (bt != FFEINFO_basictypeREAL)
4308         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4309                          convert (tree_type, ffecom_expr (arg1)),
4310                          convert (tree_type, ffecom_expr (arg2)));
4311
4312       if (kt == FFEINFO_kindtypeREAL1)
4313         /* We used to call FFECOM_gfrtAMOD here.  */
4314         gfrt = FFECOM_gfrtL_FMOD;
4315       else if (kt == FFEINFO_kindtypeREAL2)
4316         /* We used to call FFECOM_gfrtDMOD here.  */
4317         gfrt = FFECOM_gfrtL_FMOD;
4318       break;
4319
4320     case FFEINTRIN_impNINT:
4321     case FFEINTRIN_impIDNINT:
4322 #if 0
4323       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4324       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4325 #else
4326       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4327       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4328       return
4329         convert (ffecom_integer_type_node,
4330                  ffecom_3 (COND_EXPR, arg1_type,
4331                            ffecom_truth_value
4332                            (ffecom_2 (GE_EXPR, integer_type_node,
4333                                       saved_expr1,
4334                                       convert (arg1_type,
4335                                                ffecom_float_zero_))),
4336                            ffecom_2 (PLUS_EXPR, arg1_type,
4337                                      saved_expr1,
4338                                      convert (arg1_type,
4339                                               ffecom_float_half_)),
4340                            ffecom_2 (MINUS_EXPR, arg1_type,
4341                                      saved_expr1,
4342                                      convert (arg1_type,
4343                                               ffecom_float_half_))));
4344 #endif
4345
4346     case FFEINTRIN_impSIGN:
4347     case FFEINTRIN_impDSIGN:
4348     case FFEINTRIN_impISIGN:
4349       {
4350         tree arg2_tree = ffecom_expr (arg2);
4351
4352         saved_expr1
4353           = ffecom_save_tree
4354           (ffecom_1 (ABS_EXPR, tree_type,
4355                      convert (tree_type,
4356                               ffecom_expr (arg1))));
4357         expr_tree
4358           = ffecom_3 (COND_EXPR, tree_type,
4359                       ffecom_truth_value
4360                       (ffecom_2 (GE_EXPR, integer_type_node,
4361                                  arg2_tree,
4362                                  convert (TREE_TYPE (arg2_tree),
4363                                           integer_zero_node))),
4364                       saved_expr1,
4365                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4366         /* Make sure SAVE_EXPRs get referenced early enough. */
4367         expr_tree
4368           = ffecom_2 (COMPOUND_EXPR, tree_type,
4369                       convert (void_type_node, saved_expr1),
4370                       expr_tree);
4371       }
4372       return expr_tree;
4373
4374     case FFEINTRIN_impSIN:
4375     case FFEINTRIN_impCDSIN:
4376     case FFEINTRIN_impCSIN:
4377     case FFEINTRIN_impDSIN:
4378       if (bt == FFEINFO_basictypeCOMPLEX)
4379         {
4380           if (kt == FFEINFO_kindtypeREAL1)
4381             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4382           else if (kt == FFEINFO_kindtypeREAL2)
4383             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4384         }
4385       break;
4386
4387     case FFEINTRIN_impSINH:
4388     case FFEINTRIN_impDSINH:
4389       break;
4390
4391     case FFEINTRIN_impSQRT:
4392     case FFEINTRIN_impCDSQRT:
4393     case FFEINTRIN_impCSQRT:
4394     case FFEINTRIN_impDSQRT:
4395       if (bt == FFEINFO_basictypeCOMPLEX)
4396         {
4397           if (kt == FFEINFO_kindtypeREAL1)
4398             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4399           else if (kt == FFEINFO_kindtypeREAL2)
4400             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4401         }
4402       break;
4403
4404     case FFEINTRIN_impTAN:
4405     case FFEINTRIN_impDTAN:
4406     case FFEINTRIN_impTANH:
4407     case FFEINTRIN_impDTANH:
4408       break;
4409
4410     case FFEINTRIN_impREALPART:
4411       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4412         arg1_type = TREE_TYPE (arg1_type);
4413       else
4414         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4415
4416       return
4417         convert (tree_type,
4418                  ffecom_1 (REALPART_EXPR, arg1_type,
4419                            ffecom_expr (arg1)));
4420
4421     case FFEINTRIN_impIAND:
4422     case FFEINTRIN_impAND:
4423       return ffecom_2 (BIT_AND_EXPR, tree_type,
4424                        convert (tree_type,
4425                                 ffecom_expr (arg1)),
4426                        convert (tree_type,
4427                                 ffecom_expr (arg2)));
4428
4429     case FFEINTRIN_impIOR:
4430     case FFEINTRIN_impOR:
4431       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4432                        convert (tree_type,
4433                                 ffecom_expr (arg1)),
4434                        convert (tree_type,
4435                                 ffecom_expr (arg2)));
4436
4437     case FFEINTRIN_impIEOR:
4438     case FFEINTRIN_impXOR:
4439       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4440                        convert (tree_type,
4441                                 ffecom_expr (arg1)),
4442                        convert (tree_type,
4443                                 ffecom_expr (arg2)));
4444
4445     case FFEINTRIN_impLSHIFT:
4446       return ffecom_2 (LSHIFT_EXPR, tree_type,
4447                        ffecom_expr (arg1),
4448                        convert (integer_type_node,
4449                                 ffecom_expr (arg2)));
4450
4451     case FFEINTRIN_impRSHIFT:
4452       return ffecom_2 (RSHIFT_EXPR, tree_type,
4453                        ffecom_expr (arg1),
4454                        convert (integer_type_node,
4455                                 ffecom_expr (arg2)));
4456
4457     case FFEINTRIN_impNOT:
4458       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4459
4460     case FFEINTRIN_impBIT_SIZE:
4461       return convert (tree_type, TYPE_SIZE (arg1_type));
4462
4463     case FFEINTRIN_impBTEST:
4464       {
4465         ffetargetLogical1 target_true;
4466         ffetargetLogical1 target_false;
4467         tree true_tree;
4468         tree false_tree;
4469
4470         ffetarget_logical1 (&target_true, TRUE);
4471         ffetarget_logical1 (&target_false, FALSE);
4472         if (target_true == 1)
4473           true_tree = convert (tree_type, integer_one_node);
4474         else
4475           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4476         if (target_false == 0)
4477           false_tree = convert (tree_type, integer_zero_node);
4478         else
4479           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4480
4481         return
4482           ffecom_3 (COND_EXPR, tree_type,
4483                     ffecom_truth_value
4484                     (ffecom_2 (EQ_EXPR, integer_type_node,
4485                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4486                                          ffecom_expr (arg1),
4487                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4488                                                    convert (arg1_type,
4489                                                           integer_one_node),
4490                                                    convert (integer_type_node,
4491                                                             ffecom_expr (arg2)))),
4492                                convert (arg1_type,
4493                                         integer_zero_node))),
4494                     false_tree,
4495                     true_tree);
4496       }
4497
4498     case FFEINTRIN_impIBCLR:
4499       return
4500         ffecom_2 (BIT_AND_EXPR, tree_type,
4501                   ffecom_expr (arg1),
4502                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4503                             ffecom_2 (LSHIFT_EXPR, tree_type,
4504                                       convert (tree_type,
4505                                                integer_one_node),
4506                                       convert (integer_type_node,
4507                                                ffecom_expr (arg2)))));
4508
4509     case FFEINTRIN_impIBITS:
4510       {
4511         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4512                                                     ffecom_expr (arg3)));
4513         tree uns_type
4514         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4515
4516         expr_tree
4517           = ffecom_2 (BIT_AND_EXPR, tree_type,
4518                       ffecom_2 (RSHIFT_EXPR, tree_type,
4519                                 ffecom_expr (arg1),
4520                                 convert (integer_type_node,
4521                                          ffecom_expr (arg2))),
4522                       convert (tree_type,
4523                                ffecom_2 (RSHIFT_EXPR, uns_type,
4524                                          ffecom_1 (BIT_NOT_EXPR,
4525                                                    uns_type,
4526                                                    convert (uns_type,
4527                                                         integer_zero_node)),
4528                                          ffecom_2 (MINUS_EXPR,
4529                                                    integer_type_node,
4530                                                    TYPE_SIZE (uns_type),
4531                                                    arg3_tree))));
4532 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4533         expr_tree
4534           = ffecom_3 (COND_EXPR, tree_type,
4535                       ffecom_truth_value
4536                       (ffecom_2 (NE_EXPR, integer_type_node,
4537                                  arg3_tree,
4538                                  integer_zero_node)),
4539                       expr_tree,
4540                       convert (tree_type, integer_zero_node));
4541 #endif
4542       }
4543       return expr_tree;
4544
4545     case FFEINTRIN_impIBSET:
4546       return
4547         ffecom_2 (BIT_IOR_EXPR, tree_type,
4548                   ffecom_expr (arg1),
4549                   ffecom_2 (LSHIFT_EXPR, tree_type,
4550                             convert (tree_type, integer_one_node),
4551                             convert (integer_type_node,
4552                                      ffecom_expr (arg2))));
4553
4554     case FFEINTRIN_impISHFT:
4555       {
4556         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4557         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4558                                                     ffecom_expr (arg2)));
4559         tree uns_type
4560         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4561
4562         expr_tree
4563           = ffecom_3 (COND_EXPR, tree_type,
4564                       ffecom_truth_value
4565                       (ffecom_2 (GE_EXPR, integer_type_node,
4566                                  arg2_tree,
4567                                  integer_zero_node)),
4568                       ffecom_2 (LSHIFT_EXPR, tree_type,
4569                                 arg1_tree,
4570                                 arg2_tree),
4571                       convert (tree_type,
4572                                ffecom_2 (RSHIFT_EXPR, uns_type,
4573                                          convert (uns_type, arg1_tree),
4574                                          ffecom_1 (NEGATE_EXPR,
4575                                                    integer_type_node,
4576                                                    arg2_tree))));
4577 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4578         expr_tree
4579           = ffecom_3 (COND_EXPR, tree_type,
4580                       ffecom_truth_value
4581                       (ffecom_2 (NE_EXPR, integer_type_node,
4582                                  arg2_tree,
4583                                  TYPE_SIZE (uns_type))),
4584                       expr_tree,
4585                       convert (tree_type, integer_zero_node));
4586 #endif
4587         /* Make sure SAVE_EXPRs get referenced early enough. */
4588         expr_tree
4589           = ffecom_2 (COMPOUND_EXPR, tree_type,
4590                       convert (void_type_node, arg1_tree),
4591                       ffecom_2 (COMPOUND_EXPR, tree_type,
4592                                 convert (void_type_node, arg2_tree),
4593                                 expr_tree));
4594       }
4595       return expr_tree;
4596
4597     case FFEINTRIN_impISHFTC:
4598       {
4599         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4600         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4601                                                     ffecom_expr (arg2)));
4602         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4603         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4604         tree shift_neg;
4605         tree shift_pos;
4606         tree mask_arg1;
4607         tree masked_arg1;
4608         tree uns_type
4609         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4610
4611         mask_arg1
4612           = ffecom_2 (LSHIFT_EXPR, tree_type,
4613                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4614                                 convert (tree_type, integer_zero_node)),
4615                       arg3_tree);
4616 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4617         mask_arg1
4618           = ffecom_3 (COND_EXPR, tree_type,
4619                       ffecom_truth_value
4620                       (ffecom_2 (NE_EXPR, integer_type_node,
4621                                  arg3_tree,
4622                                  TYPE_SIZE (uns_type))),
4623                       mask_arg1,
4624                       convert (tree_type, integer_zero_node));
4625 #endif
4626         mask_arg1 = ffecom_save_tree (mask_arg1);
4627         masked_arg1
4628           = ffecom_2 (BIT_AND_EXPR, tree_type,
4629                       arg1_tree,
4630                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4631                                 mask_arg1));
4632         masked_arg1 = ffecom_save_tree (masked_arg1);
4633         shift_neg
4634           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4635                       convert (tree_type,
4636                                ffecom_2 (RSHIFT_EXPR, uns_type,
4637                                          convert (uns_type, masked_arg1),
4638                                          ffecom_1 (NEGATE_EXPR,
4639                                                    integer_type_node,
4640                                                    arg2_tree))),
4641                       ffecom_2 (LSHIFT_EXPR, tree_type,
4642                                 arg1_tree,
4643                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4644                                           arg2_tree,
4645                                           arg3_tree)));
4646         shift_pos
4647           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4648                       ffecom_2 (LSHIFT_EXPR, tree_type,
4649                                 arg1_tree,
4650                                 arg2_tree),
4651                       convert (tree_type,
4652                                ffecom_2 (RSHIFT_EXPR, uns_type,
4653                                          convert (uns_type, masked_arg1),
4654                                          ffecom_2 (MINUS_EXPR,
4655                                                    integer_type_node,
4656                                                    arg3_tree,
4657                                                    arg2_tree))));
4658         expr_tree
4659           = ffecom_3 (COND_EXPR, tree_type,
4660                       ffecom_truth_value
4661                       (ffecom_2 (LT_EXPR, integer_type_node,
4662                                  arg2_tree,
4663                                  integer_zero_node)),
4664                       shift_neg,
4665                       shift_pos);
4666         expr_tree
4667           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4668                       ffecom_2 (BIT_AND_EXPR, tree_type,
4669                                 mask_arg1,
4670                                 arg1_tree),
4671                       ffecom_2 (BIT_AND_EXPR, tree_type,
4672                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4673                                           mask_arg1),
4674                                 expr_tree));
4675         expr_tree
4676           = ffecom_3 (COND_EXPR, tree_type,
4677                       ffecom_truth_value
4678                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4679                                  ffecom_2 (EQ_EXPR, integer_type_node,
4680                                            ffecom_1 (ABS_EXPR,
4681                                                      integer_type_node,
4682                                                      arg2_tree),
4683                                            arg3_tree),
4684                                  ffecom_2 (EQ_EXPR, integer_type_node,
4685                                            arg2_tree,
4686                                            integer_zero_node))),
4687                       arg1_tree,
4688                       expr_tree);
4689         /* Make sure SAVE_EXPRs get referenced early enough. */
4690         expr_tree
4691           = ffecom_2 (COMPOUND_EXPR, tree_type,
4692                       convert (void_type_node, arg1_tree),
4693                       ffecom_2 (COMPOUND_EXPR, tree_type,
4694                                 convert (void_type_node, arg2_tree),
4695                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4696                                           convert (void_type_node,
4697                                                    mask_arg1),
4698                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4699                                                     convert (void_type_node,
4700                                                              masked_arg1),
4701                                                     expr_tree))));
4702         expr_tree
4703           = ffecom_2 (COMPOUND_EXPR, tree_type,
4704                       convert (void_type_node,
4705                                arg3_tree),
4706                       expr_tree);
4707       }
4708       return expr_tree;
4709
4710     case FFEINTRIN_impLOC:
4711       {
4712         tree arg1_tree = ffecom_expr (arg1);
4713
4714         expr_tree
4715           = convert (tree_type,
4716                      ffecom_1 (ADDR_EXPR,
4717                                build_pointer_type (TREE_TYPE (arg1_tree)),
4718                                arg1_tree));
4719       }
4720       return expr_tree;
4721
4722     case FFEINTRIN_impMVBITS:
4723       {
4724         tree arg1_tree;
4725         tree arg2_tree;
4726         tree arg3_tree;
4727         ffebld arg4 = ffebld_head (ffebld_trail (list));
4728         tree arg4_tree;
4729         tree arg4_type;
4730         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4731         tree arg5_tree;
4732         tree prep_arg1;
4733         tree prep_arg4;
4734         tree arg5_plus_arg3;
4735
4736         arg2_tree = convert (integer_type_node,
4737                              ffecom_expr (arg2));
4738         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4739                                                ffecom_expr (arg3)));
4740         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4741         arg4_type = TREE_TYPE (arg4_tree);
4742
4743         arg1_tree = ffecom_save_tree (convert (arg4_type,
4744                                                ffecom_expr (arg1)));
4745
4746         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4747                                                ffecom_expr (arg5)));
4748
4749         prep_arg1
4750           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4751                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4752                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4753                                           arg1_tree,
4754                                           arg2_tree),
4755                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4756                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4757                                                     ffecom_1 (BIT_NOT_EXPR,
4758                                                               arg4_type,
4759                                                               convert
4760                                                               (arg4_type,
4761                                                         integer_zero_node)),
4762                                                     arg3_tree))),
4763                       arg5_tree);
4764         arg5_plus_arg3
4765           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4766                                         arg5_tree,
4767                                         arg3_tree));
4768         prep_arg4
4769           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4770                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4771                                 convert (arg4_type,
4772                                          integer_zero_node)),
4773                       arg5_plus_arg3);
4774 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4775         prep_arg4
4776           = ffecom_3 (COND_EXPR, arg4_type,
4777                       ffecom_truth_value
4778                       (ffecom_2 (NE_EXPR, integer_type_node,
4779                                  arg5_plus_arg3,
4780                                  convert (TREE_TYPE (arg5_plus_arg3),
4781                                           TYPE_SIZE (arg4_type)))),
4782                       prep_arg4,
4783                       convert (arg4_type, integer_zero_node));
4784 #endif
4785         prep_arg4
4786           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4787                       arg4_tree,
4788                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4789                                 prep_arg4,
4790                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4791                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4792                                                     ffecom_1 (BIT_NOT_EXPR,
4793                                                               arg4_type,
4794                                                               convert
4795                                                               (arg4_type,
4796                                                         integer_zero_node)),
4797                                                     arg5_tree))));
4798         prep_arg1
4799           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4800                       prep_arg1,
4801                       prep_arg4);
4802 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4803         prep_arg1
4804           = ffecom_3 (COND_EXPR, arg4_type,
4805                       ffecom_truth_value
4806                       (ffecom_2 (NE_EXPR, integer_type_node,
4807                                  arg3_tree,
4808                                  convert (TREE_TYPE (arg3_tree),
4809                                           integer_zero_node))),
4810                       prep_arg1,
4811                       arg4_tree);
4812         prep_arg1
4813           = ffecom_3 (COND_EXPR, arg4_type,
4814                       ffecom_truth_value
4815                       (ffecom_2 (NE_EXPR, integer_type_node,
4816                                  arg3_tree,
4817                                  convert (TREE_TYPE (arg3_tree),
4818                                           TYPE_SIZE (arg4_type)))),
4819                       prep_arg1,
4820                       arg1_tree);
4821 #endif
4822         expr_tree
4823           = ffecom_2s (MODIFY_EXPR, void_type_node,
4824                        arg4_tree,
4825                        prep_arg1);
4826         /* Make sure SAVE_EXPRs get referenced early enough. */
4827         expr_tree
4828           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4829                       arg1_tree,
4830                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4831                                 arg3_tree,
4832                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4833                                           arg5_tree,
4834                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4835                                                     arg5_plus_arg3,
4836                                                     expr_tree))));
4837         expr_tree
4838           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4839                       arg4_tree,
4840                       expr_tree);
4841
4842       }
4843       return expr_tree;
4844
4845     case FFEINTRIN_impDERF:
4846     case FFEINTRIN_impERF:
4847     case FFEINTRIN_impDERFC:
4848     case FFEINTRIN_impERFC:
4849       break;
4850
4851     case FFEINTRIN_impIARGC:
4852       /* extern int xargc; i__1 = xargc - 1; */
4853       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4854                             ffecom_tree_xargc_,
4855                             convert (TREE_TYPE (ffecom_tree_xargc_),
4856                                      integer_one_node));
4857       return expr_tree;
4858
4859     case FFEINTRIN_impSIGNAL_func:
4860     case FFEINTRIN_impSIGNAL_subr:
4861       {
4862         tree arg1_tree;
4863         tree arg2_tree;
4864         tree arg3_tree;
4865
4866         arg1_tree = convert (ffecom_f2c_integer_type_node,
4867                              ffecom_expr (arg1));
4868         arg1_tree = ffecom_1 (ADDR_EXPR,
4869                               build_pointer_type (TREE_TYPE (arg1_tree)),
4870                               arg1_tree);
4871
4872         /* Pass procedure as a pointer to it, anything else by value.  */
4873         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4874           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4875         else
4876           arg2_tree = ffecom_ptr_to_expr (arg2);
4877         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4878                              arg2_tree);
4879
4880         if (arg3 != NULL)
4881           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4882         else
4883           arg3_tree = NULL_TREE;
4884
4885         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4886         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4887         TREE_CHAIN (arg1_tree) = arg2_tree;
4888
4889         expr_tree
4890           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4891                           ffecom_gfrt_kindtype (gfrt),
4892                           FALSE,
4893                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4894                            NULL_TREE :
4895                            tree_type),
4896                           arg1_tree,
4897                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4898                           ffebld_nonter_hook (expr));
4899
4900         if (arg3_tree != NULL_TREE)
4901           expr_tree
4902             = ffecom_modify (NULL_TREE, arg3_tree,
4903                              convert (TREE_TYPE (arg3_tree),
4904                                       expr_tree));
4905       }
4906       return expr_tree;
4907
4908     case FFEINTRIN_impALARM:
4909       {
4910         tree arg1_tree;
4911         tree arg2_tree;
4912         tree arg3_tree;
4913
4914         arg1_tree = convert (ffecom_f2c_integer_type_node,
4915                              ffecom_expr (arg1));
4916         arg1_tree = ffecom_1 (ADDR_EXPR,
4917                               build_pointer_type (TREE_TYPE (arg1_tree)),
4918                               arg1_tree);
4919
4920         /* Pass procedure as a pointer to it, anything else by value.  */
4921         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4922           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4923         else
4924           arg2_tree = ffecom_ptr_to_expr (arg2);
4925         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4926                              arg2_tree);
4927
4928         if (arg3 != NULL)
4929           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4930         else
4931           arg3_tree = NULL_TREE;
4932
4933         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4934         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4935         TREE_CHAIN (arg1_tree) = arg2_tree;
4936
4937         expr_tree
4938           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4939                           ffecom_gfrt_kindtype (gfrt),
4940                           FALSE,
4941                           NULL_TREE,
4942                           arg1_tree,
4943                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4944                           ffebld_nonter_hook (expr));
4945
4946         if (arg3_tree != NULL_TREE)
4947           expr_tree
4948             = ffecom_modify (NULL_TREE, arg3_tree,
4949                              convert (TREE_TYPE (arg3_tree),
4950                                       expr_tree));
4951       }
4952       return expr_tree;
4953
4954     case FFEINTRIN_impCHDIR_subr:
4955     case FFEINTRIN_impFDATE_subr:
4956     case FFEINTRIN_impFGET_subr:
4957     case FFEINTRIN_impFPUT_subr:
4958     case FFEINTRIN_impGETCWD_subr:
4959     case FFEINTRIN_impHOSTNM_subr:
4960     case FFEINTRIN_impSYSTEM_subr:
4961     case FFEINTRIN_impUNLINK_subr:
4962       {
4963         tree arg1_len = integer_zero_node;
4964         tree arg1_tree;
4965         tree arg2_tree;
4966
4967         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4968
4969         if (arg2 != NULL)
4970           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4971         else
4972           arg2_tree = NULL_TREE;
4973
4974         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4975         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4976         TREE_CHAIN (arg1_tree) = arg1_len;
4977
4978         expr_tree
4979           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4980                           ffecom_gfrt_kindtype (gfrt),
4981                           FALSE,
4982                           NULL_TREE,
4983                           arg1_tree,
4984                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4985                           ffebld_nonter_hook (expr));
4986
4987         if (arg2_tree != NULL_TREE)
4988           expr_tree
4989             = ffecom_modify (NULL_TREE, arg2_tree,
4990                              convert (TREE_TYPE (arg2_tree),
4991                                       expr_tree));
4992       }
4993       return expr_tree;
4994
4995     case FFEINTRIN_impEXIT:
4996       if (arg1 != NULL)
4997         break;
4998
4999       expr_tree = build_tree_list (NULL_TREE,
5000                                    ffecom_1 (ADDR_EXPR,
5001                                              build_pointer_type
5002                                              (ffecom_integer_type_node),
5003                                              integer_zero_node));
5004
5005       return
5006         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5007                       ffecom_gfrt_kindtype (gfrt),
5008                       FALSE,
5009                       void_type_node,
5010                       expr_tree,
5011                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5012                       ffebld_nonter_hook (expr));
5013
5014     case FFEINTRIN_impFLUSH:
5015       if (arg1 == NULL)
5016         gfrt = FFECOM_gfrtFLUSH;
5017       else
5018         gfrt = FFECOM_gfrtFLUSH1;
5019       break;
5020
5021     case FFEINTRIN_impCHMOD_subr:
5022     case FFEINTRIN_impLINK_subr:
5023     case FFEINTRIN_impRENAME_subr:
5024     case FFEINTRIN_impSYMLNK_subr:
5025       {
5026         tree arg1_len = integer_zero_node;
5027         tree arg1_tree;
5028         tree arg2_len = integer_zero_node;
5029         tree arg2_tree;
5030         tree arg3_tree;
5031
5032         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5033         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5034         if (arg3 != NULL)
5035           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5036         else
5037           arg3_tree = NULL_TREE;
5038
5039         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5040         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5041         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5042         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5043         TREE_CHAIN (arg1_tree) = arg2_tree;
5044         TREE_CHAIN (arg2_tree) = arg1_len;
5045         TREE_CHAIN (arg1_len) = arg2_len;
5046         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5047                                   ffecom_gfrt_kindtype (gfrt),
5048                                   FALSE,
5049                                   NULL_TREE,
5050                                   arg1_tree,
5051                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5052                                   ffebld_nonter_hook (expr));
5053         if (arg3_tree != NULL_TREE)
5054           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5055                                      convert (TREE_TYPE (arg3_tree),
5056                                               expr_tree));
5057       }
5058       return expr_tree;
5059
5060     case FFEINTRIN_impLSTAT_subr:
5061     case FFEINTRIN_impSTAT_subr:
5062       {
5063         tree arg1_len = integer_zero_node;
5064         tree arg1_tree;
5065         tree arg2_tree;
5066         tree arg3_tree;
5067
5068         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5069
5070         arg2_tree = ffecom_ptr_to_expr (arg2);
5071
5072         if (arg3 != NULL)
5073           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5074         else
5075           arg3_tree = NULL_TREE;
5076
5077         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5078         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5079         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5080         TREE_CHAIN (arg1_tree) = arg2_tree;
5081         TREE_CHAIN (arg2_tree) = arg1_len;
5082         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5083                                   ffecom_gfrt_kindtype (gfrt),
5084                                   FALSE,
5085                                   NULL_TREE,
5086                                   arg1_tree,
5087                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5088                                   ffebld_nonter_hook (expr));
5089         if (arg3_tree != NULL_TREE)
5090           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5091                                      convert (TREE_TYPE (arg3_tree),
5092                                               expr_tree));
5093       }
5094       return expr_tree;
5095
5096     case FFEINTRIN_impFGETC_subr:
5097     case FFEINTRIN_impFPUTC_subr:
5098       {
5099         tree arg1_tree;
5100         tree arg2_tree;
5101         tree arg2_len = integer_zero_node;
5102         tree arg3_tree;
5103
5104         arg1_tree = convert (ffecom_f2c_integer_type_node,
5105                              ffecom_expr (arg1));
5106         arg1_tree = ffecom_1 (ADDR_EXPR,
5107                               build_pointer_type (TREE_TYPE (arg1_tree)),
5108                               arg1_tree);
5109
5110         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5111         if (arg3 != NULL)
5112           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5113         else
5114           arg3_tree = NULL_TREE;
5115
5116         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5117         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5118         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5119         TREE_CHAIN (arg1_tree) = arg2_tree;
5120         TREE_CHAIN (arg2_tree) = arg2_len;
5121
5122         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5123                                   ffecom_gfrt_kindtype (gfrt),
5124                                   FALSE,
5125                                   NULL_TREE,
5126                                   arg1_tree,
5127                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5128                                   ffebld_nonter_hook (expr));
5129         if (arg3_tree != NULL_TREE)
5130           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5131                                      convert (TREE_TYPE (arg3_tree),
5132                                               expr_tree));
5133       }
5134       return expr_tree;
5135
5136     case FFEINTRIN_impFSTAT_subr:
5137       {
5138         tree arg1_tree;
5139         tree arg2_tree;
5140         tree arg3_tree;
5141
5142         arg1_tree = convert (ffecom_f2c_integer_type_node,
5143                              ffecom_expr (arg1));
5144         arg1_tree = ffecom_1 (ADDR_EXPR,
5145                               build_pointer_type (TREE_TYPE (arg1_tree)),
5146                               arg1_tree);
5147
5148         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5149                              ffecom_ptr_to_expr (arg2));
5150
5151         if (arg3 == NULL)
5152           arg3_tree = NULL_TREE;
5153         else
5154           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5155
5156         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5157         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5158         TREE_CHAIN (arg1_tree) = arg2_tree;
5159         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5160                                   ffecom_gfrt_kindtype (gfrt),
5161                                   FALSE,
5162                                   NULL_TREE,
5163                                   arg1_tree,
5164                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5165                                   ffebld_nonter_hook (expr));
5166         if (arg3_tree != NULL_TREE) {
5167           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5168                                      convert (TREE_TYPE (arg3_tree),
5169                                               expr_tree));
5170         }
5171       }
5172       return expr_tree;
5173
5174     case FFEINTRIN_impKILL_subr:
5175       {
5176         tree arg1_tree;
5177         tree arg2_tree;
5178         tree arg3_tree;
5179
5180         arg1_tree = convert (ffecom_f2c_integer_type_node,
5181                              ffecom_expr (arg1));
5182         arg1_tree = ffecom_1 (ADDR_EXPR,
5183                               build_pointer_type (TREE_TYPE (arg1_tree)),
5184                               arg1_tree);
5185
5186         arg2_tree = convert (ffecom_f2c_integer_type_node,
5187                              ffecom_expr (arg2));
5188         arg2_tree = ffecom_1 (ADDR_EXPR,
5189                               build_pointer_type (TREE_TYPE (arg2_tree)),
5190                               arg2_tree);
5191
5192         if (arg3 == NULL)
5193           arg3_tree = NULL_TREE;
5194         else
5195           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5196
5197         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5198         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5199         TREE_CHAIN (arg1_tree) = arg2_tree;
5200         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5201                                   ffecom_gfrt_kindtype (gfrt),
5202                                   FALSE,
5203                                   NULL_TREE,
5204                                   arg1_tree,
5205                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5206                                   ffebld_nonter_hook (expr));
5207         if (arg3_tree != NULL_TREE) {
5208           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5209                                      convert (TREE_TYPE (arg3_tree),
5210                                               expr_tree));
5211         }
5212       }
5213       return expr_tree;
5214
5215     case FFEINTRIN_impCTIME_subr:
5216     case FFEINTRIN_impTTYNAM_subr:
5217       {
5218         tree arg1_len = integer_zero_node;
5219         tree arg1_tree;
5220         tree arg2_tree;
5221
5222         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5223
5224         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5225                               ffecom_f2c_longint_type_node :
5226                               ffecom_f2c_integer_type_node),
5227                              ffecom_expr (arg1));
5228         arg2_tree = ffecom_1 (ADDR_EXPR,
5229                               build_pointer_type (TREE_TYPE (arg2_tree)),
5230                               arg2_tree);
5231
5232         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5233         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5234         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5235         TREE_CHAIN (arg1_len) = arg2_tree;
5236         TREE_CHAIN (arg1_tree) = arg1_len;
5237
5238         expr_tree
5239           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5240                           ffecom_gfrt_kindtype (gfrt),
5241                           FALSE,
5242                           NULL_TREE,
5243                           arg1_tree,
5244                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5245                           ffebld_nonter_hook (expr));
5246         TREE_SIDE_EFFECTS (expr_tree) = 1;
5247       }
5248       return expr_tree;
5249
5250     case FFEINTRIN_impIRAND:
5251     case FFEINTRIN_impRAND:
5252       /* Arg defaults to 0 (normal random case) */
5253       {
5254         tree arg1_tree;
5255
5256         if (arg1 == NULL)
5257           arg1_tree = ffecom_integer_zero_node;
5258         else
5259           arg1_tree = ffecom_expr (arg1);
5260         arg1_tree = convert (ffecom_f2c_integer_type_node,
5261                              arg1_tree);
5262         arg1_tree = ffecom_1 (ADDR_EXPR,
5263                               build_pointer_type (TREE_TYPE (arg1_tree)),
5264                               arg1_tree);
5265         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5266
5267         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5268                                   ffecom_gfrt_kindtype (gfrt),
5269                                   FALSE,
5270                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5271                                    ffecom_f2c_integer_type_node :
5272                                    ffecom_f2c_real_type_node),
5273                                   arg1_tree,
5274                                   dest_tree, dest, dest_used,
5275                                   NULL_TREE, TRUE,
5276                                   ffebld_nonter_hook (expr));
5277       }
5278       return expr_tree;
5279
5280     case FFEINTRIN_impFTELL_subr:
5281     case FFEINTRIN_impUMASK_subr:
5282       {
5283         tree arg1_tree;
5284         tree arg2_tree;
5285
5286         arg1_tree = convert (ffecom_f2c_integer_type_node,
5287                              ffecom_expr (arg1));
5288         arg1_tree = ffecom_1 (ADDR_EXPR,
5289                               build_pointer_type (TREE_TYPE (arg1_tree)),
5290                               arg1_tree);
5291
5292         if (arg2 == NULL)
5293           arg2_tree = NULL_TREE;
5294         else
5295           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5296
5297         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5298                                   ffecom_gfrt_kindtype (gfrt),
5299                                   FALSE,
5300                                   NULL_TREE,
5301                                   build_tree_list (NULL_TREE, arg1_tree),
5302                                   NULL_TREE, NULL, NULL, NULL_TREE,
5303                                   TRUE,
5304                                   ffebld_nonter_hook (expr));
5305         if (arg2_tree != NULL_TREE) {
5306           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5307                                      convert (TREE_TYPE (arg2_tree),
5308                                               expr_tree));
5309         }
5310       }
5311       return expr_tree;
5312
5313     case FFEINTRIN_impCPU_TIME:
5314     case FFEINTRIN_impSECOND_subr:
5315       {
5316         tree arg1_tree;
5317
5318         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5319
5320         expr_tree
5321           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5322                           ffecom_gfrt_kindtype (gfrt),
5323                           FALSE,
5324                           NULL_TREE,
5325                           NULL_TREE,
5326                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5327                           ffebld_nonter_hook (expr));
5328
5329         expr_tree
5330           = ffecom_modify (NULL_TREE, arg1_tree,
5331                            convert (TREE_TYPE (arg1_tree),
5332                                     expr_tree));
5333       }
5334       return expr_tree;
5335
5336     case FFEINTRIN_impDTIME_subr:
5337     case FFEINTRIN_impETIME_subr:
5338       {
5339         tree arg1_tree;
5340         tree result_tree;
5341
5342         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5343
5344         arg1_tree = ffecom_ptr_to_expr (arg1);
5345
5346         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5347                                   ffecom_gfrt_kindtype (gfrt),
5348                                   FALSE,
5349                                   NULL_TREE,
5350                                   build_tree_list (NULL_TREE, arg1_tree),
5351                                   NULL_TREE, NULL, NULL, NULL_TREE,
5352                                   TRUE,
5353                                   ffebld_nonter_hook (expr));
5354         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5355                                    convert (TREE_TYPE (result_tree),
5356                                             expr_tree));
5357       }
5358       return expr_tree;
5359
5360       /* Straightforward calls of libf2c routines: */
5361     case FFEINTRIN_impABORT:
5362     case FFEINTRIN_impACCESS:
5363     case FFEINTRIN_impBESJ0:
5364     case FFEINTRIN_impBESJ1:
5365     case FFEINTRIN_impBESJN:
5366     case FFEINTRIN_impBESY0:
5367     case FFEINTRIN_impBESY1:
5368     case FFEINTRIN_impBESYN:
5369     case FFEINTRIN_impCHDIR_func:
5370     case FFEINTRIN_impCHMOD_func:
5371     case FFEINTRIN_impDATE:
5372     case FFEINTRIN_impDATE_AND_TIME:
5373     case FFEINTRIN_impDBESJ0:
5374     case FFEINTRIN_impDBESJ1:
5375     case FFEINTRIN_impDBESJN:
5376     case FFEINTRIN_impDBESY0:
5377     case FFEINTRIN_impDBESY1:
5378     case FFEINTRIN_impDBESYN:
5379     case FFEINTRIN_impDTIME_func:
5380     case FFEINTRIN_impETIME_func:
5381     case FFEINTRIN_impFGETC_func:
5382     case FFEINTRIN_impFGET_func:
5383     case FFEINTRIN_impFNUM:
5384     case FFEINTRIN_impFPUTC_func:
5385     case FFEINTRIN_impFPUT_func:
5386     case FFEINTRIN_impFSEEK:
5387     case FFEINTRIN_impFSTAT_func:
5388     case FFEINTRIN_impFTELL_func:
5389     case FFEINTRIN_impGERROR:
5390     case FFEINTRIN_impGETARG:
5391     case FFEINTRIN_impGETCWD_func:
5392     case FFEINTRIN_impGETENV:
5393     case FFEINTRIN_impGETGID:
5394     case FFEINTRIN_impGETLOG:
5395     case FFEINTRIN_impGETPID:
5396     case FFEINTRIN_impGETUID:
5397     case FFEINTRIN_impGMTIME:
5398     case FFEINTRIN_impHOSTNM_func:
5399     case FFEINTRIN_impIDATE_unix:
5400     case FFEINTRIN_impIDATE_vxt:
5401     case FFEINTRIN_impIERRNO:
5402     case FFEINTRIN_impISATTY:
5403     case FFEINTRIN_impITIME:
5404     case FFEINTRIN_impKILL_func:
5405     case FFEINTRIN_impLINK_func:
5406     case FFEINTRIN_impLNBLNK:
5407     case FFEINTRIN_impLSTAT_func:
5408     case FFEINTRIN_impLTIME:
5409     case FFEINTRIN_impMCLOCK8:
5410     case FFEINTRIN_impMCLOCK:
5411     case FFEINTRIN_impPERROR:
5412     case FFEINTRIN_impRENAME_func:
5413     case FFEINTRIN_impSECNDS:
5414     case FFEINTRIN_impSECOND_func:
5415     case FFEINTRIN_impSLEEP:
5416     case FFEINTRIN_impSRAND:
5417     case FFEINTRIN_impSTAT_func:
5418     case FFEINTRIN_impSYMLNK_func:
5419     case FFEINTRIN_impSYSTEM_CLOCK:
5420     case FFEINTRIN_impSYSTEM_func:
5421     case FFEINTRIN_impTIME8:
5422     case FFEINTRIN_impTIME_unix:
5423     case FFEINTRIN_impTIME_vxt:
5424     case FFEINTRIN_impUMASK_func:
5425     case FFEINTRIN_impUNLINK_func:
5426       break;
5427
5428     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5429     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5430     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5431     case FFEINTRIN_impNONE:
5432     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5433       fprintf (stderr, "No %s implementation.\n",
5434                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5435       assert ("unimplemented intrinsic" == NULL);
5436       return error_mark_node;
5437     }
5438
5439   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5440
5441   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5442                                     ffebld_right (expr));
5443
5444   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5445                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5446                        tree_type,
5447                        expr_tree, dest_tree, dest, dest_used,
5448                        NULL_TREE, TRUE,
5449                        ffebld_nonter_hook (expr));
5450
5451   /* See bottom of this file for f2c transforms used to determine
5452      many of the above implementations.  The info seems to confuse
5453      Emacs's C mode indentation, which is why it's been moved to
5454      the bottom of this source file.  */
5455 }
5456
5457 #endif
5458 /* For power (exponentiation) where right-hand operand is type INTEGER,
5459    generate in-line code to do it the fast way (which, if the operand
5460    is a constant, might just mean a series of multiplies).  */
5461
5462 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5463 static tree
5464 ffecom_expr_power_integer_ (ffebld expr)
5465 {
5466   tree l = ffecom_expr (ffebld_left (expr));
5467   tree r = ffecom_expr (ffebld_right (expr));
5468   tree ltype = TREE_TYPE (l);
5469   tree rtype = TREE_TYPE (r);
5470   tree result = NULL_TREE;
5471
5472   if (l == error_mark_node
5473       || r == error_mark_node)
5474     return error_mark_node;
5475
5476   if (TREE_CODE (r) == INTEGER_CST)
5477     {
5478       int sgn = tree_int_cst_sgn (r);
5479
5480       if (sgn == 0)
5481         return convert (ltype, integer_one_node);
5482
5483       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5484           && (sgn < 0))
5485         {
5486           /* Reciprocal of integer is either 0, -1, or 1, so after
5487              calculating that (which we leave to the back end to do
5488              or not do optimally), don't bother with any multiplying.  */
5489
5490           result = ffecom_tree_divide_ (ltype,
5491                                         convert (ltype, integer_one_node),
5492                                         l,
5493                                         NULL_TREE, NULL, NULL, NULL_TREE);
5494           r = ffecom_1 (NEGATE_EXPR,
5495                         rtype,
5496                         r);
5497           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5498             result = ffecom_1 (ABS_EXPR, rtype,
5499                                result);
5500         }
5501
5502       /* Generate appropriate series of multiplies, preceded
5503          by divide if the exponent is negative.  */
5504
5505       l = save_expr (l);
5506
5507       if (sgn < 0)
5508         {
5509           l = ffecom_tree_divide_ (ltype,
5510                                    convert (ltype, integer_one_node),
5511                                    l,
5512                                    NULL_TREE, NULL, NULL,
5513                                    ffebld_nonter_hook (expr));
5514           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5515           assert (TREE_CODE (r) == INTEGER_CST);
5516
5517           if (tree_int_cst_sgn (r) < 0)
5518             {                   /* The "most negative" number.  */
5519               r = ffecom_1 (NEGATE_EXPR, rtype,
5520                             ffecom_2 (RSHIFT_EXPR, rtype,
5521                                       r,
5522                                       integer_one_node));
5523               l = save_expr (l);
5524               l = ffecom_2 (MULT_EXPR, ltype,
5525                             l,
5526                             l);
5527             }
5528         }
5529
5530       for (;;)
5531         {
5532           if (TREE_INT_CST_LOW (r) & 1)
5533             {
5534               if (result == NULL_TREE)
5535                 result = l;
5536               else
5537                 result = ffecom_2 (MULT_EXPR, ltype,
5538                                    result,
5539                                    l);
5540             }
5541
5542           r = ffecom_2 (RSHIFT_EXPR, rtype,
5543                         r,
5544                         integer_one_node);
5545           if (integer_zerop (r))
5546             break;
5547           assert (TREE_CODE (r) == INTEGER_CST);
5548
5549           l = save_expr (l);
5550           l = ffecom_2 (MULT_EXPR, ltype,
5551                         l,
5552                         l);
5553         }
5554       return result;
5555     }
5556
5557   /* Though rhs isn't a constant, in-line code cannot be expanded
5558      while transforming dummies
5559      because the back end cannot be easily convinced to generate
5560      stores (MODIFY_EXPR), handle temporaries, and so on before
5561      all the appropriate rtx's have been generated for things like
5562      dummy args referenced in rhs -- which doesn't happen until
5563      store_parm_decls() is called (expand_function_start, I believe,
5564      does the actual rtx-stuffing of PARM_DECLs).
5565
5566      So, in this case, let the caller generate the call to the
5567      run-time-library function to evaluate the power for us.  */
5568
5569   if (ffecom_transform_only_dummies_)
5570     return NULL_TREE;
5571
5572   /* Right-hand operand not a constant, expand in-line code to figure
5573      out how to do the multiplies, &c.
5574
5575      The returned expression is expressed this way in GNU C, where l and
5576      r are the "inputs":
5577
5578      ({ typeof (r) rtmp = r;
5579         typeof (l) ltmp = l;
5580         typeof (l) result;
5581
5582         if (rtmp == 0)
5583           result = 1;
5584         else
5585           {
5586             if ((basetypeof (l) == basetypeof (int))
5587                 && (rtmp < 0))
5588               {
5589                 result = ((typeof (l)) 1) / ltmp;
5590                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5591                   result = -result;
5592               }
5593             else
5594               {
5595                 result = 1;
5596                 if ((basetypeof (l) != basetypeof (int))
5597                     && (rtmp < 0))
5598                   {
5599                     ltmp = ((typeof (l)) 1) / ltmp;
5600                     rtmp = -rtmp;
5601                     if (rtmp < 0)
5602                       {
5603                         rtmp = -(rtmp >> 1);
5604                         ltmp *= ltmp;
5605                       }
5606                   }
5607                 for (;;)
5608                   {
5609                     if (rtmp & 1)
5610                       result *= ltmp;
5611                     if ((rtmp >>= 1) == 0)
5612                       break;
5613                     ltmp *= ltmp;
5614                   }
5615               }
5616           }
5617         result;
5618      })
5619
5620      Note that some of the above is compile-time collapsable, such as
5621      the first part of the if statements that checks the base type of
5622      l against int.  The if statements are phrased that way to suggest
5623      an easy way to generate the if/else constructs here, knowing that
5624      the back end should (and probably does) eliminate the resulting
5625      dead code (either the int case or the non-int case), something
5626      it couldn't do without the redundant phrasing, requiring explicit
5627      dead-code elimination here, which would be kind of difficult to
5628      read.  */
5629
5630   {
5631     tree rtmp;
5632     tree ltmp;
5633     tree divide;
5634     tree basetypeof_l_is_int;
5635     tree se;
5636     tree t;
5637
5638     basetypeof_l_is_int
5639       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5640
5641     se = expand_start_stmt_expr ();
5642
5643     ffecom_start_compstmt ();
5644
5645 #ifndef HAHA
5646     rtmp = ffecom_make_tempvar ("power_r", rtype,
5647                                 FFETARGET_charactersizeNONE, -1);
5648     ltmp = ffecom_make_tempvar ("power_l", ltype,
5649                                 FFETARGET_charactersizeNONE, -1);
5650     result = ffecom_make_tempvar ("power_res", ltype,
5651                                   FFETARGET_charactersizeNONE, -1);
5652     if (TREE_CODE (ltype) == COMPLEX_TYPE
5653         || TREE_CODE (ltype) == RECORD_TYPE)
5654       divide = ffecom_make_tempvar ("power_div", ltype,
5655                                     FFETARGET_charactersizeNONE, -1);
5656     else
5657       divide = NULL_TREE;
5658 #else  /* HAHA */
5659     {
5660       tree hook;
5661
5662       hook = ffebld_nonter_hook (expr);
5663       assert (hook);
5664       assert (TREE_CODE (hook) == TREE_VEC);
5665       assert (TREE_VEC_LENGTH (hook) == 4);
5666       rtmp = TREE_VEC_ELT (hook, 0);
5667       ltmp = TREE_VEC_ELT (hook, 1);
5668       result = TREE_VEC_ELT (hook, 2);
5669       divide = TREE_VEC_ELT (hook, 3);
5670       if (TREE_CODE (ltype) == COMPLEX_TYPE
5671           || TREE_CODE (ltype) == RECORD_TYPE)
5672         assert (divide);
5673       else
5674         assert (! divide);
5675     }
5676 #endif  /* HAHA */
5677
5678     expand_expr_stmt (ffecom_modify (void_type_node,
5679                                      rtmp,
5680                                      r));
5681     expand_expr_stmt (ffecom_modify (void_type_node,
5682                                      ltmp,
5683                                      l));
5684     expand_start_cond (ffecom_truth_value
5685                        (ffecom_2 (EQ_EXPR, integer_type_node,
5686                                   rtmp,
5687                                   convert (rtype, integer_zero_node))),
5688                        0);
5689     expand_expr_stmt (ffecom_modify (void_type_node,
5690                                      result,
5691                                      convert (ltype, integer_one_node)));
5692     expand_start_else ();
5693     if (! integer_zerop (basetypeof_l_is_int))
5694       {
5695         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5696                                      rtmp,
5697                                      convert (rtype,
5698                                               integer_zero_node)),
5699                            0);
5700         expand_expr_stmt (ffecom_modify (void_type_node,
5701                                          result,
5702                                          ffecom_tree_divide_
5703                                          (ltype,
5704                                           convert (ltype, integer_one_node),
5705                                           ltmp,
5706                                           NULL_TREE, NULL, NULL,
5707                                           divide)));
5708         expand_start_cond (ffecom_truth_value
5709                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5710                                       ffecom_2 (LT_EXPR, integer_type_node,
5711                                                 ltmp,
5712                                                 convert (ltype,
5713                                                          integer_zero_node)),
5714                                       ffecom_2 (EQ_EXPR, integer_type_node,
5715                                                 ffecom_2 (BIT_AND_EXPR,
5716                                                           rtype,
5717                                                           ffecom_1 (NEGATE_EXPR,
5718                                                                     rtype,
5719                                                                     rtmp),
5720                                                           convert (rtype,
5721                                                                    integer_one_node)),
5722                                                 convert (rtype,
5723                                                          integer_zero_node)))),
5724                            0);
5725         expand_expr_stmt (ffecom_modify (void_type_node,
5726                                          result,
5727                                          ffecom_1 (NEGATE_EXPR,
5728                                                    ltype,
5729                                                    result)));
5730         expand_end_cond ();
5731         expand_start_else ();
5732       }
5733     expand_expr_stmt (ffecom_modify (void_type_node,
5734                                      result,
5735                                      convert (ltype, integer_one_node)));
5736     expand_start_cond (ffecom_truth_value
5737                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5738                                   ffecom_truth_value_invert
5739                                   (basetypeof_l_is_int),
5740                                   ffecom_2 (LT_EXPR, integer_type_node,
5741                                             rtmp,
5742                                             convert (rtype,
5743                                                      integer_zero_node)))),
5744                        0);
5745     expand_expr_stmt (ffecom_modify (void_type_node,
5746                                      ltmp,
5747                                      ffecom_tree_divide_
5748                                      (ltype,
5749                                       convert (ltype, integer_one_node),
5750                                       ltmp,
5751                                       NULL_TREE, NULL, NULL,
5752                                       divide)));
5753     expand_expr_stmt (ffecom_modify (void_type_node,
5754                                      rtmp,
5755                                      ffecom_1 (NEGATE_EXPR, rtype,
5756                                                rtmp)));
5757     expand_start_cond (ffecom_truth_value
5758                        (ffecom_2 (LT_EXPR, integer_type_node,
5759                                   rtmp,
5760                                   convert (rtype, integer_zero_node))),
5761                        0);
5762     expand_expr_stmt (ffecom_modify (void_type_node,
5763                                      rtmp,
5764                                      ffecom_1 (NEGATE_EXPR, rtype,
5765                                                ffecom_2 (RSHIFT_EXPR,
5766                                                          rtype,
5767                                                          rtmp,
5768                                                          integer_one_node))));
5769     expand_expr_stmt (ffecom_modify (void_type_node,
5770                                      ltmp,
5771                                      ffecom_2 (MULT_EXPR, ltype,
5772                                                ltmp,
5773                                                ltmp)));
5774     expand_end_cond ();
5775     expand_end_cond ();
5776     expand_start_loop (1);
5777     expand_start_cond (ffecom_truth_value
5778                        (ffecom_2 (BIT_AND_EXPR, rtype,
5779                                   rtmp,
5780                                   convert (rtype, integer_one_node))),
5781                        0);
5782     expand_expr_stmt (ffecom_modify (void_type_node,
5783                                      result,
5784                                      ffecom_2 (MULT_EXPR, ltype,
5785                                                result,
5786                                                ltmp)));
5787     expand_end_cond ();
5788     expand_exit_loop_if_false (NULL,
5789                                ffecom_truth_value
5790                                (ffecom_modify (rtype,
5791                                                rtmp,
5792                                                ffecom_2 (RSHIFT_EXPR,
5793                                                          rtype,
5794                                                          rtmp,
5795                                                          integer_one_node))));
5796     expand_expr_stmt (ffecom_modify (void_type_node,
5797                                      ltmp,
5798                                      ffecom_2 (MULT_EXPR, ltype,
5799                                                ltmp,
5800                                                ltmp)));
5801     expand_end_loop ();
5802     expand_end_cond ();
5803     if (!integer_zerop (basetypeof_l_is_int))
5804       expand_end_cond ();
5805     expand_expr_stmt (result);
5806
5807     t = ffecom_end_compstmt ();
5808
5809     result = expand_end_stmt_expr (se);
5810
5811     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5812
5813     if (TREE_CODE (t) == BLOCK)
5814       {
5815         /* Make a BIND_EXPR for the BLOCK already made.  */
5816         result = build (BIND_EXPR, TREE_TYPE (result),
5817                         NULL_TREE, result, t);
5818         /* Remove the block from the tree at this point.
5819            It gets put back at the proper place
5820            when the BIND_EXPR is expanded.  */
5821         delete_block (t);
5822       }
5823     else
5824       result = t;
5825   }
5826
5827   return result;
5828 }
5829
5830 #endif
5831 /* ffecom_expr_transform_ -- Transform symbols in expr
5832
5833    ffebld expr;  // FFE expression.
5834    ffecom_expr_transform_ (expr);
5835
5836    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5837
5838 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5839 static void
5840 ffecom_expr_transform_ (ffebld expr)
5841 {
5842   tree t;
5843   ffesymbol s;
5844
5845 tail_recurse:                   /* :::::::::::::::::::: */
5846
5847   if (expr == NULL)
5848     return;
5849
5850   switch (ffebld_op (expr))
5851     {
5852     case FFEBLD_opSYMTER:
5853       s = ffebld_symter (expr);
5854       t = ffesymbol_hook (s).decl_tree;
5855       if ((t == NULL_TREE)
5856           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5857               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5858                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5859         {
5860           s = ffecom_sym_transform_ (s);
5861           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5862                                                    DIMENSION expr? */
5863         }
5864       break;                    /* Ok if (t == NULL) here. */
5865
5866     case FFEBLD_opITEM:
5867       ffecom_expr_transform_ (ffebld_head (expr));
5868       expr = ffebld_trail (expr);
5869       goto tail_recurse;        /* :::::::::::::::::::: */
5870
5871     default:
5872       break;
5873     }
5874
5875   switch (ffebld_arity (expr))
5876     {
5877     case 2:
5878       ffecom_expr_transform_ (ffebld_left (expr));
5879       expr = ffebld_right (expr);
5880       goto tail_recurse;        /* :::::::::::::::::::: */
5881
5882     case 1:
5883       expr = ffebld_left (expr);
5884       goto tail_recurse;        /* :::::::::::::::::::: */
5885
5886     default:
5887       break;
5888     }
5889
5890   return;
5891 }
5892
5893 #endif
5894 /* Make a type based on info in live f2c.h file.  */
5895
5896 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5897 static void
5898 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5899 {
5900   switch (tcode)
5901     {
5902     case FFECOM_f2ccodeCHAR:
5903       *type = make_signed_type (CHAR_TYPE_SIZE);
5904       break;
5905
5906     case FFECOM_f2ccodeSHORT:
5907       *type = make_signed_type (SHORT_TYPE_SIZE);
5908       break;
5909
5910     case FFECOM_f2ccodeINT:
5911       *type = make_signed_type (INT_TYPE_SIZE);
5912       break;
5913
5914     case FFECOM_f2ccodeLONG:
5915       *type = make_signed_type (LONG_TYPE_SIZE);
5916       break;
5917
5918     case FFECOM_f2ccodeLONGLONG:
5919       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5920       break;
5921
5922     case FFECOM_f2ccodeCHARPTR:
5923       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5924                                   ? signed_char_type_node
5925                                   : unsigned_char_type_node);
5926       break;
5927
5928     case FFECOM_f2ccodeFLOAT:
5929       *type = make_node (REAL_TYPE);
5930       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5931       layout_type (*type);
5932       break;
5933
5934     case FFECOM_f2ccodeDOUBLE:
5935       *type = make_node (REAL_TYPE);
5936       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5937       layout_type (*type);
5938       break;
5939
5940     case FFECOM_f2ccodeLONGDOUBLE:
5941       *type = make_node (REAL_TYPE);
5942       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5943       layout_type (*type);
5944       break;
5945
5946     case FFECOM_f2ccodeTWOREALS:
5947       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5948       break;
5949
5950     case FFECOM_f2ccodeTWODOUBLEREALS:
5951       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5952       break;
5953
5954     default:
5955       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5956       *type = error_mark_node;
5957       return;
5958     }
5959
5960   pushdecl (build_decl (TYPE_DECL,
5961                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5962                         *type));
5963 }
5964
5965 #endif
5966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5967 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5968    given size.  */
5969
5970 static void
5971 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5972                           int code)
5973 {
5974   int j;
5975   tree t;
5976
5977   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5978     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5979         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5980       {
5981         assert (code != -1);
5982         ffecom_f2c_typecode_[bt][j] = code;
5983         code = -1;
5984       }
5985 }
5986
5987 #endif
5988 /* Finish up globals after doing all program units in file
5989
5990    Need to handle only uninitialized COMMON areas.  */
5991
5992 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5993 static ffeglobal
5994 ffecom_finish_global_ (ffeglobal global)
5995 {
5996   tree cbtype;
5997   tree cbt;
5998   tree size;
5999
6000   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6001       return global;
6002
6003   if (ffeglobal_common_init (global))
6004       return global;
6005
6006   cbt = ffeglobal_hook (global);
6007   if ((cbt == NULL_TREE)
6008       || !ffeglobal_common_have_size (global))
6009     return global;              /* No need to make common, never ref'd. */
6010
6011   DECL_EXTERNAL (cbt) = 0;
6012
6013   /* Give the array a size now.  */
6014
6015   size = build_int_2 ((ffeglobal_common_size (global)
6016                       + ffeglobal_common_pad (global)) - 1,
6017                       0);
6018
6019   cbtype = TREE_TYPE (cbt);
6020   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6021                                            integer_zero_node,
6022                                            size);
6023   if (!TREE_TYPE (size))
6024     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6025   layout_type (cbtype);
6026
6027   cbt = start_decl (cbt, FALSE);
6028   assert (cbt == ffeglobal_hook (global));
6029
6030   finish_decl (cbt, NULL_TREE, FALSE);
6031
6032   return global;
6033 }
6034
6035 #endif
6036 /* Finish up any untransformed symbols.  */
6037
6038 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6039 static ffesymbol
6040 ffecom_finish_symbol_transform_ (ffesymbol s)
6041 {
6042   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6043     return s;
6044
6045   /* It's easy to know to transform an untransformed symbol, to make sure
6046      we put out debugging info for it.  But COMMON variables, unlike
6047      EQUIVALENCE ones, aren't given declarations in addition to the
6048      tree expressions that specify offsets, because COMMON variables
6049      can be referenced in the outer scope where only dummy arguments
6050      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6051      VAR_DECLs for COMMON variables when we transform them for real
6052      use, and therefore we do all the VAR_DECL creating here.  */
6053
6054   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6055     {
6056       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6057           || (ffesymbol_where (s) != FFEINFO_whereNONE
6058               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6059               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6060         /* Not transformed, and not CHARACTER*(*), and not a dummy
6061            argument, which can happen only if the entry point names
6062            it "rides in on" are all invalidated for other reasons.  */
6063         s = ffecom_sym_transform_ (s);
6064     }
6065
6066   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6067       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6068     {
6069       /* This isn't working, at least for dbxout.  The .s file looks
6070          okay to me (burley), but in gdb 4.9 at least, the variables
6071          appear to reside somewhere outside of the common area, so
6072          it doesn't make sense to mislead anyone by generating the info
6073          on those variables until this is fixed.  NOTE: Same problem
6074          with EQUIVALENCE, sadly...see similar #if later.  */
6075       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6076                              ffesymbol_storage (s));
6077     }
6078
6079   return s;
6080 }
6081
6082 #endif
6083 /* Append underscore(s) to name before calling get_identifier.  "us"
6084    is nonzero if the name already contains an underscore and thus
6085    needs two underscores appended.  */
6086
6087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6088 static tree
6089 ffecom_get_appended_identifier_ (char us, const char *name)
6090 {
6091   int i;
6092   char *newname;
6093   tree id;
6094
6095   newname = xmalloc ((i = strlen (name)) + 1
6096                      + ffe_is_underscoring ()
6097                      + us);
6098   memcpy (newname, name, i);
6099   newname[i] = '_';
6100   newname[i + us] = '_';
6101   newname[i + 1 + us] = '\0';
6102   id = get_identifier (newname);
6103
6104   free (newname);
6105
6106   return id;
6107 }
6108
6109 #endif
6110 /* Decide whether to append underscore to name before calling
6111    get_identifier.  */
6112
6113 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6114 static tree
6115 ffecom_get_external_identifier_ (ffesymbol s)
6116 {
6117   char us;
6118   const char *name = ffesymbol_text (s);
6119
6120   /* If name is a built-in name, just return it as is.  */
6121
6122   if (!ffe_is_underscoring ()
6123       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6124 #if FFETARGET_isENFORCED_MAIN_NAME
6125       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6126 #else
6127       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6128 #endif
6129       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6130     return get_identifier (name);
6131
6132   us = ffe_is_second_underscore ()
6133     ? (strchr (name, '_') != NULL)
6134       : 0;
6135
6136   return ffecom_get_appended_identifier_ (us, name);
6137 }
6138
6139 #endif
6140 /* Decide whether to append underscore to internal name before calling
6141    get_identifier.
6142
6143    This is for non-external, top-function-context names only.  Transform
6144    identifier so it doesn't conflict with the transformed result
6145    of using a _different_ external name.  E.g. if "CALL FOO" is
6146    transformed into "FOO_();", then the variable in "FOO_ = 3"
6147    must be transformed into something that does not conflict, since
6148    these two things should be independent.
6149
6150    The transformation is as follows.  If the name does not contain
6151    an underscore, there is no possible conflict, so just return.
6152    If the name does contain an underscore, then transform it just
6153    like we transform an external identifier.  */
6154
6155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6156 static tree
6157 ffecom_get_identifier_ (const char *name)
6158 {
6159   /* If name does not contain an underscore, just return it as is.  */
6160
6161   if (!ffe_is_underscoring ()
6162       || (strchr (name, '_') == NULL))
6163     return get_identifier (name);
6164
6165   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6166                                           name);
6167 }
6168
6169 #endif
6170 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6171
6172    tree t;
6173    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6174    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6175          ffesymbol_kindtype(s));
6176
6177    Call after setting up containing function and getting trees for all
6178    other symbols.  */
6179
6180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6181 static tree
6182 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6183 {
6184   ffebld expr = ffesymbol_sfexpr (s);
6185   tree type;
6186   tree func;
6187   tree result;
6188   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6189   static bool recurse = FALSE;
6190   int old_lineno = lineno;
6191   const char *old_input_filename = input_filename;
6192
6193   ffecom_nested_entry_ = s;
6194
6195   /* For now, we don't have a handy pointer to where the sfunc is actually
6196      defined, though that should be easy to add to an ffesymbol. (The
6197      token/where info available might well point to the place where the type
6198      of the sfunc is declared, especially if that precedes the place where
6199      the sfunc itself is defined, which is typically the case.)  We should
6200      put out a null pointer rather than point somewhere wrong, but I want to
6201      see how it works at this point.  */
6202
6203   input_filename = ffesymbol_where_filename (s);
6204   lineno = ffesymbol_where_filelinenum (s);
6205
6206   /* Pretransform the expression so any newly discovered things belong to the
6207      outer program unit, not to the statement function. */
6208
6209   ffecom_expr_transform_ (expr);
6210
6211   /* Make sure no recursive invocation of this fn (a specific case of failing
6212      to pretransform an sfunc's expression, i.e. where its expression
6213      references another untransformed sfunc) happens. */
6214
6215   assert (!recurse);
6216   recurse = TRUE;
6217
6218   push_f_function_context ();
6219
6220   if (charfunc)
6221     type = void_type_node;
6222   else
6223     {
6224       type = ffecom_tree_type[bt][kt];
6225       if (type == NULL_TREE)
6226         type = integer_type_node;       /* _sym_exec_transition reports
6227                                            error. */
6228     }
6229
6230   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6231                   build_function_type (type, NULL_TREE),
6232                   1,            /* nested/inline */
6233                   0);           /* TREE_PUBLIC */
6234
6235   /* We don't worry about COMPLEX return values here, because this is
6236      entirely internal to our code, and gcc has the ability to return COMPLEX
6237      directly as a value.  */
6238
6239   if (charfunc)
6240     {                           /* Prepend arg for where result goes. */
6241       tree type;
6242
6243       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6244
6245       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6246
6247       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6248
6249       type = build_pointer_type (type);
6250       result = build_decl (PARM_DECL, result, type);
6251
6252       push_parm_decl (result);
6253     }
6254   else
6255     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6256
6257   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6258
6259   store_parm_decls (0);
6260
6261   ffecom_start_compstmt ();
6262
6263   if (expr != NULL)
6264     {
6265       if (charfunc)
6266         {
6267           ffetargetCharacterSize sz = ffesymbol_size (s);
6268           tree result_length;
6269
6270           result_length = build_int_2 (sz, 0);
6271           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6272
6273           ffecom_prepare_let_char_ (sz, expr);
6274
6275           ffecom_prepare_end ();
6276
6277           ffecom_let_char_ (result, result_length, sz, expr);
6278           expand_null_return ();
6279         }
6280       else
6281         {
6282           ffecom_prepare_expr (expr);
6283
6284           ffecom_prepare_end ();
6285
6286           expand_return (ffecom_modify (NULL_TREE,
6287                                         DECL_RESULT (current_function_decl),
6288                                         ffecom_expr (expr)));
6289         }
6290     }
6291
6292   ffecom_end_compstmt ();
6293
6294   func = current_function_decl;
6295   finish_function (1);
6296
6297   pop_f_function_context ();
6298
6299   recurse = FALSE;
6300
6301   lineno = old_lineno;
6302   input_filename = old_input_filename;
6303
6304   ffecom_nested_entry_ = NULL;
6305
6306   return func;
6307 }
6308
6309 #endif
6310
6311 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6312 static const char *
6313 ffecom_gfrt_args_ (ffecomGfrt ix)
6314 {
6315   return ffecom_gfrt_argstring_[ix];
6316 }
6317
6318 #endif
6319 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6320 static tree
6321 ffecom_gfrt_tree_ (ffecomGfrt ix)
6322 {
6323   if (ffecom_gfrt_[ix] == NULL_TREE)
6324     ffecom_make_gfrt_ (ix);
6325
6326   return ffecom_1 (ADDR_EXPR,
6327                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6328                    ffecom_gfrt_[ix]);
6329 }
6330
6331 #endif
6332 /* Return initialize-to-zero expression for this VAR_DECL.  */
6333
6334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6335 /* A somewhat evil way to prevent the garbage collector
6336    from collecting 'tree' structures.  */
6337 #define NUM_TRACKED_CHUNK 63
6338 static struct tree_ggc_tracker
6339 {
6340   struct tree_ggc_tracker *next;
6341   tree trees[NUM_TRACKED_CHUNK];
6342 } *tracker_head = NULL;
6343
6344 static void
6345 mark_tracker_head (void *arg)
6346 {
6347   struct tree_ggc_tracker *head;
6348   int i;
6349
6350   for (head = * (struct tree_ggc_tracker **) arg;
6351        head != NULL;
6352        head = head->next)
6353   {
6354     ggc_mark (head);
6355     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6356       ggc_mark_tree (head->trees[i]);
6357   }
6358 }
6359
6360 void
6361 ffecom_save_tree_forever (tree t)
6362 {
6363   int i;
6364   if (tracker_head != NULL)
6365     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6366       if (tracker_head->trees[i] == NULL)
6367         {
6368           tracker_head->trees[i] = t;
6369           return;
6370         }
6371
6372   {
6373     /* Need to allocate a new block.  */
6374     struct tree_ggc_tracker *old_head = tracker_head;
6375
6376     tracker_head = ggc_alloc (sizeof (*tracker_head));
6377     tracker_head->next = old_head;
6378     tracker_head->trees[0] = t;
6379     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6380       tracker_head->trees[i] = NULL;
6381   }
6382 }
6383
6384 static tree
6385 ffecom_init_zero_ (tree decl)
6386 {
6387   tree init;
6388   int incremental = TREE_STATIC (decl);
6389   tree type = TREE_TYPE (decl);
6390
6391   if (incremental)
6392     {
6393       make_decl_rtl (decl, NULL);
6394       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6395     }
6396
6397   if ((TREE_CODE (type) != ARRAY_TYPE)
6398       && (TREE_CODE (type) != RECORD_TYPE)
6399       && (TREE_CODE (type) != UNION_TYPE)
6400       && !incremental)
6401     init = convert (type, integer_zero_node);
6402   else if (!incremental)
6403     {
6404       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6405       TREE_CONSTANT (init) = 1;
6406       TREE_STATIC (init) = 1;
6407     }
6408   else
6409     {
6410       assemble_zeros (int_size_in_bytes (type));
6411       init = error_mark_node;
6412     }
6413
6414   return init;
6415 }
6416
6417 #endif
6418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6419 static tree
6420 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6421                          tree *maybe_tree)
6422 {
6423   tree expr_tree;
6424   tree length_tree;
6425
6426   switch (ffebld_op (arg))
6427     {
6428     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6429       if (ffetarget_length_character1
6430           (ffebld_constant_character1
6431            (ffebld_conter (arg))) == 0)
6432         {
6433           *maybe_tree = integer_zero_node;
6434           return convert (tree_type, integer_zero_node);
6435         }
6436
6437       *maybe_tree = integer_one_node;
6438       expr_tree = build_int_2 (*ffetarget_text_character1
6439                                (ffebld_constant_character1
6440                                 (ffebld_conter (arg))),
6441                                0);
6442       TREE_TYPE (expr_tree) = tree_type;
6443       return expr_tree;
6444
6445     case FFEBLD_opSYMTER:
6446     case FFEBLD_opARRAYREF:
6447     case FFEBLD_opFUNCREF:
6448     case FFEBLD_opSUBSTR:
6449       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6450
6451       if ((expr_tree == error_mark_node)
6452           || (length_tree == error_mark_node))
6453         {
6454           *maybe_tree = error_mark_node;
6455           return error_mark_node;
6456         }
6457
6458       if (integer_zerop (length_tree))
6459         {
6460           *maybe_tree = integer_zero_node;
6461           return convert (tree_type, integer_zero_node);
6462         }
6463
6464       expr_tree
6465         = ffecom_1 (INDIRECT_REF,
6466                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6467                     expr_tree);
6468       expr_tree
6469         = ffecom_2 (ARRAY_REF,
6470                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6471                     expr_tree,
6472                     integer_one_node);
6473       expr_tree = convert (tree_type, expr_tree);
6474
6475       if (TREE_CODE (length_tree) == INTEGER_CST)
6476         *maybe_tree = integer_one_node;
6477       else                      /* Must check length at run time.  */
6478         *maybe_tree
6479           = ffecom_truth_value
6480             (ffecom_2 (GT_EXPR, integer_type_node,
6481                        length_tree,
6482                        ffecom_f2c_ftnlen_zero_node));
6483       return expr_tree;
6484
6485     case FFEBLD_opPAREN:
6486     case FFEBLD_opCONVERT:
6487       if (ffeinfo_size (ffebld_info (arg)) == 0)
6488         {
6489           *maybe_tree = integer_zero_node;
6490           return convert (tree_type, integer_zero_node);
6491         }
6492       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6493                                       maybe_tree);
6494
6495     case FFEBLD_opCONCATENATE:
6496       {
6497         tree maybe_left;
6498         tree maybe_right;
6499         tree expr_left;
6500         tree expr_right;
6501
6502         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6503                                              &maybe_left);
6504         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6505                                               &maybe_right);
6506         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6507                                 maybe_left,
6508                                 maybe_right);
6509         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6510                               maybe_left,
6511                               expr_left,
6512                               expr_right);
6513         return expr_tree;
6514       }
6515
6516     default:
6517       assert ("bad op in ICHAR" == NULL);
6518       return error_mark_node;
6519     }
6520 }
6521
6522 #endif
6523 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6524
6525    tree length_arg;
6526    ffebld expr;
6527    length_arg = ffecom_intrinsic_len_ (expr);
6528
6529    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6530    subexpressions by constructing the appropriate tree for the
6531    length-of-character-text argument in a calling sequence.  */
6532
6533 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6534 static tree
6535 ffecom_intrinsic_len_ (ffebld expr)
6536 {
6537   ffetargetCharacter1 val;
6538   tree length;
6539
6540   switch (ffebld_op (expr))
6541     {
6542     case FFEBLD_opCONTER:
6543       val = ffebld_constant_character1 (ffebld_conter (expr));
6544       length = build_int_2 (ffetarget_length_character1 (val), 0);
6545       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6546       break;
6547
6548     case FFEBLD_opSYMTER:
6549       {
6550         ffesymbol s = ffebld_symter (expr);
6551         tree item;
6552
6553         item = ffesymbol_hook (s).decl_tree;
6554         if (item == NULL_TREE)
6555           {
6556             s = ffecom_sym_transform_ (s);
6557             item = ffesymbol_hook (s).decl_tree;
6558           }
6559         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6560           {
6561             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6562               length = ffesymbol_hook (s).length_tree;
6563             else
6564               {
6565                 length = build_int_2 (ffesymbol_size (s), 0);
6566                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6567               }
6568           }
6569         else if (item == error_mark_node)
6570           length = error_mark_node;
6571         else                    /* FFEINFO_kindFUNCTION: */
6572           length = NULL_TREE;
6573       }
6574       break;
6575
6576     case FFEBLD_opARRAYREF:
6577       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6578       break;
6579
6580     case FFEBLD_opSUBSTR:
6581       {
6582         ffebld start;
6583         ffebld end;
6584         ffebld thing = ffebld_right (expr);
6585         tree start_tree;
6586         tree end_tree;
6587
6588         assert (ffebld_op (thing) == FFEBLD_opITEM);
6589         start = ffebld_head (thing);
6590         thing = ffebld_trail (thing);
6591         assert (ffebld_trail (thing) == NULL);
6592         end = ffebld_head (thing);
6593
6594         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6595
6596         if (length == error_mark_node)
6597           break;
6598
6599         if (start == NULL)
6600           {
6601             if (end == NULL)
6602               ;
6603             else
6604               {
6605                 length = convert (ffecom_f2c_ftnlen_type_node,
6606                                   ffecom_expr (end));
6607               }
6608           }
6609         else
6610           {
6611             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6612                                   ffecom_expr (start));
6613
6614             if (start_tree == error_mark_node)
6615               {
6616                 length = error_mark_node;
6617                 break;
6618               }
6619
6620             if (end == NULL)
6621               {
6622                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6623                                    ffecom_f2c_ftnlen_one_node,
6624                                    ffecom_2 (MINUS_EXPR,
6625                                              ffecom_f2c_ftnlen_type_node,
6626                                              length,
6627                                              start_tree));
6628               }
6629             else
6630               {
6631                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6632                                     ffecom_expr (end));
6633
6634                 if (end_tree == error_mark_node)
6635                   {
6636                     length = error_mark_node;
6637                     break;
6638                   }
6639
6640                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6641                                    ffecom_f2c_ftnlen_one_node,
6642                                    ffecom_2 (MINUS_EXPR,
6643                                              ffecom_f2c_ftnlen_type_node,
6644                                              end_tree, start_tree));
6645               }
6646           }
6647       }
6648       break;
6649
6650     case FFEBLD_opCONCATENATE:
6651       length
6652         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6653                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6654                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6655       break;
6656
6657     case FFEBLD_opFUNCREF:
6658     case FFEBLD_opCONVERT:
6659       length = build_int_2 (ffebld_size (expr), 0);
6660       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6661       break;
6662
6663     default:
6664       assert ("bad op for single char arg expr" == NULL);
6665       length = ffecom_f2c_ftnlen_zero_node;
6666       break;
6667     }
6668
6669   assert (length != NULL_TREE);
6670
6671   return length;
6672 }
6673
6674 #endif
6675 /* Handle CHARACTER assignments.
6676
6677    Generates code to do the assignment.  Used by ordinary assignment
6678    statement handler ffecom_let_stmt and by statement-function
6679    handler to generate code for a statement function.  */
6680
6681 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6682 static void
6683 ffecom_let_char_ (tree dest_tree, tree dest_length,
6684                   ffetargetCharacterSize dest_size, ffebld source)
6685 {
6686   ffecomConcatList_ catlist;
6687   tree source_length;
6688   tree source_tree;
6689   tree expr_tree;
6690
6691   if ((dest_tree == error_mark_node)
6692       || (dest_length == error_mark_node))
6693     return;
6694
6695   assert (dest_tree != NULL_TREE);
6696   assert (dest_length != NULL_TREE);
6697
6698   /* Source might be an opCONVERT, which just means it is a different size
6699      than the destination.  Since the underlying implementation here handles
6700      that (directly or via the s_copy or s_cat run-time-library functions),
6701      we don't need the "convenience" of an opCONVERT that tells us to
6702      truncate or blank-pad, particularly since the resulting implementation
6703      would probably be slower than otherwise. */
6704
6705   while (ffebld_op (source) == FFEBLD_opCONVERT)
6706     source = ffebld_left (source);
6707
6708   catlist = ffecom_concat_list_new_ (source, dest_size);
6709   switch (ffecom_concat_list_count_ (catlist))
6710     {
6711     case 0:                     /* Shouldn't happen, but in case it does... */
6712       ffecom_concat_list_kill_ (catlist);
6713       source_tree = null_pointer_node;
6714       source_length = ffecom_f2c_ftnlen_zero_node;
6715       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6716       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6717       TREE_CHAIN (TREE_CHAIN (expr_tree))
6718         = build_tree_list (NULL_TREE, dest_length);
6719       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6720         = build_tree_list (NULL_TREE, source_length);
6721
6722       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6723       TREE_SIDE_EFFECTS (expr_tree) = 1;
6724
6725       expand_expr_stmt (expr_tree);
6726
6727       return;
6728
6729     case 1:                     /* The (fairly) easy case. */
6730       ffecom_char_args_ (&source_tree, &source_length,
6731                          ffecom_concat_list_expr_ (catlist, 0));
6732       ffecom_concat_list_kill_ (catlist);
6733       assert (source_tree != NULL_TREE);
6734       assert (source_length != NULL_TREE);
6735
6736       if ((source_tree == error_mark_node)
6737           || (source_length == error_mark_node))
6738         return;
6739
6740       if (dest_size == 1)
6741         {
6742           dest_tree
6743             = ffecom_1 (INDIRECT_REF,
6744                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6745                                                       (dest_tree))),
6746                         dest_tree);
6747           dest_tree
6748             = ffecom_2 (ARRAY_REF,
6749                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6750                                                       (dest_tree))),
6751                         dest_tree,
6752                         integer_one_node);
6753           source_tree
6754             = ffecom_1 (INDIRECT_REF,
6755                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6756                                                       (source_tree))),
6757                         source_tree);
6758           source_tree
6759             = ffecom_2 (ARRAY_REF,
6760                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6761                                                       (source_tree))),
6762                         source_tree,
6763                         integer_one_node);
6764
6765           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6766
6767           expand_expr_stmt (expr_tree);
6768
6769           return;
6770         }
6771
6772       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6773       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6774       TREE_CHAIN (TREE_CHAIN (expr_tree))
6775         = build_tree_list (NULL_TREE, dest_length);
6776       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6777         = build_tree_list (NULL_TREE, source_length);
6778
6779       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6780       TREE_SIDE_EFFECTS (expr_tree) = 1;
6781
6782       expand_expr_stmt (expr_tree);
6783
6784       return;
6785
6786     default:                    /* Must actually concatenate things. */
6787       break;
6788     }
6789
6790   /* Heavy-duty concatenation. */
6791
6792   {
6793     int count = ffecom_concat_list_count_ (catlist);
6794     int i;
6795     tree lengths;
6796     tree items;
6797     tree length_array;
6798     tree item_array;
6799     tree citem;
6800     tree clength;
6801
6802 #ifdef HOHO
6803     length_array
6804       = lengths
6805       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6806                              FFETARGET_charactersizeNONE, count, TRUE);
6807     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6808                                               FFETARGET_charactersizeNONE,
6809                                               count, TRUE);
6810 #else
6811     {
6812       tree hook;
6813
6814       hook = ffebld_nonter_hook (source);
6815       assert (hook);
6816       assert (TREE_CODE (hook) == TREE_VEC);
6817       assert (TREE_VEC_LENGTH (hook) == 2);
6818       length_array = lengths = TREE_VEC_ELT (hook, 0);
6819       item_array = items = TREE_VEC_ELT (hook, 1);
6820     }
6821 #endif
6822
6823     for (i = 0; i < count; ++i)
6824       {
6825         ffecom_char_args_ (&citem, &clength,
6826                            ffecom_concat_list_expr_ (catlist, i));
6827         if ((citem == error_mark_node)
6828             || (clength == error_mark_node))
6829           {
6830             ffecom_concat_list_kill_ (catlist);
6831             return;
6832           }
6833
6834         items
6835           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6836                       ffecom_modify (void_type_node,
6837                                      ffecom_2 (ARRAY_REF,
6838                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6839                                                item_array,
6840                                                build_int_2 (i, 0)),
6841                                      citem),
6842                       items);
6843         lengths
6844           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6845                       ffecom_modify (void_type_node,
6846                                      ffecom_2 (ARRAY_REF,
6847                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6848                                                length_array,
6849                                                build_int_2 (i, 0)),
6850                                      clength),
6851                       lengths);
6852       }
6853
6854     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6855     TREE_CHAIN (expr_tree)
6856       = build_tree_list (NULL_TREE,
6857                          ffecom_1 (ADDR_EXPR,
6858                                    build_pointer_type (TREE_TYPE (items)),
6859                                    items));
6860     TREE_CHAIN (TREE_CHAIN (expr_tree))
6861       = build_tree_list (NULL_TREE,
6862                          ffecom_1 (ADDR_EXPR,
6863                                    build_pointer_type (TREE_TYPE (lengths)),
6864                                    lengths));
6865     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6866       = build_tree_list
6867         (NULL_TREE,
6868          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6869                    convert (ffecom_f2c_ftnlen_type_node,
6870                             build_int_2 (count, 0))));
6871     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6872       = build_tree_list (NULL_TREE, dest_length);
6873
6874     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6875     TREE_SIDE_EFFECTS (expr_tree) = 1;
6876
6877     expand_expr_stmt (expr_tree);
6878   }
6879
6880   ffecom_concat_list_kill_ (catlist);
6881 }
6882
6883 #endif
6884 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6885
6886    ffecomGfrt ix;
6887    ffecom_make_gfrt_(ix);
6888
6889    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6890    for the indicated run-time routine (ix).  */
6891
6892 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6893 static void
6894 ffecom_make_gfrt_ (ffecomGfrt ix)
6895 {
6896   tree t;
6897   tree ttype;
6898
6899   switch (ffecom_gfrt_type_[ix])
6900     {
6901     case FFECOM_rttypeVOID_:
6902       ttype = void_type_node;
6903       break;
6904
6905     case FFECOM_rttypeVOIDSTAR_:
6906       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6907       break;
6908
6909     case FFECOM_rttypeFTNINT_:
6910       ttype = ffecom_f2c_ftnint_type_node;
6911       break;
6912
6913     case FFECOM_rttypeINTEGER_:
6914       ttype = ffecom_f2c_integer_type_node;
6915       break;
6916
6917     case FFECOM_rttypeLONGINT_:
6918       ttype = ffecom_f2c_longint_type_node;
6919       break;
6920
6921     case FFECOM_rttypeLOGICAL_:
6922       ttype = ffecom_f2c_logical_type_node;
6923       break;
6924
6925     case FFECOM_rttypeREAL_F2C_:
6926       ttype = double_type_node;
6927       break;
6928
6929     case FFECOM_rttypeREAL_GNU_:
6930       ttype = float_type_node;
6931       break;
6932
6933     case FFECOM_rttypeCOMPLEX_F2C_:
6934       ttype = void_type_node;
6935       break;
6936
6937     case FFECOM_rttypeCOMPLEX_GNU_:
6938       ttype = ffecom_f2c_complex_type_node;
6939       break;
6940
6941     case FFECOM_rttypeDOUBLE_:
6942       ttype = double_type_node;
6943       break;
6944
6945     case FFECOM_rttypeDOUBLEREAL_:
6946       ttype = ffecom_f2c_doublereal_type_node;
6947       break;
6948
6949     case FFECOM_rttypeDBLCMPLX_F2C_:
6950       ttype = void_type_node;
6951       break;
6952
6953     case FFECOM_rttypeDBLCMPLX_GNU_:
6954       ttype = ffecom_f2c_doublecomplex_type_node;
6955       break;
6956
6957     case FFECOM_rttypeCHARACTER_:
6958       ttype = void_type_node;
6959       break;
6960
6961     default:
6962       ttype = NULL;
6963       assert ("bad rttype" == NULL);
6964       break;
6965     }
6966
6967   ttype = build_function_type (ttype, NULL_TREE);
6968   t = build_decl (FUNCTION_DECL,
6969                   get_identifier (ffecom_gfrt_name_[ix]),
6970                   ttype);
6971   DECL_EXTERNAL (t) = 1;
6972   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6973   TREE_PUBLIC (t) = 1;
6974   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6975
6976   /* Sanity check:  A function that's const cannot be volatile.  */
6977
6978   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6979
6980   /* Sanity check: A function that's const cannot return complex.  */
6981
6982   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6983
6984   t = start_decl (t, TRUE);
6985
6986   finish_decl (t, NULL_TREE, TRUE);
6987
6988   ffecom_gfrt_[ix] = t;
6989 }
6990
6991 #endif
6992 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6993
6994 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6995 static void
6996 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6997 {
6998   ffesymbol s = ffestorag_symbol (st);
6999
7000   if (ffesymbol_namelisted (s))
7001     ffecom_member_namelisted_ = TRUE;
7002 }
7003
7004 #endif
7005 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7006    the member so debugger will see it.  Otherwise nobody should be
7007    referencing the member.  */
7008
7009 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7010 static void
7011 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7012 {
7013   ffesymbol s;
7014   tree t;
7015   tree mt;
7016   tree type;
7017
7018   if ((mst == NULL)
7019       || ((mt = ffestorag_hook (mst)) == NULL)
7020       || (mt == error_mark_node))
7021     return;
7022
7023   if ((st == NULL)
7024       || ((s = ffestorag_symbol (st)) == NULL))
7025     return;
7026
7027   type = ffecom_type_localvar_ (s,
7028                                 ffesymbol_basictype (s),
7029                                 ffesymbol_kindtype (s));
7030   if (type == error_mark_node)
7031     return;
7032
7033   t = build_decl (VAR_DECL,
7034                   ffecom_get_identifier_ (ffesymbol_text (s)),
7035                   type);
7036
7037   TREE_STATIC (t) = TREE_STATIC (mt);
7038   DECL_INITIAL (t) = NULL_TREE;
7039   TREE_ASM_WRITTEN (t) = 1;
7040   TREE_USED (t) = 1;
7041
7042   SET_DECL_RTL (t,
7043                 gen_rtx (MEM, TYPE_MODE (type),
7044                          plus_constant (XEXP (DECL_RTL (mt), 0),
7045                                         ffestorag_modulo (mst)
7046                                         + ffestorag_offset (st)
7047                                         - ffestorag_offset (mst))));
7048
7049   t = start_decl (t, FALSE);
7050
7051   finish_decl (t, NULL_TREE, FALSE);
7052 }
7053
7054 #endif
7055 /* Prepare source expression for assignment into a destination perhaps known
7056    to be of a specific size.  */
7057
7058 static void
7059 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7060 {
7061   ffecomConcatList_ catlist;
7062   int count;
7063   int i;
7064   tree ltmp;
7065   tree itmp;
7066   tree tempvar = NULL_TREE;
7067
7068   while (ffebld_op (source) == FFEBLD_opCONVERT)
7069     source = ffebld_left (source);
7070
7071   catlist = ffecom_concat_list_new_ (source, dest_size);
7072   count = ffecom_concat_list_count_ (catlist);
7073
7074   if (count >= 2)
7075     {
7076       ltmp
7077         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7078                                FFETARGET_charactersizeNONE, count);
7079       itmp
7080         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7081                                FFETARGET_charactersizeNONE, count);
7082
7083       tempvar = make_tree_vec (2);
7084       TREE_VEC_ELT (tempvar, 0) = ltmp;
7085       TREE_VEC_ELT (tempvar, 1) = itmp;
7086     }
7087
7088   for (i = 0; i < count; ++i)
7089     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7090
7091   ffecom_concat_list_kill_ (catlist);
7092
7093   if (tempvar)
7094     {
7095       ffebld_nonter_set_hook (source, tempvar);
7096       current_binding_level->prep_state = 1;
7097     }
7098 }
7099
7100 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7101
7102    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7103    (which generates their trees) and then their trees get push_parm_decl'd.
7104
7105    The second arg is TRUE if the dummies are for a statement function, in
7106    which case lengths are not pushed for character arguments (since they are
7107    always known by both the caller and the callee, though the code allows
7108    for someday permitting CHAR*(*) stmtfunc dummies).  */
7109
7110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7111 static void
7112 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7113 {
7114   ffebld dummy;
7115   ffebld dumlist;
7116   ffesymbol s;
7117   tree parm;
7118
7119   ffecom_transform_only_dummies_ = TRUE;
7120
7121   /* First push the parms corresponding to actual dummy "contents".  */
7122
7123   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7124     {
7125       dummy = ffebld_head (dumlist);
7126       switch (ffebld_op (dummy))
7127         {
7128         case FFEBLD_opSTAR:
7129         case FFEBLD_opANY:
7130           continue;             /* Forget alternate returns. */
7131
7132         default:
7133           break;
7134         }
7135       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7136       s = ffebld_symter (dummy);
7137       parm = ffesymbol_hook (s).decl_tree;
7138       if (parm == NULL_TREE)
7139         {
7140           s = ffecom_sym_transform_ (s);
7141           parm = ffesymbol_hook (s).decl_tree;
7142           assert (parm != NULL_TREE);
7143         }
7144       if (parm != error_mark_node)
7145         push_parm_decl (parm);
7146     }
7147
7148   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7149
7150   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7151     {
7152       dummy = ffebld_head (dumlist);
7153       switch (ffebld_op (dummy))
7154         {
7155         case FFEBLD_opSTAR:
7156         case FFEBLD_opANY:
7157           continue;             /* Forget alternate returns, they mean
7158                                    NOTHING! */
7159
7160         default:
7161           break;
7162         }
7163       s = ffebld_symter (dummy);
7164       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7165         continue;               /* Only looking for CHARACTER arguments. */
7166       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7167         continue;               /* Stmtfunc arg with known size needs no
7168                                    length param. */
7169       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7170         continue;               /* Only looking for variables and arrays. */
7171       parm = ffesymbol_hook (s).length_tree;
7172       assert (parm != NULL_TREE);
7173       if (parm != error_mark_node)
7174         push_parm_decl (parm);
7175     }
7176
7177   ffecom_transform_only_dummies_ = FALSE;
7178 }
7179
7180 #endif
7181 /* ffecom_start_progunit_ -- Beginning of program unit
7182
7183    Does GNU back end stuff necessary to teach it about the start of its
7184    equivalent of a Fortran program unit.  */
7185
7186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7187 static void
7188 ffecom_start_progunit_ ()
7189 {
7190   ffesymbol fn = ffecom_primary_entry_;
7191   ffebld arglist;
7192   tree id;                      /* Identifier (name) of function. */
7193   tree type;                    /* Type of function. */
7194   tree result;                  /* Result of function. */
7195   ffeinfoBasictype bt;
7196   ffeinfoKindtype kt;
7197   ffeglobal g;
7198   ffeglobalType gt;
7199   ffeglobalType egt = FFEGLOBAL_type;
7200   bool charfunc;
7201   bool cmplxfunc;
7202   bool altentries = (ffecom_num_entrypoints_ != 0);
7203   bool multi
7204   = altentries
7205   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7206   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7207   bool main_program = FALSE;
7208   int old_lineno = lineno;
7209   const char *old_input_filename = input_filename;
7210
7211   assert (fn != NULL);
7212   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7213
7214   input_filename = ffesymbol_where_filename (fn);
7215   lineno = ffesymbol_where_filelinenum (fn);
7216
7217   switch (ffecom_primary_entry_kind_)
7218     {
7219     case FFEINFO_kindPROGRAM:
7220       main_program = TRUE;
7221       gt = FFEGLOBAL_typeMAIN;
7222       bt = FFEINFO_basictypeNONE;
7223       kt = FFEINFO_kindtypeNONE;
7224       type = ffecom_tree_fun_type_void;
7225       charfunc = FALSE;
7226       cmplxfunc = FALSE;
7227       break;
7228
7229     case FFEINFO_kindBLOCKDATA:
7230       gt = FFEGLOBAL_typeBDATA;
7231       bt = FFEINFO_basictypeNONE;
7232       kt = FFEINFO_kindtypeNONE;
7233       type = ffecom_tree_fun_type_void;
7234       charfunc = FALSE;
7235       cmplxfunc = FALSE;
7236       break;
7237
7238     case FFEINFO_kindFUNCTION:
7239       gt = FFEGLOBAL_typeFUNC;
7240       egt = FFEGLOBAL_typeEXT;
7241       bt = ffesymbol_basictype (fn);
7242       kt = ffesymbol_kindtype (fn);
7243       if (bt == FFEINFO_basictypeNONE)
7244         {
7245           ffeimplic_establish_symbol (fn);
7246           if (ffesymbol_funcresult (fn) != NULL)
7247             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7248           bt = ffesymbol_basictype (fn);
7249           kt = ffesymbol_kindtype (fn);
7250         }
7251
7252       if (multi)
7253         charfunc = cmplxfunc = FALSE;
7254       else if (bt == FFEINFO_basictypeCHARACTER)
7255         charfunc = TRUE, cmplxfunc = FALSE;
7256       else if ((bt == FFEINFO_basictypeCOMPLEX)
7257                && ffesymbol_is_f2c (fn)
7258                && !altentries)
7259         charfunc = FALSE, cmplxfunc = TRUE;
7260       else
7261         charfunc = cmplxfunc = FALSE;
7262
7263       if (multi || charfunc)
7264         type = ffecom_tree_fun_type_void;
7265       else if (ffesymbol_is_f2c (fn) && !altentries)
7266         type = ffecom_tree_fun_type[bt][kt];
7267       else
7268         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7269
7270       if ((type == NULL_TREE)
7271           || (TREE_TYPE (type) == NULL_TREE))
7272         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7273       break;
7274
7275     case FFEINFO_kindSUBROUTINE:
7276       gt = FFEGLOBAL_typeSUBR;
7277       egt = FFEGLOBAL_typeEXT;
7278       bt = FFEINFO_basictypeNONE;
7279       kt = FFEINFO_kindtypeNONE;
7280       if (ffecom_is_altreturning_)
7281         type = ffecom_tree_subr_type;
7282       else
7283         type = ffecom_tree_fun_type_void;
7284       charfunc = FALSE;
7285       cmplxfunc = FALSE;
7286       break;
7287
7288     default:
7289       assert ("say what??" == NULL);
7290       /* Fall through. */
7291     case FFEINFO_kindANY:
7292       gt = FFEGLOBAL_typeANY;
7293       bt = FFEINFO_basictypeNONE;
7294       kt = FFEINFO_kindtypeNONE;
7295       type = error_mark_node;
7296       charfunc = FALSE;
7297       cmplxfunc = FALSE;
7298       break;
7299     }
7300
7301   if (altentries)
7302     {
7303       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7304                                            ffesymbol_text (fn));
7305     }
7306 #if FFETARGET_isENFORCED_MAIN
7307   else if (main_program)
7308     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7309 #endif
7310   else
7311     id = ffecom_get_external_identifier_ (fn);
7312
7313   start_function (id,
7314                   type,
7315                   0,            /* nested/inline */
7316                   !altentries); /* TREE_PUBLIC */
7317
7318   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7319
7320   if (!altentries
7321       && ((g = ffesymbol_global (fn)) != NULL)
7322       && ((ffeglobal_type (g) == gt)
7323           || (ffeglobal_type (g) == egt)))
7324     {
7325       ffeglobal_set_hook (g, current_function_decl);
7326     }
7327
7328   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7329      exec-transitioning needs current_function_decl to be filled in.  So we
7330      do these things in two phases. */
7331
7332   if (altentries)
7333     {                           /* 1st arg identifies which entrypoint. */
7334       ffecom_which_entrypoint_decl_
7335         = build_decl (PARM_DECL,
7336                       ffecom_get_invented_identifier ("__g77_%s",
7337                                                       "which_entrypoint"),
7338                       integer_type_node);
7339       push_parm_decl (ffecom_which_entrypoint_decl_);
7340     }
7341
7342   if (charfunc
7343       || cmplxfunc
7344       || multi)
7345     {                           /* Arg for result (return value). */
7346       tree type;
7347       tree length;
7348
7349       if (charfunc)
7350         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7351       else if (cmplxfunc)
7352         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7353       else
7354         type = ffecom_multi_type_node_;
7355
7356       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7357
7358       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7359
7360       if (charfunc)
7361         length = ffecom_char_enhance_arg_ (&type, fn);
7362       else
7363         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7364
7365       type = build_pointer_type (type);
7366       result = build_decl (PARM_DECL, result, type);
7367
7368       push_parm_decl (result);
7369       if (multi)
7370         ffecom_multi_retval_ = result;
7371       else
7372         ffecom_func_result_ = result;
7373
7374       if (charfunc)
7375         {
7376           push_parm_decl (length);
7377           ffecom_func_length_ = length;
7378         }
7379     }
7380
7381   if (ffecom_primary_entry_is_proc_)
7382     {
7383       if (altentries)
7384         arglist = ffecom_master_arglist_;
7385       else
7386         arglist = ffesymbol_dummyargs (fn);
7387       ffecom_push_dummy_decls_ (arglist, FALSE);
7388     }
7389
7390   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7391     store_parm_decls (main_program ? 1 : 0);
7392
7393   ffecom_start_compstmt ();
7394   /* Disallow temp vars at this level.  */
7395   current_binding_level->prep_state = 2;
7396
7397   lineno = old_lineno;
7398   input_filename = old_input_filename;
7399
7400   /* This handles any symbols still untransformed, in case -g specified.
7401      This used to be done in ffecom_finish_progunit, but it turns out to
7402      be necessary to do it here so that statement functions are
7403      expanded before code.  But don't bother for BLOCK DATA.  */
7404
7405   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7406     ffesymbol_drive (ffecom_finish_symbol_transform_);
7407 }
7408
7409 #endif
7410 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7411
7412    ffesymbol s;
7413    ffecom_sym_transform_(s);
7414
7415    The ffesymbol_hook info for s is updated with appropriate backend info
7416    on the symbol.  */
7417
7418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7419 static ffesymbol
7420 ffecom_sym_transform_ (ffesymbol s)
7421 {
7422   tree t;                       /* Transformed thingy. */
7423   tree tlen;                    /* Length if CHAR*(*). */
7424   bool addr;                    /* Is t the address of the thingy? */
7425   ffeinfoBasictype bt;
7426   ffeinfoKindtype kt;
7427   ffeglobal g;
7428   int old_lineno = lineno;
7429   const char *old_input_filename = input_filename;
7430
7431   /* Must ensure special ASSIGN variables are declared at top of outermost
7432      block, else they'll end up in the innermost block when their first
7433      ASSIGN is seen, which leaves them out of scope when they're the
7434      subject of a GOTO or I/O statement.
7435
7436      We make this variable even if -fugly-assign.  Just let it go unused,
7437      in case it turns out there are cases where we really want to use this
7438      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7439
7440   if (! ffecom_transform_only_dummies_
7441       && ffesymbol_assigned (s)
7442       && ! ffesymbol_hook (s).assign_tree)
7443     s = ffecom_sym_transform_assign_ (s);
7444
7445   if (ffesymbol_sfdummyparent (s) == NULL)
7446     {
7447       input_filename = ffesymbol_where_filename (s);
7448       lineno = ffesymbol_where_filelinenum (s);
7449     }
7450   else
7451     {
7452       ffesymbol sf = ffesymbol_sfdummyparent (s);
7453
7454       input_filename = ffesymbol_where_filename (sf);
7455       lineno = ffesymbol_where_filelinenum (sf);
7456     }
7457
7458   bt = ffeinfo_basictype (ffebld_info (s));
7459   kt = ffeinfo_kindtype (ffebld_info (s));
7460
7461   t = NULL_TREE;
7462   tlen = NULL_TREE;
7463   addr = FALSE;
7464
7465   switch (ffesymbol_kind (s))
7466     {
7467     case FFEINFO_kindNONE:
7468       switch (ffesymbol_where (s))
7469         {
7470         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7471           assert (ffecom_transform_only_dummies_);
7472
7473           /* Before 0.4, this could be ENTITY/DUMMY, but see
7474              ffestu_sym_end_transition -- no longer true (in particular, if
7475              it could be an ENTITY, it _will_ be made one, so that
7476              possibility won't come through here).  So we never make length
7477              arg for CHARACTER type.  */
7478
7479           t = build_decl (PARM_DECL,
7480                           ffecom_get_identifier_ (ffesymbol_text (s)),
7481                           ffecom_tree_ptr_to_subr_type);
7482 #if BUILT_FOR_270
7483           DECL_ARTIFICIAL (t) = 1;
7484 #endif
7485           addr = TRUE;
7486           break;
7487
7488         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7489           assert (!ffecom_transform_only_dummies_);
7490
7491           if (((g = ffesymbol_global (s)) != NULL)
7492               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7493                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7494                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7495               && (ffeglobal_hook (g) != NULL_TREE)
7496               && ffe_is_globals ())
7497             {
7498               t = ffeglobal_hook (g);
7499               break;
7500             }
7501
7502           t = build_decl (FUNCTION_DECL,
7503                           ffecom_get_external_identifier_ (s),
7504                           ffecom_tree_subr_type);       /* Assume subr. */
7505           DECL_EXTERNAL (t) = 1;
7506           TREE_PUBLIC (t) = 1;
7507
7508           t = start_decl (t, FALSE);
7509           finish_decl (t, NULL_TREE, FALSE);
7510
7511           if ((g != NULL)
7512               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7513                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7514                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7515             ffeglobal_set_hook (g, t);
7516
7517           ffecom_save_tree_forever (t);
7518
7519           break;
7520
7521         default:
7522           assert ("NONE where unexpected" == NULL);
7523           /* Fall through. */
7524         case FFEINFO_whereANY:
7525           break;
7526         }
7527       break;
7528
7529     case FFEINFO_kindENTITY:
7530       switch (ffeinfo_where (ffesymbol_info (s)))
7531         {
7532
7533         case FFEINFO_whereCONSTANT:
7534           /* ~~Debugging info needed? */
7535           assert (!ffecom_transform_only_dummies_);
7536           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7537           break;
7538
7539         case FFEINFO_whereLOCAL:
7540           assert (!ffecom_transform_only_dummies_);
7541
7542           {
7543             ffestorag st = ffesymbol_storage (s);
7544             tree type;
7545
7546             if ((st != NULL)
7547                 && (ffestorag_size (st) == 0))
7548               {
7549                 t = error_mark_node;
7550                 break;
7551               }
7552
7553             type = ffecom_type_localvar_ (s, bt, kt);
7554
7555             if (type == error_mark_node)
7556               {
7557                 t = error_mark_node;
7558                 break;
7559               }
7560
7561             if ((st != NULL)
7562                 && (ffestorag_parent (st) != NULL))
7563               {                 /* Child of EQUIVALENCE parent. */
7564                 ffestorag est;
7565                 tree et;
7566                 ffetargetOffset offset;
7567
7568                 est = ffestorag_parent (st);
7569                 ffecom_transform_equiv_ (est);
7570
7571                 et = ffestorag_hook (est);
7572                 assert (et != NULL_TREE);
7573
7574                 if (! TREE_STATIC (et))
7575                   put_var_into_stack (et);
7576
7577                 offset = ffestorag_modulo (est)
7578                   + ffestorag_offset (ffesymbol_storage (s))
7579                   - ffestorag_offset (est);
7580
7581                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7582
7583                 /* (t_type *) (((char *) &et) + offset) */
7584
7585                 t = convert (string_type_node,  /* (char *) */
7586                              ffecom_1 (ADDR_EXPR,
7587                                        build_pointer_type (TREE_TYPE (et)),
7588                                        et));
7589                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7590                               t,
7591                               build_int_2 (offset, 0));
7592                 t = convert (build_pointer_type (type),
7593                              t);
7594                 TREE_CONSTANT (t) = staticp (et);
7595
7596                 addr = TRUE;
7597               }
7598             else
7599               {
7600                 tree initexpr;
7601                 bool init = ffesymbol_is_init (s);
7602
7603                 t = build_decl (VAR_DECL,
7604                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7605                                 type);
7606
7607                 if (init
7608                     || ffesymbol_namelisted (s)
7609 #ifdef FFECOM_sizeMAXSTACKITEM
7610                     || ((st != NULL)
7611                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7612 #endif
7613                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7614                         && (ffecom_primary_entry_kind_
7615                             != FFEINFO_kindBLOCKDATA)
7616                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7617                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7618                 else
7619                   TREE_STATIC (t) = 0;  /* No need to make static. */
7620
7621                 if (init || ffe_is_init_local_zero ())
7622                   DECL_INITIAL (t) = error_mark_node;
7623
7624                 /* Keep -Wunused from complaining about var if it
7625                    is used as sfunc arg or DATA implied-DO.  */
7626                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7627                   DECL_IN_SYSTEM_HEADER (t) = 1;
7628
7629                 t = start_decl (t, FALSE);
7630
7631                 if (init)
7632                   {
7633                     if (ffesymbol_init (s) != NULL)
7634                       initexpr = ffecom_expr (ffesymbol_init (s));
7635                     else
7636                       initexpr = ffecom_init_zero_ (t);
7637                   }
7638                 else if (ffe_is_init_local_zero ())
7639                   initexpr = ffecom_init_zero_ (t);
7640                 else
7641                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7642
7643                 finish_decl (t, initexpr, FALSE);
7644
7645                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7646                   {
7647                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7648                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7649                                                    ffestorag_size (st)));
7650                   }
7651               }
7652           }
7653           break;
7654
7655         case FFEINFO_whereRESULT:
7656           assert (!ffecom_transform_only_dummies_);
7657
7658           if (bt == FFEINFO_basictypeCHARACTER)
7659             {                   /* Result is already in list of dummies, use
7660                                    it (& length). */
7661               t = ffecom_func_result_;
7662               tlen = ffecom_func_length_;
7663               addr = TRUE;
7664               break;
7665             }
7666           if ((ffecom_num_entrypoints_ == 0)
7667               && (bt == FFEINFO_basictypeCOMPLEX)
7668               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7669             {                   /* Result is already in list of dummies, use
7670                                    it. */
7671               t = ffecom_func_result_;
7672               addr = TRUE;
7673               break;
7674             }
7675           if (ffecom_func_result_ != NULL_TREE)
7676             {
7677               t = ffecom_func_result_;
7678               break;
7679             }
7680           if ((ffecom_num_entrypoints_ != 0)
7681               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7682             {
7683               assert (ffecom_multi_retval_ != NULL_TREE);
7684               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7685                             ffecom_multi_retval_);
7686               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7687                             t, ffecom_multi_fields_[bt][kt]);
7688
7689               break;
7690             }
7691
7692           t = build_decl (VAR_DECL,
7693                           ffecom_get_identifier_ (ffesymbol_text (s)),
7694                           ffecom_tree_type[bt][kt]);
7695           TREE_STATIC (t) = 0;  /* Put result on stack. */
7696           t = start_decl (t, FALSE);
7697           finish_decl (t, NULL_TREE, FALSE);
7698
7699           ffecom_func_result_ = t;
7700
7701           break;
7702
7703         case FFEINFO_whereDUMMY:
7704           {
7705             tree type;
7706             ffebld dl;
7707             ffebld dim;
7708             tree low;
7709             tree high;
7710             tree old_sizes;
7711             bool adjustable = FALSE;    /* Conditionally adjustable? */
7712
7713             type = ffecom_tree_type[bt][kt];
7714             if (ffesymbol_sfdummyparent (s) != NULL)
7715               {
7716                 if (current_function_decl == ffecom_outer_function_decl_)
7717                   {                     /* Exec transition before sfunc
7718                                            context; get it later. */
7719                     break;
7720                   }
7721                 t = ffecom_get_identifier_ (ffesymbol_text
7722                                             (ffesymbol_sfdummyparent (s)));
7723               }
7724             else
7725               t = ffecom_get_identifier_ (ffesymbol_text (s));
7726
7727             assert (ffecom_transform_only_dummies_);
7728
7729             old_sizes = get_pending_sizes ();
7730             put_pending_sizes (old_sizes);
7731
7732             if (bt == FFEINFO_basictypeCHARACTER)
7733               tlen = ffecom_char_enhance_arg_ (&type, s);
7734             type = ffecom_check_size_overflow_ (s, type, TRUE);
7735
7736             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7737               {
7738                 if (type == error_mark_node)
7739                   break;
7740
7741                 dim = ffebld_head (dl);
7742                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7743                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7744                   low = ffecom_integer_one_node;
7745                 else
7746                   low = ffecom_expr (ffebld_left (dim));
7747                 assert (ffebld_right (dim) != NULL);
7748                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7749                     || ffecom_doing_entry_)
7750                   {
7751                     /* Used to just do high=low.  But for ffecom_tree_
7752                        canonize_ref_, it probably is important to correctly
7753                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7754                        C(2)=CFUNC(C), overlap can happen, while it can't
7755                        for, say, C(1)=CFUNC(C(2)).  */
7756                     /* Even more recently used to set to INT_MAX, but that
7757                        broke when some overflow checking went into the back
7758                        end.  Now we just leave the upper bound unspecified.  */
7759                     high = NULL;
7760                   }
7761                 else
7762                   high = ffecom_expr (ffebld_right (dim));
7763
7764                 /* Determine whether array is conditionally adjustable,
7765                    to decide whether back-end magic is needed.
7766
7767                    Normally the front end uses the back-end function
7768                    variable_size to wrap SAVE_EXPR's around expressions
7769                    affecting the size/shape of an array so that the
7770                    size/shape info doesn't change during execution
7771                    of the compiled code even though variables and
7772                    functions referenced in those expressions might.
7773
7774                    variable_size also makes sure those saved expressions
7775                    get evaluated immediately upon entry to the
7776                    compiled procedure -- the front end normally doesn't
7777                    have to worry about that.
7778
7779                    However, there is a problem with this that affects
7780                    g77's implementation of entry points, and that is
7781                    that it is _not_ true that each invocation of the
7782                    compiled procedure is permitted to evaluate
7783                    array size/shape info -- because it is possible
7784                    that, for some invocations, that info is invalid (in
7785                    which case it is "promised" -- i.e. a violation of
7786                    the Fortran standard -- that the compiled code
7787                    won't reference the array or its size/shape
7788                    during that particular invocation).
7789
7790                    To phrase this in C terms, consider this gcc function:
7791
7792                      void foo (int *n, float (*a)[*n])
7793                      {
7794                        // a is "pointer to array ...", fyi.
7795                      }
7796
7797                    Suppose that, for some invocations, it is permitted
7798                    for a caller of foo to do this:
7799
7800                        foo (NULL, NULL);
7801
7802                    Now the _written_ code for foo can take such a call
7803                    into account by either testing explicitly for whether
7804                    (a == NULL) || (n == NULL) -- presumably it is
7805                    not permitted to reference *a in various fashions
7806                    if (n == NULL) I suppose -- or it can avoid it by
7807                    looking at other info (other arguments, static/global
7808                    data, etc.).
7809
7810                    However, this won't work in gcc 2.5.8 because it'll
7811                    automatically emit the code to save the "*n"
7812                    expression, which'll yield a NULL dereference for
7813                    the "foo (NULL, NULL)" call, something the code
7814                    for foo cannot prevent.
7815
7816                    g77 definitely needs to avoid executing such
7817                    code anytime the pointer to the adjustable array
7818                    is NULL, because even if its bounds expressions
7819                    don't have any references to possible "absent"
7820                    variables like "*n" -- say all variable references
7821                    are to COMMON variables, i.e. global (though in C,
7822                    local static could actually make sense) -- the
7823                    expressions could yield other run-time problems
7824                    for allowably "dead" values in those variables.
7825
7826                    For example, let's consider a more complicated
7827                    version of foo:
7828
7829                      extern int i;
7830                      extern int j;
7831
7832                      void foo (float (*a)[i/j])
7833                      {
7834                        ...
7835                      }
7836
7837                    The above is (essentially) quite valid for Fortran
7838                    but, again, for a call like "foo (NULL);", it is
7839                    permitted for i and j to be undefined when the
7840                    call is made.  If j happened to be zero, for
7841                    example, emitting the code to evaluate "i/j"
7842                    could result in a run-time error.
7843
7844                    Offhand, though I don't have my F77 or F90
7845                    standards handy, it might even be valid for a
7846                    bounds expression to contain a function reference,
7847                    in which case I doubt it is permitted for an
7848                    implementation to invoke that function in the
7849                    Fortran case involved here (invocation of an
7850                    alternate ENTRY point that doesn't have the adjustable
7851                    array as one of its arguments).
7852
7853                    So, the code that the compiler would normally emit
7854                    to preevaluate the size/shape info for an
7855                    adjustable array _must not_ be executed at run time
7856                    in certain cases.  Specifically, for Fortran,
7857                    the case is when the pointer to the adjustable
7858                    array == NULL.  (For gnu-ish C, it might be nice
7859                    for the source code itself to specify an expression
7860                    that, if TRUE, inhibits execution of the code.  Or
7861                    reverse the sense for elegance.)
7862
7863                    (Note that g77 could use a different test than NULL,
7864                    actually, since it happens to always pass an
7865                    integer to the called function that specifies which
7866                    entry point is being invoked.  Hmm, this might
7867                    solve the next problem.)
7868
7869                    One way a user could, I suppose, write "foo" so
7870                    it works is to insert COND_EXPR's for the
7871                    size/shape info so the dangerous stuff isn't
7872                    actually done, as in:
7873
7874                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7875                      {
7876                        ...
7877                      }
7878
7879                    The next problem is that the front end needs to
7880                    be able to tell the back end about the array's
7881                    decl _before_ it tells it about the conditional
7882                    expression to inhibit evaluation of size/shape info,
7883                    as shown above.
7884
7885                    To solve this, the front end needs to be able
7886                    to give the back end the expression to inhibit
7887                    generation of the preevaluation code _after_
7888                    it makes the decl for the adjustable array.
7889
7890                    Until then, the above example using the COND_EXPR
7891                    doesn't pass muster with gcc because the "(a == NULL)"
7892                    part has a reference to "a", which is still
7893                    undefined at that point.
7894
7895                    g77 will therefore use a different mechanism in the
7896                    meantime.  */
7897
7898                 if (!adjustable
7899                     && ((TREE_CODE (low) != INTEGER_CST)
7900                         || (high && TREE_CODE (high) != INTEGER_CST)))
7901                   adjustable = TRUE;
7902
7903 #if 0                           /* Old approach -- see below. */
7904                 if (TREE_CODE (low) != INTEGER_CST)
7905                   low = ffecom_3 (COND_EXPR, integer_type_node,
7906                                   ffecom_adjarray_passed_ (s),
7907                                   low,
7908                                   ffecom_integer_zero_node);
7909
7910                 if (high && TREE_CODE (high) != INTEGER_CST)
7911                   high = ffecom_3 (COND_EXPR, integer_type_node,
7912                                    ffecom_adjarray_passed_ (s),
7913                                    high,
7914                                    ffecom_integer_zero_node);
7915 #endif
7916
7917                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7918                    probably.  Fixes 950302-1.f.  */
7919
7920                 if (TREE_CODE (low) != INTEGER_CST)
7921                   low = variable_size (low);
7922
7923                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7924                    does this, which is why dumb0.c would work.  */
7925
7926                 if (high && TREE_CODE (high) != INTEGER_CST)
7927                   high = variable_size (high);
7928
7929                 type
7930                   = build_array_type
7931                     (type,
7932                      build_range_type (ffecom_integer_type_node,
7933                                        low, high));
7934                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7935               }
7936
7937             if (type == error_mark_node)
7938               {
7939                 t = error_mark_node;
7940                 break;
7941               }
7942
7943             if ((ffesymbol_sfdummyparent (s) == NULL)
7944                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7945               {
7946                 type = build_pointer_type (type);
7947                 addr = TRUE;
7948               }
7949
7950             t = build_decl (PARM_DECL, t, type);
7951 #if BUILT_FOR_270
7952             DECL_ARTIFICIAL (t) = 1;
7953 #endif
7954
7955             /* If this arg is present in every entry point's list of
7956                dummy args, then we're done.  */
7957
7958             if (ffesymbol_numentries (s)
7959                 == (ffecom_num_entrypoints_ + 1))
7960               break;
7961
7962 #if 1
7963
7964             /* If variable_size in stor-layout has been called during
7965                the above, then get_pending_sizes should have the
7966                yet-to-be-evaluated saved expressions pending.
7967                Make the whole lot of them get emitted, conditionally
7968                on whether the array decl ("t" above) is not NULL.  */
7969
7970             {
7971               tree sizes = get_pending_sizes ();
7972               tree tem;
7973
7974               for (tem = sizes;
7975                    tem != old_sizes;
7976                    tem = TREE_CHAIN (tem))
7977                 {
7978                   tree temv = TREE_VALUE (tem);
7979
7980                   if (sizes == tem)
7981                     sizes = temv;
7982                   else
7983                     sizes
7984                       = ffecom_2 (COMPOUND_EXPR,
7985                                   TREE_TYPE (sizes),
7986                                   temv,
7987                                   sizes);
7988                 }
7989
7990               if (sizes != tem)
7991                 {
7992                   sizes
7993                     = ffecom_3 (COND_EXPR,
7994                                 TREE_TYPE (sizes),
7995                                 ffecom_2 (NE_EXPR,
7996                                           integer_type_node,
7997                                           t,
7998                                           null_pointer_node),
7999                                 sizes,
8000                                 convert (TREE_TYPE (sizes),
8001                                          integer_zero_node));
8002                   sizes = ffecom_save_tree (sizes);
8003
8004                   sizes
8005                     = tree_cons (NULL_TREE, sizes, tem);
8006                 }
8007
8008               if (sizes)
8009                 put_pending_sizes (sizes);
8010             }
8011
8012 #else
8013 #if 0
8014             if (adjustable
8015                 && (ffesymbol_numentries (s)
8016                     != ffecom_num_entrypoints_ + 1))
8017               DECL_SOMETHING (t)
8018                 = ffecom_2 (NE_EXPR, integer_type_node,
8019                             t,
8020                             null_pointer_node);
8021 #else
8022 #if 0
8023             if (adjustable
8024                 && (ffesymbol_numentries (s)
8025                     != ffecom_num_entrypoints_ + 1))
8026               {
8027                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8028                 ffebad_here (0, ffesymbol_where_line (s),
8029                              ffesymbol_where_column (s));
8030                 ffebad_string (ffesymbol_text (s));
8031                 ffebad_finish ();
8032               }
8033 #endif
8034 #endif
8035 #endif
8036           }
8037           break;
8038
8039         case FFEINFO_whereCOMMON:
8040           {
8041             ffesymbol cs;
8042             ffeglobal cg;
8043             tree ct;
8044             ffestorag st = ffesymbol_storage (s);
8045             tree type;
8046
8047             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8048             if (st != NULL)     /* Else not laid out. */
8049               {
8050                 ffecom_transform_common_ (cs);
8051                 st = ffesymbol_storage (s);
8052               }
8053
8054             type = ffecom_type_localvar_ (s, bt, kt);
8055
8056             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8057             if ((cg == NULL)
8058                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8059               ct = NULL_TREE;
8060             else
8061               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8062
8063             if ((ct == NULL_TREE)
8064                 || (st == NULL)
8065                 || (type == error_mark_node))
8066               t = error_mark_node;
8067             else
8068               {
8069                 ffetargetOffset offset;
8070                 ffestorag cst;
8071
8072                 cst = ffestorag_parent (st);
8073                 assert (cst == ffesymbol_storage (cs));
8074
8075                 offset = ffestorag_modulo (cst)
8076                   + ffestorag_offset (st)
8077                   - ffestorag_offset (cst);
8078
8079                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8080
8081                 /* (t_type *) (((char *) &ct) + offset) */
8082
8083                 t = convert (string_type_node,  /* (char *) */
8084                              ffecom_1 (ADDR_EXPR,
8085                                        build_pointer_type (TREE_TYPE (ct)),
8086                                        ct));
8087                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8088                               t,
8089                               build_int_2 (offset, 0));
8090                 t = convert (build_pointer_type (type),
8091                              t);
8092                 TREE_CONSTANT (t) = 1;
8093
8094                 addr = TRUE;
8095               }
8096           }
8097           break;
8098
8099         case FFEINFO_whereIMMEDIATE:
8100         case FFEINFO_whereGLOBAL:
8101         case FFEINFO_whereFLEETING:
8102         case FFEINFO_whereFLEETING_CADDR:
8103         case FFEINFO_whereFLEETING_IADDR:
8104         case FFEINFO_whereINTRINSIC:
8105         case FFEINFO_whereCONSTANT_SUBOBJECT:
8106         default:
8107           assert ("ENTITY where unheard of" == NULL);
8108           /* Fall through. */
8109         case FFEINFO_whereANY:
8110           t = error_mark_node;
8111           break;
8112         }
8113       break;
8114
8115     case FFEINFO_kindFUNCTION:
8116       switch (ffeinfo_where (ffesymbol_info (s)))
8117         {
8118         case FFEINFO_whereLOCAL:        /* Me. */
8119           assert (!ffecom_transform_only_dummies_);
8120           t = current_function_decl;
8121           break;
8122
8123         case FFEINFO_whereGLOBAL:
8124           assert (!ffecom_transform_only_dummies_);
8125
8126           if (((g = ffesymbol_global (s)) != NULL)
8127               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8128                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8129               && (ffeglobal_hook (g) != NULL_TREE)
8130               && ffe_is_globals ())
8131             {
8132               t = ffeglobal_hook (g);
8133               break;
8134             }
8135
8136           if (ffesymbol_is_f2c (s)
8137               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8138             t = ffecom_tree_fun_type[bt][kt];
8139           else
8140             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8141
8142           t = build_decl (FUNCTION_DECL,
8143                           ffecom_get_external_identifier_ (s),
8144                           t);
8145           DECL_EXTERNAL (t) = 1;
8146           TREE_PUBLIC (t) = 1;
8147
8148           t = start_decl (t, FALSE);
8149           finish_decl (t, NULL_TREE, FALSE);
8150
8151           if ((g != NULL)
8152               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8153                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8154             ffeglobal_set_hook (g, t);
8155
8156           ffecom_save_tree_forever (t);
8157
8158           break;
8159
8160         case FFEINFO_whereDUMMY:
8161           assert (ffecom_transform_only_dummies_);
8162
8163           if (ffesymbol_is_f2c (s)
8164               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8165             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8166           else
8167             t = build_pointer_type
8168               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8169
8170           t = build_decl (PARM_DECL,
8171                           ffecom_get_identifier_ (ffesymbol_text (s)),
8172                           t);
8173 #if BUILT_FOR_270
8174           DECL_ARTIFICIAL (t) = 1;
8175 #endif
8176           addr = TRUE;
8177           break;
8178
8179         case FFEINFO_whereCONSTANT:     /* Statement function. */
8180           assert (!ffecom_transform_only_dummies_);
8181           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8182           break;
8183
8184         case FFEINFO_whereINTRINSIC:
8185           assert (!ffecom_transform_only_dummies_);
8186           break;                /* Let actual references generate their
8187                                    decls. */
8188
8189         default:
8190           assert ("FUNCTION where unheard of" == NULL);
8191           /* Fall through. */
8192         case FFEINFO_whereANY:
8193           t = error_mark_node;
8194           break;
8195         }
8196       break;
8197
8198     case FFEINFO_kindSUBROUTINE:
8199       switch (ffeinfo_where (ffesymbol_info (s)))
8200         {
8201         case FFEINFO_whereLOCAL:        /* Me. */
8202           assert (!ffecom_transform_only_dummies_);
8203           t = current_function_decl;
8204           break;
8205
8206         case FFEINFO_whereGLOBAL:
8207           assert (!ffecom_transform_only_dummies_);
8208
8209           if (((g = ffesymbol_global (s)) != NULL)
8210               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8211                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8212               && (ffeglobal_hook (g) != NULL_TREE)
8213               && ffe_is_globals ())
8214             {
8215               t = ffeglobal_hook (g);
8216               break;
8217             }
8218
8219           t = build_decl (FUNCTION_DECL,
8220                           ffecom_get_external_identifier_ (s),
8221                           ffecom_tree_subr_type);
8222           DECL_EXTERNAL (t) = 1;
8223           TREE_PUBLIC (t) = 1;
8224
8225           t = start_decl (t, FALSE);
8226           finish_decl (t, NULL_TREE, FALSE);
8227
8228           if ((g != NULL)
8229               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8230                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8231             ffeglobal_set_hook (g, t);
8232
8233           ffecom_save_tree_forever (t);
8234
8235           break;
8236
8237         case FFEINFO_whereDUMMY:
8238           assert (ffecom_transform_only_dummies_);
8239
8240           t = build_decl (PARM_DECL,
8241                           ffecom_get_identifier_ (ffesymbol_text (s)),
8242                           ffecom_tree_ptr_to_subr_type);
8243 #if BUILT_FOR_270
8244           DECL_ARTIFICIAL (t) = 1;
8245 #endif
8246           addr = TRUE;
8247           break;
8248
8249         case FFEINFO_whereINTRINSIC:
8250           assert (!ffecom_transform_only_dummies_);
8251           break;                /* Let actual references generate their
8252                                    decls. */
8253
8254         default:
8255           assert ("SUBROUTINE where unheard of" == NULL);
8256           /* Fall through. */
8257         case FFEINFO_whereANY:
8258           t = error_mark_node;
8259           break;
8260         }
8261       break;
8262
8263     case FFEINFO_kindPROGRAM:
8264       switch (ffeinfo_where (ffesymbol_info (s)))
8265         {
8266         case FFEINFO_whereLOCAL:        /* Me. */
8267           assert (!ffecom_transform_only_dummies_);
8268           t = current_function_decl;
8269           break;
8270
8271         case FFEINFO_whereCOMMON:
8272         case FFEINFO_whereDUMMY:
8273         case FFEINFO_whereGLOBAL:
8274         case FFEINFO_whereRESULT:
8275         case FFEINFO_whereFLEETING:
8276         case FFEINFO_whereFLEETING_CADDR:
8277         case FFEINFO_whereFLEETING_IADDR:
8278         case FFEINFO_whereIMMEDIATE:
8279         case FFEINFO_whereINTRINSIC:
8280         case FFEINFO_whereCONSTANT:
8281         case FFEINFO_whereCONSTANT_SUBOBJECT:
8282         default:
8283           assert ("PROGRAM where unheard of" == NULL);
8284           /* Fall through. */
8285         case FFEINFO_whereANY:
8286           t = error_mark_node;
8287           break;
8288         }
8289       break;
8290
8291     case FFEINFO_kindBLOCKDATA:
8292       switch (ffeinfo_where (ffesymbol_info (s)))
8293         {
8294         case FFEINFO_whereLOCAL:        /* Me. */
8295           assert (!ffecom_transform_only_dummies_);
8296           t = current_function_decl;
8297           break;
8298
8299         case FFEINFO_whereGLOBAL:
8300           assert (!ffecom_transform_only_dummies_);
8301
8302           t = build_decl (FUNCTION_DECL,
8303                           ffecom_get_external_identifier_ (s),
8304                           ffecom_tree_blockdata_type);
8305           DECL_EXTERNAL (t) = 1;
8306           TREE_PUBLIC (t) = 1;
8307
8308           t = start_decl (t, FALSE);
8309           finish_decl (t, NULL_TREE, FALSE);
8310
8311           ffecom_save_tree_forever (t);
8312
8313           break;
8314
8315         case FFEINFO_whereCOMMON:
8316         case FFEINFO_whereDUMMY:
8317         case FFEINFO_whereRESULT:
8318         case FFEINFO_whereFLEETING:
8319         case FFEINFO_whereFLEETING_CADDR:
8320         case FFEINFO_whereFLEETING_IADDR:
8321         case FFEINFO_whereIMMEDIATE:
8322         case FFEINFO_whereINTRINSIC:
8323         case FFEINFO_whereCONSTANT:
8324         case FFEINFO_whereCONSTANT_SUBOBJECT:
8325         default:
8326           assert ("BLOCKDATA where unheard of" == NULL);
8327           /* Fall through. */
8328         case FFEINFO_whereANY:
8329           t = error_mark_node;
8330           break;
8331         }
8332       break;
8333
8334     case FFEINFO_kindCOMMON:
8335       switch (ffeinfo_where (ffesymbol_info (s)))
8336         {
8337         case FFEINFO_whereLOCAL:
8338           assert (!ffecom_transform_only_dummies_);
8339           ffecom_transform_common_ (s);
8340           break;
8341
8342         case FFEINFO_whereNONE:
8343         case FFEINFO_whereCOMMON:
8344         case FFEINFO_whereDUMMY:
8345         case FFEINFO_whereGLOBAL:
8346         case FFEINFO_whereRESULT:
8347         case FFEINFO_whereFLEETING:
8348         case FFEINFO_whereFLEETING_CADDR:
8349         case FFEINFO_whereFLEETING_IADDR:
8350         case FFEINFO_whereIMMEDIATE:
8351         case FFEINFO_whereINTRINSIC:
8352         case FFEINFO_whereCONSTANT:
8353         case FFEINFO_whereCONSTANT_SUBOBJECT:
8354         default:
8355           assert ("COMMON where unheard of" == NULL);
8356           /* Fall through. */
8357         case FFEINFO_whereANY:
8358           t = error_mark_node;
8359           break;
8360         }
8361       break;
8362
8363     case FFEINFO_kindCONSTRUCT:
8364       switch (ffeinfo_where (ffesymbol_info (s)))
8365         {
8366         case FFEINFO_whereLOCAL:
8367           assert (!ffecom_transform_only_dummies_);
8368           break;
8369
8370         case FFEINFO_whereNONE:
8371         case FFEINFO_whereCOMMON:
8372         case FFEINFO_whereDUMMY:
8373         case FFEINFO_whereGLOBAL:
8374         case FFEINFO_whereRESULT:
8375         case FFEINFO_whereFLEETING:
8376         case FFEINFO_whereFLEETING_CADDR:
8377         case FFEINFO_whereFLEETING_IADDR:
8378         case FFEINFO_whereIMMEDIATE:
8379         case FFEINFO_whereINTRINSIC:
8380         case FFEINFO_whereCONSTANT:
8381         case FFEINFO_whereCONSTANT_SUBOBJECT:
8382         default:
8383           assert ("CONSTRUCT where unheard of" == NULL);
8384           /* Fall through. */
8385         case FFEINFO_whereANY:
8386           t = error_mark_node;
8387           break;
8388         }
8389       break;
8390
8391     case FFEINFO_kindNAMELIST:
8392       switch (ffeinfo_where (ffesymbol_info (s)))
8393         {
8394         case FFEINFO_whereLOCAL:
8395           assert (!ffecom_transform_only_dummies_);
8396           t = ffecom_transform_namelist_ (s);
8397           break;
8398
8399         case FFEINFO_whereNONE:
8400         case FFEINFO_whereCOMMON:
8401         case FFEINFO_whereDUMMY:
8402         case FFEINFO_whereGLOBAL:
8403         case FFEINFO_whereRESULT:
8404         case FFEINFO_whereFLEETING:
8405         case FFEINFO_whereFLEETING_CADDR:
8406         case FFEINFO_whereFLEETING_IADDR:
8407         case FFEINFO_whereIMMEDIATE:
8408         case FFEINFO_whereINTRINSIC:
8409         case FFEINFO_whereCONSTANT:
8410         case FFEINFO_whereCONSTANT_SUBOBJECT:
8411         default:
8412           assert ("NAMELIST where unheard of" == NULL);
8413           /* Fall through. */
8414         case FFEINFO_whereANY:
8415           t = error_mark_node;
8416           break;
8417         }
8418       break;
8419
8420     default:
8421       assert ("kind unheard of" == NULL);
8422       /* Fall through. */
8423     case FFEINFO_kindANY:
8424       t = error_mark_node;
8425       break;
8426     }
8427
8428   ffesymbol_hook (s).decl_tree = t;
8429   ffesymbol_hook (s).length_tree = tlen;
8430   ffesymbol_hook (s).addr = addr;
8431
8432   lineno = old_lineno;
8433   input_filename = old_input_filename;
8434
8435   return s;
8436 }
8437
8438 #endif
8439 /* Transform into ASSIGNable symbol.
8440
8441    Symbol has already been transformed, but for whatever reason, the
8442    resulting decl_tree has been deemed not usable for an ASSIGN target.
8443    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8444    another local symbol of type void * and stuff that in the assign_tree
8445    argument.  The F77/F90 standards allow this implementation.  */
8446
8447 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8448 static ffesymbol
8449 ffecom_sym_transform_assign_ (ffesymbol s)
8450 {
8451   tree t;                       /* Transformed thingy. */
8452   int old_lineno = lineno;
8453   const char *old_input_filename = input_filename;
8454
8455   if (ffesymbol_sfdummyparent (s) == NULL)
8456     {
8457       input_filename = ffesymbol_where_filename (s);
8458       lineno = ffesymbol_where_filelinenum (s);
8459     }
8460   else
8461     {
8462       ffesymbol sf = ffesymbol_sfdummyparent (s);
8463
8464       input_filename = ffesymbol_where_filename (sf);
8465       lineno = ffesymbol_where_filelinenum (sf);
8466     }
8467
8468   assert (!ffecom_transform_only_dummies_);
8469
8470   t = build_decl (VAR_DECL,
8471                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8472                                                    ffesymbol_text (s)),
8473                   TREE_TYPE (null_pointer_node));
8474
8475   switch (ffesymbol_where (s))
8476     {
8477     case FFEINFO_whereLOCAL:
8478       /* Unlike for regular vars, SAVE status is easy to determine for
8479          ASSIGNed vars, since there's no initialization, there's no
8480          effective storage association (so "SAVE J" does not apply to
8481          K even given "EQUIVALENCE (J,K)"), there's no size issue
8482          to worry about, etc.  */
8483       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8484           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8485           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8486         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8487       else
8488         TREE_STATIC (t) = 0;    /* No need to make static. */
8489       break;
8490
8491     case FFEINFO_whereCOMMON:
8492       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8493       break;
8494
8495     case FFEINFO_whereDUMMY:
8496       /* Note that twinning a DUMMY means the caller won't see
8497          the ASSIGNed value.  But both F77 and F90 allow implementations
8498          to do this, i.e. disallow Fortran code that would try and
8499          take advantage of actually putting a label into a variable
8500          via a dummy argument (or any other storage association, for
8501          that matter).  */
8502       TREE_STATIC (t) = 0;
8503       break;
8504
8505     default:
8506       TREE_STATIC (t) = 0;
8507       break;
8508     }
8509
8510   t = start_decl (t, FALSE);
8511   finish_decl (t, NULL_TREE, FALSE);
8512
8513   ffesymbol_hook (s).assign_tree = t;
8514
8515   lineno = old_lineno;
8516   input_filename = old_input_filename;
8517
8518   return s;
8519 }
8520
8521 #endif
8522 /* Implement COMMON area in back end.
8523
8524    Because COMMON-based variables can be referenced in the dimension
8525    expressions of dummy (adjustable) arrays, and because dummies
8526    (in the gcc back end) need to be put in the outer binding level
8527    of a function (which has two binding levels, the outer holding
8528    the dummies and the inner holding the other vars), special care
8529    must be taken to handle COMMON areas.
8530
8531    The current strategy is basically to always tell the back end about
8532    the COMMON area as a top-level external reference to just a block
8533    of storage of the master type of that area (e.g. integer, real,
8534    character, whatever -- not a structure).  As a distinct action,
8535    if initial values are provided, tell the back end about the area
8536    as a top-level non-external (initialized) area and remember not to
8537    allow further initialization or expansion of the area.  Meanwhile,
8538    if no initialization happens at all, tell the back end about
8539    the largest size we've seen declared so the space does get reserved.
8540    (This function doesn't handle all that stuff, but it does some
8541    of the important things.)
8542
8543    Meanwhile, for COMMON variables themselves, just keep creating
8544    references like *((float *) (&common_area + offset)) each time
8545    we reference the variable.  In other words, don't make a VAR_DECL
8546    or any kind of component reference (like we used to do before 0.4),
8547    though we might do that as well just for debugging purposes (and
8548    stuff the rtl with the appropriate offset expression).  */
8549
8550 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8551 static void
8552 ffecom_transform_common_ (ffesymbol s)
8553 {
8554   ffestorag st = ffesymbol_storage (s);
8555   ffeglobal g = ffesymbol_global (s);
8556   tree cbt;
8557   tree cbtype;
8558   tree init;
8559   tree high;
8560   bool is_init = ffestorag_is_init (st);
8561
8562   assert (st != NULL);
8563
8564   if ((g == NULL)
8565       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8566     return;
8567
8568   /* First update the size of the area in global terms.  */
8569
8570   ffeglobal_size_common (s, ffestorag_size (st));
8571
8572   if (!ffeglobal_common_init (g))
8573     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8574
8575   cbt = ffeglobal_hook (g);
8576
8577   /* If we already have declared this common block for a previous program
8578      unit, and either we already initialized it or we don't have new
8579      initialization for it, just return what we have without changing it.  */
8580
8581   if ((cbt != NULL_TREE)
8582       && (!is_init
8583           || !DECL_EXTERNAL (cbt)))
8584     {
8585       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8586       return;
8587     }
8588
8589   /* Process inits.  */
8590
8591   if (is_init)
8592     {
8593       if (ffestorag_init (st) != NULL)
8594         {
8595           ffebld sexp;
8596
8597           /* Set the padding for the expression, so ffecom_expr
8598              knows to insert that many zeros.  */
8599           switch (ffebld_op (sexp = ffestorag_init (st)))
8600             {
8601             case FFEBLD_opCONTER:
8602               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8603               break;
8604
8605             case FFEBLD_opARRTER:
8606               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8607               break;
8608
8609             case FFEBLD_opACCTER:
8610               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8611               break;
8612
8613             default:
8614               assert ("bad op for cmn init (pad)" == NULL);
8615               break;
8616             }
8617
8618           init = ffecom_expr (sexp);
8619           if (init == error_mark_node)
8620             {                   /* Hopefully the back end complained! */
8621               init = NULL_TREE;
8622               if (cbt != NULL_TREE)
8623                 return;
8624             }
8625         }
8626       else
8627         init = error_mark_node;
8628     }
8629   else
8630     init = NULL_TREE;
8631
8632   /* cbtype must be permanently allocated!  */
8633
8634   /* Allocate the MAX of the areas so far, seen filewide.  */
8635   high = build_int_2 ((ffeglobal_common_size (g)
8636                        + ffeglobal_common_pad (g)) - 1, 0);
8637   TREE_TYPE (high) = ffecom_integer_type_node;
8638
8639   if (init)
8640     cbtype = build_array_type (char_type_node,
8641                                build_range_type (integer_type_node,
8642                                                  integer_zero_node,
8643                                                  high));
8644   else
8645     cbtype = build_array_type (char_type_node, NULL_TREE);
8646
8647   if (cbt == NULL_TREE)
8648     {
8649       cbt
8650         = build_decl (VAR_DECL,
8651                       ffecom_get_external_identifier_ (s),
8652                       cbtype);
8653       TREE_STATIC (cbt) = 1;
8654       TREE_PUBLIC (cbt) = 1;
8655     }
8656   else
8657     {
8658       assert (is_init);
8659       TREE_TYPE (cbt) = cbtype;
8660     }
8661   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8662   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8663
8664   cbt = start_decl (cbt, TRUE);
8665   if (ffeglobal_hook (g) != NULL)
8666     assert (cbt == ffeglobal_hook (g));
8667
8668   assert (!init || !DECL_EXTERNAL (cbt));
8669
8670   /* Make sure that any type can live in COMMON and be referenced
8671      without getting a bus error.  We could pick the most restrictive
8672      alignment of all entities actually placed in the COMMON, but
8673      this seems easy enough.  */
8674
8675   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8676   DECL_USER_ALIGN (cbt) = 0;
8677
8678   if (is_init && (ffestorag_init (st) == NULL))
8679     init = ffecom_init_zero_ (cbt);
8680
8681   finish_decl (cbt, init, TRUE);
8682
8683   if (is_init)
8684     ffestorag_set_init (st, ffebld_new_any ());
8685
8686   if (init)
8687     {
8688       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8689       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8690       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8691                                      (ffeglobal_common_size (g)
8692                                       + ffeglobal_common_pad (g))));
8693     }
8694
8695   ffeglobal_set_hook (g, cbt);
8696
8697   ffestorag_set_hook (st, cbt);
8698
8699   ffecom_save_tree_forever (cbt);
8700 }
8701
8702 #endif
8703 /* Make master area for local EQUIVALENCE.  */
8704
8705 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8706 static void
8707 ffecom_transform_equiv_ (ffestorag eqst)
8708 {
8709   tree eqt;
8710   tree eqtype;
8711   tree init;
8712   tree high;
8713   bool is_init = ffestorag_is_init (eqst);
8714
8715   assert (eqst != NULL);
8716
8717   eqt = ffestorag_hook (eqst);
8718
8719   if (eqt != NULL_TREE)
8720     return;
8721
8722   /* Process inits.  */
8723
8724   if (is_init)
8725     {
8726       if (ffestorag_init (eqst) != NULL)
8727         {
8728           ffebld sexp;
8729
8730           /* Set the padding for the expression, so ffecom_expr
8731              knows to insert that many zeros.  */
8732           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8733             {
8734             case FFEBLD_opCONTER:
8735               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8736               break;
8737
8738             case FFEBLD_opARRTER:
8739               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8740               break;
8741
8742             case FFEBLD_opACCTER:
8743               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8744               break;
8745
8746             default:
8747               assert ("bad op for eqv init (pad)" == NULL);
8748               break;
8749             }
8750
8751           init = ffecom_expr (sexp);
8752           if (init == error_mark_node)
8753             init = NULL_TREE;   /* Hopefully the back end complained! */
8754         }
8755       else
8756         init = error_mark_node;
8757     }
8758   else if (ffe_is_init_local_zero ())
8759     init = error_mark_node;
8760   else
8761     init = NULL_TREE;
8762
8763   ffecom_member_namelisted_ = FALSE;
8764   ffestorag_drive (ffestorag_list_equivs (eqst),
8765                    &ffecom_member_phase1_,
8766                    eqst);
8767
8768   high = build_int_2 ((ffestorag_size (eqst)
8769                        + ffestorag_modulo (eqst)) - 1, 0);
8770   TREE_TYPE (high) = ffecom_integer_type_node;
8771
8772   eqtype = build_array_type (char_type_node,
8773                              build_range_type (ffecom_integer_type_node,
8774                                                ffecom_integer_zero_node,
8775                                                high));
8776
8777   eqt = build_decl (VAR_DECL,
8778                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8779                                                     ffesymbol_text
8780                                                     (ffestorag_symbol (eqst))),
8781                     eqtype);
8782   DECL_EXTERNAL (eqt) = 0;
8783   if (is_init
8784       || ffecom_member_namelisted_
8785 #ifdef FFECOM_sizeMAXSTACKITEM
8786       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8787 #endif
8788       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8789           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8790           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8791     TREE_STATIC (eqt) = 1;
8792   else
8793     TREE_STATIC (eqt) = 0;
8794   TREE_PUBLIC (eqt) = 0;
8795   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8796   DECL_CONTEXT (eqt) = current_function_decl;
8797   if (init)
8798     DECL_INITIAL (eqt) = error_mark_node;
8799   else
8800     DECL_INITIAL (eqt) = NULL_TREE;
8801
8802   eqt = start_decl (eqt, FALSE);
8803
8804   /* Make sure that any type can live in EQUIVALENCE and be referenced
8805      without getting a bus error.  We could pick the most restrictive
8806      alignment of all entities actually placed in the EQUIVALENCE, but
8807      this seems easy enough.  */
8808
8809   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8810   DECL_USER_ALIGN (eqt) = 0;
8811
8812   if ((!is_init && ffe_is_init_local_zero ())
8813       || (is_init && (ffestorag_init (eqst) == NULL)))
8814     init = ffecom_init_zero_ (eqt);
8815
8816   finish_decl (eqt, init, FALSE);
8817
8818   if (is_init)
8819     ffestorag_set_init (eqst, ffebld_new_any ());
8820
8821   {
8822     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8823     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8824                                    (ffestorag_size (eqst)
8825                                     + ffestorag_modulo (eqst))));
8826   }
8827
8828   ffestorag_set_hook (eqst, eqt);
8829
8830   ffestorag_drive (ffestorag_list_equivs (eqst),
8831                    &ffecom_member_phase2_,
8832                    eqst);
8833 }
8834
8835 #endif
8836 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8837
8838 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8839 static tree
8840 ffecom_transform_namelist_ (ffesymbol s)
8841 {
8842   tree nmlt;
8843   tree nmltype = ffecom_type_namelist_ ();
8844   tree nmlinits;
8845   tree nameinit;
8846   tree varsinit;
8847   tree nvarsinit;
8848   tree field;
8849   tree high;
8850   int i;
8851   static int mynumber = 0;
8852
8853   nmlt = build_decl (VAR_DECL,
8854                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8855                                                      mynumber++),
8856                      nmltype);
8857   TREE_STATIC (nmlt) = 1;
8858   DECL_INITIAL (nmlt) = error_mark_node;
8859
8860   nmlt = start_decl (nmlt, FALSE);
8861
8862   /* Process inits.  */
8863
8864   i = strlen (ffesymbol_text (s));
8865
8866   high = build_int_2 (i, 0);
8867   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8868
8869   nameinit = ffecom_build_f2c_string_ (i + 1,
8870                                        ffesymbol_text (s));
8871   TREE_TYPE (nameinit)
8872     = build_type_variant
8873     (build_array_type
8874      (char_type_node,
8875       build_range_type (ffecom_f2c_ftnlen_type_node,
8876                         ffecom_f2c_ftnlen_one_node,
8877                         high)),
8878      1, 0);
8879   TREE_CONSTANT (nameinit) = 1;
8880   TREE_STATIC (nameinit) = 1;
8881   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8882                        nameinit);
8883
8884   varsinit = ffecom_vardesc_array_ (s);
8885   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8886                        varsinit);
8887   TREE_CONSTANT (varsinit) = 1;
8888   TREE_STATIC (varsinit) = 1;
8889
8890   {
8891     ffebld b;
8892
8893     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8894       ++i;
8895   }
8896   nvarsinit = build_int_2 (i, 0);
8897   TREE_TYPE (nvarsinit) = integer_type_node;
8898   TREE_CONSTANT (nvarsinit) = 1;
8899   TREE_STATIC (nvarsinit) = 1;
8900
8901   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8902   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8903                                            varsinit);
8904   TREE_CHAIN (TREE_CHAIN (nmlinits))
8905     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8906
8907   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8908   TREE_CONSTANT (nmlinits) = 1;
8909   TREE_STATIC (nmlinits) = 1;
8910
8911   finish_decl (nmlt, nmlinits, FALSE);
8912
8913   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8914
8915   return nmlt;
8916 }
8917
8918 #endif
8919
8920 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8921    analyzed on the assumption it is calculating a pointer to be
8922    indirected through.  It must return the proper decl and offset,
8923    taking into account different units of measurements for offsets.  */
8924
8925 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8926 static void
8927 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8928                            tree t)
8929 {
8930   switch (TREE_CODE (t))
8931     {
8932     case NOP_EXPR:
8933     case CONVERT_EXPR:
8934     case NON_LVALUE_EXPR:
8935       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8936       break;
8937
8938     case PLUS_EXPR:
8939       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8940       if ((*decl == NULL_TREE)
8941           || (*decl == error_mark_node))
8942         break;
8943
8944       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8945         {
8946           /* An offset into COMMON.  */
8947           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8948                                  *offset, TREE_OPERAND (t, 1)));
8949           /* Convert offset (presumably in bytes) into canonical units
8950              (presumably bits).  */
8951           *offset = size_binop (MULT_EXPR,
8952                                 convert (bitsizetype, *offset),
8953                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8954           break;
8955         }
8956       /* Not a COMMON reference, so an unrecognized pattern.  */
8957       *decl = error_mark_node;
8958       break;
8959
8960     case PARM_DECL:
8961       *decl = t;
8962       *offset = bitsize_zero_node;
8963       break;
8964
8965     case ADDR_EXPR:
8966       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8967         {
8968           /* A reference to COMMON.  */
8969           *decl = TREE_OPERAND (t, 0);
8970           *offset = bitsize_zero_node;
8971           break;
8972         }
8973       /* Fall through.  */
8974     default:
8975       /* Not a COMMON reference, so an unrecognized pattern.  */
8976       *decl = error_mark_node;
8977       break;
8978     }
8979 }
8980 #endif
8981
8982 /* Given a tree that is possibly intended for use as an lvalue, return
8983    information representing a canonical view of that tree as a decl, an
8984    offset into that decl, and a size for the lvalue.
8985
8986    If there's no applicable decl, NULL_TREE is returned for the decl,
8987    and the other fields are left undefined.
8988
8989    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8990    is returned for the decl, and the other fields are left undefined.
8991
8992    Otherwise, the decl returned currently is either a VAR_DECL or a
8993    PARM_DECL.
8994
8995    The offset returned is always valid, but of course not necessarily
8996    a constant, and not necessarily converted into the appropriate
8997    type, leaving that up to the caller (so as to avoid that overhead
8998    if the decls being looked at are different anyway).
8999
9000    If the size cannot be determined (e.g. an adjustable array),
9001    an ERROR_MARK node is returned for the size.  Otherwise, the
9002    size returned is valid, not necessarily a constant, and not
9003    necessarily converted into the appropriate type as with the
9004    offset.
9005
9006    Note that the offset and size expressions are expressed in the
9007    base storage units (usually bits) rather than in the units of
9008    the type of the decl, because two decls with different types
9009    might overlap but with apparently non-overlapping array offsets,
9010    whereas converting the array offsets to consistant offsets will
9011    reveal the overlap.  */
9012
9013 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9014 static void
9015 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9016                            tree *size, tree t)
9017 {
9018   /* The default path is to report a nonexistant decl.  */
9019   *decl = NULL_TREE;
9020
9021   if (t == NULL_TREE)
9022     return;
9023
9024   switch (TREE_CODE (t))
9025     {
9026     case ERROR_MARK:
9027     case IDENTIFIER_NODE:
9028     case INTEGER_CST:
9029     case REAL_CST:
9030     case COMPLEX_CST:
9031     case STRING_CST:
9032     case CONST_DECL:
9033     case PLUS_EXPR:
9034     case MINUS_EXPR:
9035     case MULT_EXPR:
9036     case TRUNC_DIV_EXPR:
9037     case CEIL_DIV_EXPR:
9038     case FLOOR_DIV_EXPR:
9039     case ROUND_DIV_EXPR:
9040     case TRUNC_MOD_EXPR:
9041     case CEIL_MOD_EXPR:
9042     case FLOOR_MOD_EXPR:
9043     case ROUND_MOD_EXPR:
9044     case RDIV_EXPR:
9045     case EXACT_DIV_EXPR:
9046     case FIX_TRUNC_EXPR:
9047     case FIX_CEIL_EXPR:
9048     case FIX_FLOOR_EXPR:
9049     case FIX_ROUND_EXPR:
9050     case FLOAT_EXPR:
9051     case EXPON_EXPR:
9052     case NEGATE_EXPR:
9053     case MIN_EXPR:
9054     case MAX_EXPR:
9055     case ABS_EXPR:
9056     case FFS_EXPR:
9057     case LSHIFT_EXPR:
9058     case RSHIFT_EXPR:
9059     case LROTATE_EXPR:
9060     case RROTATE_EXPR:
9061     case BIT_IOR_EXPR:
9062     case BIT_XOR_EXPR:
9063     case BIT_AND_EXPR:
9064     case BIT_ANDTC_EXPR:
9065     case BIT_NOT_EXPR:
9066     case TRUTH_ANDIF_EXPR:
9067     case TRUTH_ORIF_EXPR:
9068     case TRUTH_AND_EXPR:
9069     case TRUTH_OR_EXPR:
9070     case TRUTH_XOR_EXPR:
9071     case TRUTH_NOT_EXPR:
9072     case LT_EXPR:
9073     case LE_EXPR:
9074     case GT_EXPR:
9075     case GE_EXPR:
9076     case EQ_EXPR:
9077     case NE_EXPR:
9078     case COMPLEX_EXPR:
9079     case CONJ_EXPR:
9080     case REALPART_EXPR:
9081     case IMAGPART_EXPR:
9082     case LABEL_EXPR:
9083     case COMPONENT_REF:
9084     case COMPOUND_EXPR:
9085     case ADDR_EXPR:
9086       return;
9087
9088     case VAR_DECL:
9089     case PARM_DECL:
9090       *decl = t;
9091       *offset = bitsize_zero_node;
9092       *size = TYPE_SIZE (TREE_TYPE (t));
9093       return;
9094
9095     case ARRAY_REF:
9096       {
9097         tree array = TREE_OPERAND (t, 0);
9098         tree element = TREE_OPERAND (t, 1);
9099         tree init_offset;
9100
9101         if ((array == NULL_TREE)
9102             || (element == NULL_TREE))
9103           {
9104             *decl = error_mark_node;
9105             return;
9106           }
9107
9108         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9109                                    array);
9110         if ((*decl == NULL_TREE)
9111             || (*decl == error_mark_node))
9112           return;
9113
9114         /* Calculate ((element - base) * NBBY) + init_offset.  */
9115         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9116                                element,
9117                                TYPE_MIN_VALUE (TYPE_DOMAIN
9118                                                (TREE_TYPE (array)))));
9119
9120         *offset = size_binop (MULT_EXPR,
9121                               convert (bitsizetype, *offset),
9122                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9123
9124         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9125
9126         *size = TYPE_SIZE (TREE_TYPE (t));
9127         return;
9128       }
9129
9130     case INDIRECT_REF:
9131
9132       /* Most of this code is to handle references to COMMON.  And so
9133          far that is useful only for calling library functions, since
9134          external (user) functions might reference common areas.  But
9135          even calling an external function, it's worthwhile to decode
9136          COMMON references because if not storing into COMMON, we don't
9137          want COMMON-based arguments to gratuitously force use of a
9138          temporary.  */
9139
9140       *size = TYPE_SIZE (TREE_TYPE (t));
9141
9142       ffecom_tree_canonize_ptr_ (decl, offset,
9143                                  TREE_OPERAND (t, 0));
9144
9145       return;
9146
9147     case CONVERT_EXPR:
9148     case NOP_EXPR:
9149     case MODIFY_EXPR:
9150     case NON_LVALUE_EXPR:
9151     case RESULT_DECL:
9152     case FIELD_DECL:
9153     case COND_EXPR:             /* More cases than we can handle. */
9154     case SAVE_EXPR:
9155     case REFERENCE_EXPR:
9156     case PREDECREMENT_EXPR:
9157     case PREINCREMENT_EXPR:
9158     case POSTDECREMENT_EXPR:
9159     case POSTINCREMENT_EXPR:
9160     case CALL_EXPR:
9161     default:
9162       *decl = error_mark_node;
9163       return;
9164     }
9165 }
9166 #endif
9167
9168 /* Do divide operation appropriate to type of operands.  */
9169
9170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9171 static tree
9172 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9173                      tree dest_tree, ffebld dest, bool *dest_used,
9174                      tree hook)
9175 {
9176   if ((left == error_mark_node)
9177       || (right == error_mark_node))
9178     return error_mark_node;
9179
9180   switch (TREE_CODE (tree_type))
9181     {
9182     case INTEGER_TYPE:
9183       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9184                        left,
9185                        right);
9186
9187     case COMPLEX_TYPE:
9188       if (! optimize_size)
9189         return ffecom_2 (RDIV_EXPR, tree_type,
9190                          left,
9191                          right);
9192       {
9193         ffecomGfrt ix;
9194
9195         if (TREE_TYPE (tree_type)
9196             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9197           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9198         else
9199           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9200
9201         left = ffecom_1 (ADDR_EXPR,
9202                          build_pointer_type (TREE_TYPE (left)),
9203                          left);
9204         left = build_tree_list (NULL_TREE, left);
9205         right = ffecom_1 (ADDR_EXPR,
9206                           build_pointer_type (TREE_TYPE (right)),
9207                           right);
9208         right = build_tree_list (NULL_TREE, right);
9209         TREE_CHAIN (left) = right;
9210
9211         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9212                              ffecom_gfrt_kindtype (ix),
9213                              ffe_is_f2c_library (),
9214                              tree_type,
9215                              left,
9216                              dest_tree, dest, dest_used,
9217                              NULL_TREE, TRUE, hook);
9218       }
9219       break;
9220
9221     case RECORD_TYPE:
9222       {
9223         ffecomGfrt ix;
9224
9225         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9226             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9227           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9228         else
9229           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9230
9231         left = ffecom_1 (ADDR_EXPR,
9232                          build_pointer_type (TREE_TYPE (left)),
9233                          left);
9234         left = build_tree_list (NULL_TREE, left);
9235         right = ffecom_1 (ADDR_EXPR,
9236                           build_pointer_type (TREE_TYPE (right)),
9237                           right);
9238         right = build_tree_list (NULL_TREE, right);
9239         TREE_CHAIN (left) = right;
9240
9241         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9242                              ffecom_gfrt_kindtype (ix),
9243                              ffe_is_f2c_library (),
9244                              tree_type,
9245                              left,
9246                              dest_tree, dest, dest_used,
9247                              NULL_TREE, TRUE, hook);
9248       }
9249       break;
9250
9251     default:
9252       return ffecom_2 (RDIV_EXPR, tree_type,
9253                        left,
9254                        right);
9255     }
9256 }
9257
9258 #endif
9259 /* Build type info for non-dummy variable.  */
9260
9261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9262 static tree
9263 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9264                        ffeinfoKindtype kt)
9265 {
9266   tree type;
9267   ffebld dl;
9268   ffebld dim;
9269   tree lowt;
9270   tree hight;
9271
9272   type = ffecom_tree_type[bt][kt];
9273   if (bt == FFEINFO_basictypeCHARACTER)
9274     {
9275       hight = build_int_2 (ffesymbol_size (s), 0);
9276       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9277
9278       type
9279         = build_array_type
9280           (type,
9281            build_range_type (ffecom_f2c_ftnlen_type_node,
9282                              ffecom_f2c_ftnlen_one_node,
9283                              hight));
9284       type = ffecom_check_size_overflow_ (s, type, FALSE);
9285     }
9286
9287   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9288     {
9289       if (type == error_mark_node)
9290         break;
9291
9292       dim = ffebld_head (dl);
9293       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9294
9295       if (ffebld_left (dim) == NULL)
9296         lowt = integer_one_node;
9297       else
9298         lowt = ffecom_expr (ffebld_left (dim));
9299
9300       if (TREE_CODE (lowt) != INTEGER_CST)
9301         lowt = variable_size (lowt);
9302
9303       assert (ffebld_right (dim) != NULL);
9304       hight = ffecom_expr (ffebld_right (dim));
9305
9306       if (TREE_CODE (hight) != INTEGER_CST)
9307         hight = variable_size (hight);
9308
9309       type = build_array_type (type,
9310                                build_range_type (ffecom_integer_type_node,
9311                                                  lowt, hight));
9312       type = ffecom_check_size_overflow_ (s, type, FALSE);
9313     }
9314
9315   return type;
9316 }
9317
9318 #endif
9319 /* Build Namelist type.  */
9320
9321 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9322 static tree
9323 ffecom_type_namelist_ ()
9324 {
9325   static tree type = NULL_TREE;
9326
9327   if (type == NULL_TREE)
9328     {
9329       static tree namefield, varsfield, nvarsfield;
9330       tree vardesctype;
9331
9332       vardesctype = ffecom_type_vardesc_ ();
9333
9334       type = make_node (RECORD_TYPE);
9335
9336       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9337
9338       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9339                                      string_type_node);
9340       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9341       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9342                                       integer_type_node);
9343
9344       TYPE_FIELDS (type) = namefield;
9345       layout_type (type);
9346
9347       ggc_add_tree_root (&type, 1);
9348     }
9349
9350   return type;
9351 }
9352
9353 #endif
9354
9355 /* Build Vardesc type.  */
9356
9357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9358 static tree
9359 ffecom_type_vardesc_ ()
9360 {
9361   static tree type = NULL_TREE;
9362   static tree namefield, addrfield, dimsfield, typefield;
9363
9364   if (type == NULL_TREE)
9365     {
9366       type = make_node (RECORD_TYPE);
9367
9368       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9369                                      string_type_node);
9370       addrfield = ffecom_decl_field (type, namefield, "addr",
9371                                      string_type_node);
9372       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9373                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9374       typefield = ffecom_decl_field (type, dimsfield, "type",
9375                                      integer_type_node);
9376
9377       TYPE_FIELDS (type) = namefield;
9378       layout_type (type);
9379
9380       ggc_add_tree_root (&type, 1);
9381     }
9382
9383   return type;
9384 }
9385
9386 #endif
9387
9388 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9389 static tree
9390 ffecom_vardesc_ (ffebld expr)
9391 {
9392   ffesymbol s;
9393
9394   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9395   s = ffebld_symter (expr);
9396
9397   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9398     {
9399       int i;
9400       tree vardesctype = ffecom_type_vardesc_ ();
9401       tree var;
9402       tree nameinit;
9403       tree dimsinit;
9404       tree addrinit;
9405       tree typeinit;
9406       tree field;
9407       tree varinits;
9408       static int mynumber = 0;
9409
9410       var = build_decl (VAR_DECL,
9411                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9412                                                         mynumber++),
9413                         vardesctype);
9414       TREE_STATIC (var) = 1;
9415       DECL_INITIAL (var) = error_mark_node;
9416
9417       var = start_decl (var, FALSE);
9418
9419       /* Process inits.  */
9420
9421       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9422                                            + 1,
9423                                            ffesymbol_text (s));
9424       TREE_TYPE (nameinit)
9425         = build_type_variant
9426         (build_array_type
9427          (char_type_node,
9428           build_range_type (integer_type_node,
9429                             integer_one_node,
9430                             build_int_2 (i, 0))),
9431          1, 0);
9432       TREE_CONSTANT (nameinit) = 1;
9433       TREE_STATIC (nameinit) = 1;
9434       nameinit = ffecom_1 (ADDR_EXPR,
9435                            build_pointer_type (TREE_TYPE (nameinit)),
9436                            nameinit);
9437
9438       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9439
9440       dimsinit = ffecom_vardesc_dims_ (s);
9441
9442       if (typeinit == NULL_TREE)
9443         {
9444           ffeinfoBasictype bt = ffesymbol_basictype (s);
9445           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9446           int tc = ffecom_f2c_typecode (bt, kt);
9447
9448           assert (tc != -1);
9449           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9450         }
9451       else
9452         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9453
9454       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9455                                   nameinit);
9456       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9457                                                addrinit);
9458       TREE_CHAIN (TREE_CHAIN (varinits))
9459         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9460       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9461         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9462
9463       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9464       TREE_CONSTANT (varinits) = 1;
9465       TREE_STATIC (varinits) = 1;
9466
9467       finish_decl (var, varinits, FALSE);
9468
9469       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9470
9471       ffesymbol_hook (s).vardesc_tree = var;
9472     }
9473
9474   return ffesymbol_hook (s).vardesc_tree;
9475 }
9476
9477 #endif
9478 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9479 static tree
9480 ffecom_vardesc_array_ (ffesymbol s)
9481 {
9482   ffebld b;
9483   tree list;
9484   tree item = NULL_TREE;
9485   tree var;
9486   int i;
9487   static int mynumber = 0;
9488
9489   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9490        b != NULL;
9491        b = ffebld_trail (b), ++i)
9492     {
9493       tree t;
9494
9495       t = ffecom_vardesc_ (ffebld_head (b));
9496
9497       if (list == NULL_TREE)
9498         list = item = build_tree_list (NULL_TREE, t);
9499       else
9500         {
9501           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9502           item = TREE_CHAIN (item);
9503         }
9504     }
9505
9506   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9507                            build_range_type (integer_type_node,
9508                                              integer_one_node,
9509                                              build_int_2 (i, 0)));
9510   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9511   TREE_CONSTANT (list) = 1;
9512   TREE_STATIC (list) = 1;
9513
9514   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9515   var = build_decl (VAR_DECL, var, item);
9516   TREE_STATIC (var) = 1;
9517   DECL_INITIAL (var) = error_mark_node;
9518   var = start_decl (var, FALSE);
9519   finish_decl (var, list, FALSE);
9520
9521   return var;
9522 }
9523
9524 #endif
9525 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9526 static tree
9527 ffecom_vardesc_dims_ (ffesymbol s)
9528 {
9529   if (ffesymbol_dims (s) == NULL)
9530     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9531                     integer_zero_node);
9532
9533   {
9534     ffebld b;
9535     ffebld e;
9536     tree list;
9537     tree backlist;
9538     tree item = NULL_TREE;
9539     tree var;
9540     tree numdim;
9541     tree numelem;
9542     tree baseoff = NULL_TREE;
9543     static int mynumber = 0;
9544
9545     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9546     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9547
9548     numelem = ffecom_expr (ffesymbol_arraysize (s));
9549     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9550
9551     list = NULL_TREE;
9552     backlist = NULL_TREE;
9553     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9554          b != NULL;
9555          b = ffebld_trail (b), e = ffebld_trail (e))
9556       {
9557         tree t;
9558         tree low;
9559         tree back;
9560
9561         if (ffebld_trail (b) == NULL)
9562           t = NULL_TREE;
9563         else
9564           {
9565             t = convert (ffecom_f2c_ftnlen_type_node,
9566                          ffecom_expr (ffebld_head (e)));
9567
9568             if (list == NULL_TREE)
9569               list = item = build_tree_list (NULL_TREE, t);
9570             else
9571               {
9572                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9573                 item = TREE_CHAIN (item);
9574               }
9575           }
9576
9577         if (ffebld_left (ffebld_head (b)) == NULL)
9578           low = ffecom_integer_one_node;
9579         else
9580           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9581         low = convert (ffecom_f2c_ftnlen_type_node, low);
9582
9583         back = build_tree_list (low, t);
9584         TREE_CHAIN (back) = backlist;
9585         backlist = back;
9586       }
9587
9588     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9589       {
9590         if (TREE_VALUE (item) == NULL_TREE)
9591           baseoff = TREE_PURPOSE (item);
9592         else
9593           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9594                               TREE_PURPOSE (item),
9595                               ffecom_2 (MULT_EXPR,
9596                                         ffecom_f2c_ftnlen_type_node,
9597                                         TREE_VALUE (item),
9598                                         baseoff));
9599       }
9600
9601     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9602
9603     baseoff = build_tree_list (NULL_TREE, baseoff);
9604     TREE_CHAIN (baseoff) = list;
9605
9606     numelem = build_tree_list (NULL_TREE, numelem);
9607     TREE_CHAIN (numelem) = baseoff;
9608
9609     numdim = build_tree_list (NULL_TREE, numdim);
9610     TREE_CHAIN (numdim) = numelem;
9611
9612     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9613                              build_range_type (integer_type_node,
9614                                                integer_zero_node,
9615                                                build_int_2
9616                                                ((int) ffesymbol_rank (s)
9617                                                 + 2, 0)));
9618     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9619     TREE_CONSTANT (list) = 1;
9620     TREE_STATIC (list) = 1;
9621
9622     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9623     var = build_decl (VAR_DECL, var, item);
9624     TREE_STATIC (var) = 1;
9625     DECL_INITIAL (var) = error_mark_node;
9626     var = start_decl (var, FALSE);
9627     finish_decl (var, list, FALSE);
9628
9629     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9630
9631     return var;
9632   }
9633 }
9634
9635 #endif
9636 /* Essentially does a "fold (build1 (code, type, node))" while checking
9637    for certain housekeeping things.
9638
9639    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9640    ffecom_1_fn instead.  */
9641
9642 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9643 tree
9644 ffecom_1 (enum tree_code code, tree type, tree node)
9645 {
9646   tree item;
9647
9648   if ((node == error_mark_node)
9649       || (type == error_mark_node))
9650     return error_mark_node;
9651
9652   if (code == ADDR_EXPR)
9653     {
9654       if (!mark_addressable (node))
9655         assert ("can't mark_addressable this node!" == NULL);
9656     }
9657
9658   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9659     {
9660       tree realtype;
9661
9662     case REALPART_EXPR:
9663       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9664       break;
9665
9666     case IMAGPART_EXPR:
9667       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9668       break;
9669
9670
9671     case NEGATE_EXPR:
9672       if (TREE_CODE (type) != RECORD_TYPE)
9673         {
9674           item = build1 (code, type, node);
9675           break;
9676         }
9677       node = ffecom_stabilize_aggregate_ (node);
9678       realtype = TREE_TYPE (TYPE_FIELDS (type));
9679       item =
9680         ffecom_2 (COMPLEX_EXPR, type,
9681                   ffecom_1 (NEGATE_EXPR, realtype,
9682                             ffecom_1 (REALPART_EXPR, realtype,
9683                                       node)),
9684                   ffecom_1 (NEGATE_EXPR, realtype,
9685                             ffecom_1 (IMAGPART_EXPR, realtype,
9686                                       node)));
9687       break;
9688
9689     default:
9690       item = build1 (code, type, node);
9691       break;
9692     }
9693
9694   if (TREE_SIDE_EFFECTS (node))
9695     TREE_SIDE_EFFECTS (item) = 1;
9696   if ((code == ADDR_EXPR) && staticp (node))
9697     TREE_CONSTANT (item) = 1;
9698   return fold (item);
9699 }
9700 #endif
9701
9702 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9703    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9704    does not set TREE_ADDRESSABLE (because calling an inline
9705    function does not mean the function needs to be separately
9706    compiled).  */
9707
9708 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9709 tree
9710 ffecom_1_fn (tree node)
9711 {
9712   tree item;
9713   tree type;
9714
9715   if (node == error_mark_node)
9716     return error_mark_node;
9717
9718   type = build_type_variant (TREE_TYPE (node),
9719                              TREE_READONLY (node),
9720                              TREE_THIS_VOLATILE (node));
9721   item = build1 (ADDR_EXPR,
9722                  build_pointer_type (type), node);
9723   if (TREE_SIDE_EFFECTS (node))
9724     TREE_SIDE_EFFECTS (item) = 1;
9725   if (staticp (node))
9726     TREE_CONSTANT (item) = 1;
9727   return fold (item);
9728 }
9729 #endif
9730
9731 /* Essentially does a "fold (build (code, type, node1, node2))" while
9732    checking for certain housekeeping things.  */
9733
9734 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9735 tree
9736 ffecom_2 (enum tree_code code, tree type, tree node1,
9737           tree node2)
9738 {
9739   tree item;
9740
9741   if ((node1 == error_mark_node)
9742       || (node2 == error_mark_node)
9743       || (type == error_mark_node))
9744     return error_mark_node;
9745
9746   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9747     {
9748       tree a, b, c, d, realtype;
9749
9750     case CONJ_EXPR:
9751       assert ("no CONJ_EXPR support yet" == NULL);
9752       return error_mark_node;
9753
9754     case COMPLEX_EXPR:
9755       item = build_tree_list (TYPE_FIELDS (type), node1);
9756       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9757       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9758       break;
9759
9760     case PLUS_EXPR:
9761       if (TREE_CODE (type) != RECORD_TYPE)
9762         {
9763           item = build (code, type, node1, node2);
9764           break;
9765         }
9766       node1 = ffecom_stabilize_aggregate_ (node1);
9767       node2 = ffecom_stabilize_aggregate_ (node2);
9768       realtype = TREE_TYPE (TYPE_FIELDS (type));
9769       item =
9770         ffecom_2 (COMPLEX_EXPR, type,
9771                   ffecom_2 (PLUS_EXPR, realtype,
9772                             ffecom_1 (REALPART_EXPR, realtype,
9773                                       node1),
9774                             ffecom_1 (REALPART_EXPR, realtype,
9775                                       node2)),
9776                   ffecom_2 (PLUS_EXPR, realtype,
9777                             ffecom_1 (IMAGPART_EXPR, realtype,
9778                                       node1),
9779                             ffecom_1 (IMAGPART_EXPR, realtype,
9780                                       node2)));
9781       break;
9782
9783     case MINUS_EXPR:
9784       if (TREE_CODE (type) != RECORD_TYPE)
9785         {
9786           item = build (code, type, node1, node2);
9787           break;
9788         }
9789       node1 = ffecom_stabilize_aggregate_ (node1);
9790       node2 = ffecom_stabilize_aggregate_ (node2);
9791       realtype = TREE_TYPE (TYPE_FIELDS (type));
9792       item =
9793         ffecom_2 (COMPLEX_EXPR, type,
9794                   ffecom_2 (MINUS_EXPR, realtype,
9795                             ffecom_1 (REALPART_EXPR, realtype,
9796                                       node1),
9797                             ffecom_1 (REALPART_EXPR, realtype,
9798                                       node2)),
9799                   ffecom_2 (MINUS_EXPR, realtype,
9800                             ffecom_1 (IMAGPART_EXPR, realtype,
9801                                       node1),
9802                             ffecom_1 (IMAGPART_EXPR, realtype,
9803                                       node2)));
9804       break;
9805
9806     case MULT_EXPR:
9807       if (TREE_CODE (type) != RECORD_TYPE)
9808         {
9809           item = build (code, type, node1, node2);
9810           break;
9811         }
9812       node1 = ffecom_stabilize_aggregate_ (node1);
9813       node2 = ffecom_stabilize_aggregate_ (node2);
9814       realtype = TREE_TYPE (TYPE_FIELDS (type));
9815       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9816                                node1));
9817       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9818                                node1));
9819       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9820                                node2));
9821       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9822                                node2));
9823       item =
9824         ffecom_2 (COMPLEX_EXPR, type,
9825                   ffecom_2 (MINUS_EXPR, realtype,
9826                             ffecom_2 (MULT_EXPR, realtype,
9827                                       a,
9828                                       c),
9829                             ffecom_2 (MULT_EXPR, realtype,
9830                                       b,
9831                                       d)),
9832                   ffecom_2 (PLUS_EXPR, realtype,
9833                             ffecom_2 (MULT_EXPR, realtype,
9834                                       a,
9835                                       d),
9836                             ffecom_2 (MULT_EXPR, realtype,
9837                                       c,
9838                                       b)));
9839       break;
9840
9841     case EQ_EXPR:
9842       if ((TREE_CODE (node1) != RECORD_TYPE)
9843           && (TREE_CODE (node2) != RECORD_TYPE))
9844         {
9845           item = build (code, type, node1, node2);
9846           break;
9847         }
9848       assert (TREE_CODE (node1) == RECORD_TYPE);
9849       assert (TREE_CODE (node2) == RECORD_TYPE);
9850       node1 = ffecom_stabilize_aggregate_ (node1);
9851       node2 = ffecom_stabilize_aggregate_ (node2);
9852       realtype = TREE_TYPE (TYPE_FIELDS (type));
9853       item =
9854         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9855                   ffecom_2 (code, type,
9856                             ffecom_1 (REALPART_EXPR, realtype,
9857                                       node1),
9858                             ffecom_1 (REALPART_EXPR, realtype,
9859                                       node2)),
9860                   ffecom_2 (code, type,
9861                             ffecom_1 (IMAGPART_EXPR, realtype,
9862                                       node1),
9863                             ffecom_1 (IMAGPART_EXPR, realtype,
9864                                       node2)));
9865       break;
9866
9867     case NE_EXPR:
9868       if ((TREE_CODE (node1) != RECORD_TYPE)
9869           && (TREE_CODE (node2) != RECORD_TYPE))
9870         {
9871           item = build (code, type, node1, node2);
9872           break;
9873         }
9874       assert (TREE_CODE (node1) == RECORD_TYPE);
9875       assert (TREE_CODE (node2) == RECORD_TYPE);
9876       node1 = ffecom_stabilize_aggregate_ (node1);
9877       node2 = ffecom_stabilize_aggregate_ (node2);
9878       realtype = TREE_TYPE (TYPE_FIELDS (type));
9879       item =
9880         ffecom_2 (TRUTH_ORIF_EXPR, type,
9881                   ffecom_2 (code, type,
9882                             ffecom_1 (REALPART_EXPR, realtype,
9883                                       node1),
9884                             ffecom_1 (REALPART_EXPR, realtype,
9885                                       node2)),
9886                   ffecom_2 (code, type,
9887                             ffecom_1 (IMAGPART_EXPR, realtype,
9888                                       node1),
9889                             ffecom_1 (IMAGPART_EXPR, realtype,
9890                                       node2)));
9891       break;
9892
9893     default:
9894       item = build (code, type, node1, node2);
9895       break;
9896     }
9897
9898   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9899     TREE_SIDE_EFFECTS (item) = 1;
9900   return fold (item);
9901 }
9902
9903 #endif
9904 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9905
9906    ffesymbol s;  // the ENTRY point itself
9907    if (ffecom_2pass_advise_entrypoint(s))
9908        // the ENTRY point has been accepted
9909
9910    Does whatever compiler needs to do when it learns about the entrypoint,
9911    like determine the return type of the master function, count the
9912    number of entrypoints, etc.  Returns FALSE if the return type is
9913    not compatible with the return type(s) of other entrypoint(s).
9914
9915    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9916    later (after _finish_progunit) be called with the same entrypoint(s)
9917    as passed to this fn for which TRUE was returned.
9918
9919    03-Jan-92  JCB  2.0
9920       Return FALSE if the return type conflicts with previous entrypoints.  */
9921
9922 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9923 bool
9924 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9925 {
9926   ffebld list;                  /* opITEM. */
9927   ffebld mlist;                 /* opITEM. */
9928   ffebld plist;                 /* opITEM. */
9929   ffebld arg;                   /* ffebld_head(opITEM). */
9930   ffebld item;                  /* opITEM. */
9931   ffesymbol s;                  /* ffebld_symter(arg). */
9932   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9933   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9934   ffetargetCharacterSize size = ffesymbol_size (entry);
9935   bool ok;
9936
9937   if (ffecom_num_entrypoints_ == 0)
9938     {                           /* First entrypoint, make list of main
9939                                    arglist's dummies. */
9940       assert (ffecom_primary_entry_ != NULL);
9941
9942       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9943       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9944       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9945
9946       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9947            list != NULL;
9948            list = ffebld_trail (list))
9949         {
9950           arg = ffebld_head (list);
9951           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9952             continue;           /* Alternate return or some such thing. */
9953           item = ffebld_new_item (arg, NULL);
9954           if (plist == NULL)
9955             ffecom_master_arglist_ = item;
9956           else
9957             ffebld_set_trail (plist, item);
9958           plist = item;
9959         }
9960     }
9961
9962   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9963      apparently redundantly (it's done below to UNIONize the arglists) so
9964      that we don't complain about RETURN 1 if an offending ENTRY is the only
9965      one with an alternate return.  */
9966
9967   if (!ffecom_is_altreturning_)
9968     {
9969       for (list = ffesymbol_dummyargs (entry);
9970            list != NULL;
9971            list = ffebld_trail (list))
9972         {
9973           arg = ffebld_head (list);
9974           if (ffebld_op (arg) == FFEBLD_opSTAR)
9975             {
9976               ffecom_is_altreturning_ = TRUE;
9977               break;
9978             }
9979         }
9980     }
9981
9982   /* Now check type compatibility. */
9983
9984   switch (ffecom_master_bt_)
9985     {
9986     case FFEINFO_basictypeNONE:
9987       ok = (bt != FFEINFO_basictypeCHARACTER);
9988       break;
9989
9990     case FFEINFO_basictypeCHARACTER:
9991       ok
9992         = (bt == FFEINFO_basictypeCHARACTER)
9993         && (kt == ffecom_master_kt_)
9994         && (size == ffecom_master_size_);
9995       break;
9996
9997     case FFEINFO_basictypeANY:
9998       return FALSE;             /* Just don't bother. */
9999
10000     default:
10001       if (bt == FFEINFO_basictypeCHARACTER)
10002         {
10003           ok = FALSE;
10004           break;
10005         }
10006       ok = TRUE;
10007       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10008         {
10009           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10010           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10011         }
10012       break;
10013     }
10014
10015   if (!ok)
10016     {
10017       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10018       ffest_ffebad_here_current_stmt (0);
10019       ffebad_finish ();
10020       return FALSE;             /* Can't handle entrypoint. */
10021     }
10022
10023   /* Entrypoint type compatible with previous types. */
10024
10025   ++ffecom_num_entrypoints_;
10026
10027   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10028
10029   for (list = ffesymbol_dummyargs (entry);
10030        list != NULL;
10031        list = ffebld_trail (list))
10032     {
10033       arg = ffebld_head (list);
10034       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10035         continue;               /* Alternate return or some such thing. */
10036       s = ffebld_symter (arg);
10037       for (plist = NULL, mlist = ffecom_master_arglist_;
10038            mlist != NULL;
10039            plist = mlist, mlist = ffebld_trail (mlist))
10040         {                       /* plist points to previous item for easy
10041                                    appending of arg. */
10042           if (ffebld_symter (ffebld_head (mlist)) == s)
10043             break;              /* Already have this arg in the master list. */
10044         }
10045       if (mlist != NULL)
10046         continue;               /* Already have this arg in the master list. */
10047
10048       /* Append this arg to the master list. */
10049
10050       item = ffebld_new_item (arg, NULL);
10051       if (plist == NULL)
10052         ffecom_master_arglist_ = item;
10053       else
10054         ffebld_set_trail (plist, item);
10055     }
10056
10057   return TRUE;
10058 }
10059
10060 #endif
10061 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10062
10063    ffesymbol s;  // the ENTRY point itself
10064    ffecom_2pass_do_entrypoint(s);
10065
10066    Does whatever compiler needs to do to make the entrypoint actually
10067    happen.  Must be called for each entrypoint after
10068    ffecom_finish_progunit is called.  */
10069
10070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10071 void
10072 ffecom_2pass_do_entrypoint (ffesymbol entry)
10073 {
10074   static int mfn_num = 0;
10075   static int ent_num;
10076
10077   if (mfn_num != ffecom_num_fns_)
10078     {                           /* First entrypoint for this program unit. */
10079       ent_num = 1;
10080       mfn_num = ffecom_num_fns_;
10081       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10082     }
10083   else
10084     ++ent_num;
10085
10086   --ffecom_num_entrypoints_;
10087
10088   ffecom_do_entry_ (entry, ent_num);
10089 }
10090
10091 #endif
10092
10093 /* Essentially does a "fold (build (code, type, node1, node2))" while
10094    checking for certain housekeeping things.  Always sets
10095    TREE_SIDE_EFFECTS.  */
10096
10097 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10098 tree
10099 ffecom_2s (enum tree_code code, tree type, tree node1,
10100            tree node2)
10101 {
10102   tree item;
10103
10104   if ((node1 == error_mark_node)
10105       || (node2 == error_mark_node)
10106       || (type == error_mark_node))
10107     return error_mark_node;
10108
10109   item = build (code, type, node1, node2);
10110   TREE_SIDE_EFFECTS (item) = 1;
10111   return fold (item);
10112 }
10113
10114 #endif
10115 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10116    checking for certain housekeeping things.  */
10117
10118 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10119 tree
10120 ffecom_3 (enum tree_code code, tree type, tree node1,
10121           tree node2, tree node3)
10122 {
10123   tree item;
10124
10125   if ((node1 == error_mark_node)
10126       || (node2 == error_mark_node)
10127       || (node3 == error_mark_node)
10128       || (type == error_mark_node))
10129     return error_mark_node;
10130
10131   item = build (code, type, node1, node2, node3);
10132   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10133       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10134     TREE_SIDE_EFFECTS (item) = 1;
10135   return fold (item);
10136 }
10137
10138 #endif
10139 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10140    checking for certain housekeeping things.  Always sets
10141    TREE_SIDE_EFFECTS.  */
10142
10143 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10144 tree
10145 ffecom_3s (enum tree_code code, tree type, tree node1,
10146            tree node2, tree node3)
10147 {
10148   tree item;
10149
10150   if ((node1 == error_mark_node)
10151       || (node2 == error_mark_node)
10152       || (node3 == error_mark_node)
10153       || (type == error_mark_node))
10154     return error_mark_node;
10155
10156   item = build (code, type, node1, node2, node3);
10157   TREE_SIDE_EFFECTS (item) = 1;
10158   return fold (item);
10159 }
10160
10161 #endif
10162
10163 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10164
10165    See use by ffecom_list_expr.
10166
10167    If expression is NULL, returns an integer zero tree.  If it is not
10168    a CHARACTER expression, returns whatever ffecom_expr
10169    returns and sets the length return value to NULL_TREE.  Otherwise
10170    generates code to evaluate the character expression, returns the proper
10171    pointer to the result, but does NOT set the length return value to a tree
10172    that specifies the length of the result.  (In other words, the length
10173    variable is always set to NULL_TREE, because a length is never passed.)
10174
10175    21-Dec-91  JCB  1.1
10176       Don't set returned length, since nobody needs it (yet; someday if
10177       we allow CHARACTER*(*) dummies to statement functions, we'll need
10178       it).  */
10179
10180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10181 tree
10182 ffecom_arg_expr (ffebld expr, tree *length)
10183 {
10184   tree ign;
10185
10186   *length = NULL_TREE;
10187
10188   if (expr == NULL)
10189     return integer_zero_node;
10190
10191   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10192     return ffecom_expr (expr);
10193
10194   return ffecom_arg_ptr_to_expr (expr, &ign);
10195 }
10196
10197 #endif
10198 /* Transform expression into constant argument-pointer-to-expression tree.
10199
10200    If the expression can be transformed into a argument-pointer-to-expression
10201    tree that is constant, that is done, and the tree returned.  Else
10202    NULL_TREE is returned.
10203
10204    That way, a caller can attempt to provide compile-time initialization
10205    of a variable and, if that fails, *then* choose to start a new block
10206    and resort to using temporaries, as appropriate.  */
10207
10208 tree
10209 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10210 {
10211   if (! expr)
10212     return integer_zero_node;
10213
10214   if (ffebld_op (expr) == FFEBLD_opANY)
10215     {
10216       if (length)
10217         *length = error_mark_node;
10218       return error_mark_node;
10219     }
10220
10221   if (ffebld_arity (expr) == 0
10222       && (ffebld_op (expr) != FFEBLD_opSYMTER
10223           || ffebld_where (expr) == FFEINFO_whereCOMMON
10224           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10225           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10226     {
10227       tree t;
10228
10229       t = ffecom_arg_ptr_to_expr (expr, length);
10230       assert (TREE_CONSTANT (t));
10231       assert (! length || TREE_CONSTANT (*length));
10232       return t;
10233     }
10234
10235   if (length
10236       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10237     *length = build_int_2 (ffebld_size (expr), 0);
10238   else if (length)
10239     *length = NULL_TREE;
10240   return NULL_TREE;
10241 }
10242
10243 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10244
10245    See use by ffecom_list_ptr_to_expr.
10246
10247    If expression is NULL, returns an integer zero tree.  If it is not
10248    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10249    returns and sets the length return value to NULL_TREE.  Otherwise
10250    generates code to evaluate the character expression, returns the proper
10251    pointer to the result, AND sets the length return value to a tree that
10252    specifies the length of the result.
10253
10254    If the length argument is NULL, this is a slightly special
10255    case of building a FORMAT expression, that is, an expression that
10256    will be used at run time without regard to length.  For the current
10257    implementation, which uses the libf2c library, this means it is nice
10258    to append a null byte to the end of the expression, where feasible,
10259    to make sure any diagnostic about the FORMAT string terminates at
10260    some useful point.
10261
10262    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10263    length argument.  This might even be seen as a feature, if a null
10264    byte can always be appended.  */
10265
10266 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10267 tree
10268 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10269 {
10270   tree item;
10271   tree ign_length;
10272   ffecomConcatList_ catlist;
10273
10274   if (length != NULL)
10275     *length = NULL_TREE;
10276
10277   if (expr == NULL)
10278     return integer_zero_node;
10279
10280   switch (ffebld_op (expr))
10281     {
10282     case FFEBLD_opPERCENT_VAL:
10283       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10284         return ffecom_expr (ffebld_left (expr));
10285       {
10286         tree temp_exp;
10287         tree temp_length;
10288
10289         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10290         if (temp_exp == error_mark_node)
10291           return error_mark_node;
10292
10293         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10294                          temp_exp);
10295       }
10296
10297     case FFEBLD_opPERCENT_REF:
10298       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10299         return ffecom_ptr_to_expr (ffebld_left (expr));
10300       if (length != NULL)
10301         {
10302           ign_length = NULL_TREE;
10303           length = &ign_length;
10304         }
10305       expr = ffebld_left (expr);
10306       break;
10307
10308     case FFEBLD_opPERCENT_DESCR:
10309       switch (ffeinfo_basictype (ffebld_info (expr)))
10310         {
10311 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10312         case FFEINFO_basictypeHOLLERITH:
10313 #endif
10314         case FFEINFO_basictypeCHARACTER:
10315           break;                /* Passed by descriptor anyway. */
10316
10317         default:
10318           item = ffecom_ptr_to_expr (expr);
10319           if (item != error_mark_node)
10320             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10321           break;
10322         }
10323       break;
10324
10325     default:
10326       break;
10327     }
10328
10329 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10330   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10331       && (length != NULL))
10332     {                           /* Pass Hollerith by descriptor. */
10333       ffetargetHollerith h;
10334
10335       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10336       h = ffebld_cu_val_hollerith (ffebld_constant_union
10337                                    (ffebld_conter (expr)));
10338       *length
10339         = build_int_2 (h.length, 0);
10340       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10341     }
10342 #endif
10343
10344   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10345     return ffecom_ptr_to_expr (expr);
10346
10347   assert (ffeinfo_kindtype (ffebld_info (expr))
10348           == FFEINFO_kindtypeCHARACTER1);
10349
10350   while (ffebld_op (expr) == FFEBLD_opPAREN)
10351     expr = ffebld_left (expr);
10352
10353   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10354   switch (ffecom_concat_list_count_ (catlist))
10355     {
10356     case 0:                     /* Shouldn't happen, but in case it does... */
10357       if (length != NULL)
10358         {
10359           *length = ffecom_f2c_ftnlen_zero_node;
10360           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10361         }
10362       ffecom_concat_list_kill_ (catlist);
10363       return null_pointer_node;
10364
10365     case 1:                     /* The (fairly) easy case. */
10366       if (length == NULL)
10367         ffecom_char_args_with_null_ (&item, &ign_length,
10368                                      ffecom_concat_list_expr_ (catlist, 0));
10369       else
10370         ffecom_char_args_ (&item, length,
10371                            ffecom_concat_list_expr_ (catlist, 0));
10372       ffecom_concat_list_kill_ (catlist);
10373       assert (item != NULL_TREE);
10374       return item;
10375
10376     default:                    /* Must actually concatenate things. */
10377       break;
10378     }
10379
10380   {
10381     int count = ffecom_concat_list_count_ (catlist);
10382     int i;
10383     tree lengths;
10384     tree items;
10385     tree length_array;
10386     tree item_array;
10387     tree citem;
10388     tree clength;
10389     tree temporary;
10390     tree num;
10391     tree known_length;
10392     ffetargetCharacterSize sz;
10393
10394     sz = ffecom_concat_list_maxlen_ (catlist);
10395     /* ~~Kludge! */
10396     assert (sz != FFETARGET_charactersizeNONE);
10397
10398 #ifdef HOHO
10399     length_array
10400       = lengths
10401       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10402                              FFETARGET_charactersizeNONE, count, TRUE);
10403     item_array
10404       = items
10405       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10406                              FFETARGET_charactersizeNONE, count, TRUE);
10407     temporary = ffecom_push_tempvar (char_type_node,
10408                                      sz, -1, TRUE);
10409 #else
10410     {
10411       tree hook;
10412
10413       hook = ffebld_nonter_hook (expr);
10414       assert (hook);
10415       assert (TREE_CODE (hook) == TREE_VEC);
10416       assert (TREE_VEC_LENGTH (hook) == 3);
10417       length_array = lengths = TREE_VEC_ELT (hook, 0);
10418       item_array = items = TREE_VEC_ELT (hook, 1);
10419       temporary = TREE_VEC_ELT (hook, 2);
10420     }
10421 #endif
10422
10423     known_length = ffecom_f2c_ftnlen_zero_node;
10424
10425     for (i = 0; i < count; ++i)
10426       {
10427         if ((i == count)
10428             && (length == NULL))
10429           ffecom_char_args_with_null_ (&citem, &clength,
10430                                        ffecom_concat_list_expr_ (catlist, i));
10431         else
10432           ffecom_char_args_ (&citem, &clength,
10433                              ffecom_concat_list_expr_ (catlist, i));
10434         if ((citem == error_mark_node)
10435             || (clength == error_mark_node))
10436           {
10437             ffecom_concat_list_kill_ (catlist);
10438             *length = error_mark_node;
10439             return error_mark_node;
10440           }
10441
10442         items
10443           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10444                       ffecom_modify (void_type_node,
10445                                      ffecom_2 (ARRAY_REF,
10446                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10447                                                item_array,
10448                                                build_int_2 (i, 0)),
10449                                      citem),
10450                       items);
10451         clength = ffecom_save_tree (clength);
10452         if (length != NULL)
10453           known_length
10454             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10455                         known_length,
10456                         clength);
10457         lengths
10458           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10459                       ffecom_modify (void_type_node,
10460                                      ffecom_2 (ARRAY_REF,
10461                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10462                                                length_array,
10463                                                build_int_2 (i, 0)),
10464                                      clength),
10465                       lengths);
10466       }
10467
10468     temporary = ffecom_1 (ADDR_EXPR,
10469                           build_pointer_type (TREE_TYPE (temporary)),
10470                           temporary);
10471
10472     item = build_tree_list (NULL_TREE, temporary);
10473     TREE_CHAIN (item)
10474       = build_tree_list (NULL_TREE,
10475                          ffecom_1 (ADDR_EXPR,
10476                                    build_pointer_type (TREE_TYPE (items)),
10477                                    items));
10478     TREE_CHAIN (TREE_CHAIN (item))
10479       = build_tree_list (NULL_TREE,
10480                          ffecom_1 (ADDR_EXPR,
10481                                    build_pointer_type (TREE_TYPE (lengths)),
10482                                    lengths));
10483     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10484       = build_tree_list
10485         (NULL_TREE,
10486          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10487                    convert (ffecom_f2c_ftnlen_type_node,
10488                             build_int_2 (count, 0))));
10489     num = build_int_2 (sz, 0);
10490     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10491     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10492       = build_tree_list (NULL_TREE, num);
10493
10494     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10495     TREE_SIDE_EFFECTS (item) = 1;
10496     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10497                      item,
10498                      temporary);
10499
10500     if (length != NULL)
10501       *length = known_length;
10502   }
10503
10504   ffecom_concat_list_kill_ (catlist);
10505   assert (item != NULL_TREE);
10506   return item;
10507 }
10508
10509 #endif
10510 /* Generate call to run-time function.
10511
10512    The first arg is the GNU Fortran Run-Time function index, the second
10513    arg is the list of arguments to pass to it.  Returned is the expression
10514    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10515    result (which may be void).  */
10516
10517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10518 tree
10519 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10520 {
10521   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10522                        ffecom_gfrt_kindtype (ix),
10523                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10524                        NULL_TREE, args, NULL_TREE, NULL,
10525                        NULL, NULL_TREE, TRUE, hook);
10526 }
10527 #endif
10528
10529 /* Transform constant-union to tree.  */
10530
10531 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10532 tree
10533 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10534                       ffeinfoKindtype kt, tree tree_type)
10535 {
10536   tree item;
10537
10538   switch (bt)
10539     {
10540     case FFEINFO_basictypeINTEGER:
10541       {
10542         int val;
10543
10544         switch (kt)
10545           {
10546 #if FFETARGET_okINTEGER1
10547           case FFEINFO_kindtypeINTEGER1:
10548             val = ffebld_cu_val_integer1 (*cu);
10549             break;
10550 #endif
10551
10552 #if FFETARGET_okINTEGER2
10553           case FFEINFO_kindtypeINTEGER2:
10554             val = ffebld_cu_val_integer2 (*cu);
10555             break;
10556 #endif
10557
10558 #if FFETARGET_okINTEGER3
10559           case FFEINFO_kindtypeINTEGER3:
10560             val = ffebld_cu_val_integer3 (*cu);
10561             break;
10562 #endif
10563
10564 #if FFETARGET_okINTEGER4
10565           case FFEINFO_kindtypeINTEGER4:
10566             val = ffebld_cu_val_integer4 (*cu);
10567             break;
10568 #endif
10569
10570           default:
10571             assert ("bad INTEGER constant kind type" == NULL);
10572             /* Fall through. */
10573           case FFEINFO_kindtypeANY:
10574             return error_mark_node;
10575           }
10576         item = build_int_2 (val, (val < 0) ? -1 : 0);
10577         TREE_TYPE (item) = tree_type;
10578       }
10579       break;
10580
10581     case FFEINFO_basictypeLOGICAL:
10582       {
10583         int val;
10584
10585         switch (kt)
10586           {
10587 #if FFETARGET_okLOGICAL1
10588           case FFEINFO_kindtypeLOGICAL1:
10589             val = ffebld_cu_val_logical1 (*cu);
10590             break;
10591 #endif
10592
10593 #if FFETARGET_okLOGICAL2
10594           case FFEINFO_kindtypeLOGICAL2:
10595             val = ffebld_cu_val_logical2 (*cu);
10596             break;
10597 #endif
10598
10599 #if FFETARGET_okLOGICAL3
10600           case FFEINFO_kindtypeLOGICAL3:
10601             val = ffebld_cu_val_logical3 (*cu);
10602             break;
10603 #endif
10604
10605 #if FFETARGET_okLOGICAL4
10606           case FFEINFO_kindtypeLOGICAL4:
10607             val = ffebld_cu_val_logical4 (*cu);
10608             break;
10609 #endif
10610
10611           default:
10612             assert ("bad LOGICAL constant kind type" == NULL);
10613             /* Fall through. */
10614           case FFEINFO_kindtypeANY:
10615             return error_mark_node;
10616           }
10617         item = build_int_2 (val, (val < 0) ? -1 : 0);
10618         TREE_TYPE (item) = tree_type;
10619       }
10620       break;
10621
10622     case FFEINFO_basictypeREAL:
10623       {
10624         REAL_VALUE_TYPE val;
10625
10626         switch (kt)
10627           {
10628 #if FFETARGET_okREAL1
10629           case FFEINFO_kindtypeREAL1:
10630             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10631             break;
10632 #endif
10633
10634 #if FFETARGET_okREAL2
10635           case FFEINFO_kindtypeREAL2:
10636             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10637             break;
10638 #endif
10639
10640 #if FFETARGET_okREAL3
10641           case FFEINFO_kindtypeREAL3:
10642             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10643             break;
10644 #endif
10645
10646 #if FFETARGET_okREAL4
10647           case FFEINFO_kindtypeREAL4:
10648             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10649             break;
10650 #endif
10651
10652           default:
10653             assert ("bad REAL constant kind type" == NULL);
10654             /* Fall through. */
10655           case FFEINFO_kindtypeANY:
10656             return error_mark_node;
10657           }
10658         item = build_real (tree_type, val);
10659       }
10660       break;
10661
10662     case FFEINFO_basictypeCOMPLEX:
10663       {
10664         REAL_VALUE_TYPE real;
10665         REAL_VALUE_TYPE imag;
10666         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10667
10668         switch (kt)
10669           {
10670 #if FFETARGET_okCOMPLEX1
10671           case FFEINFO_kindtypeREAL1:
10672             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10673             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10674             break;
10675 #endif
10676
10677 #if FFETARGET_okCOMPLEX2
10678           case FFEINFO_kindtypeREAL2:
10679             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10680             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10681             break;
10682 #endif
10683
10684 #if FFETARGET_okCOMPLEX3
10685           case FFEINFO_kindtypeREAL3:
10686             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10687             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10688             break;
10689 #endif
10690
10691 #if FFETARGET_okCOMPLEX4
10692           case FFEINFO_kindtypeREAL4:
10693             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10694             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10695             break;
10696 #endif
10697
10698           default:
10699             assert ("bad REAL constant kind type" == NULL);
10700             /* Fall through. */
10701           case FFEINFO_kindtypeANY:
10702             return error_mark_node;
10703           }
10704         item = ffecom_build_complex_constant_ (tree_type,
10705                                                build_real (el_type, real),
10706                                                build_real (el_type, imag));
10707       }
10708       break;
10709
10710     case FFEINFO_basictypeCHARACTER:
10711       {                         /* Happens only in DATA and similar contexts. */
10712         ffetargetCharacter1 val;
10713
10714         switch (kt)
10715           {
10716 #if FFETARGET_okCHARACTER1
10717           case FFEINFO_kindtypeLOGICAL1:
10718             val = ffebld_cu_val_character1 (*cu);
10719             break;
10720 #endif
10721
10722           default:
10723             assert ("bad CHARACTER constant kind type" == NULL);
10724             /* Fall through. */
10725           case FFEINFO_kindtypeANY:
10726             return error_mark_node;
10727           }
10728         item = build_string (ffetarget_length_character1 (val),
10729                              ffetarget_text_character1 (val));
10730         TREE_TYPE (item)
10731           = build_type_variant (build_array_type (char_type_node,
10732                                                   build_range_type
10733                                                   (integer_type_node,
10734                                                    integer_one_node,
10735                                                    build_int_2
10736                                                 (ffetarget_length_character1
10737                                                  (val), 0))),
10738                                 1, 0);
10739       }
10740       break;
10741
10742     case FFEINFO_basictypeHOLLERITH:
10743       {
10744         ffetargetHollerith h;
10745
10746         h = ffebld_cu_val_hollerith (*cu);
10747
10748         /* If not at least as wide as default INTEGER, widen it.  */
10749         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10750           item = build_string (h.length, h.text);
10751         else
10752           {
10753             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10754
10755             memcpy (str, h.text, h.length);
10756             memset (&str[h.length], ' ',
10757                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10758                     - h.length);
10759             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10760                                  str);
10761           }
10762         TREE_TYPE (item)
10763           = build_type_variant (build_array_type (char_type_node,
10764                                                   build_range_type
10765                                                   (integer_type_node,
10766                                                    integer_one_node,
10767                                                    build_int_2
10768                                                    (h.length, 0))),
10769                                 1, 0);
10770       }
10771       break;
10772
10773     case FFEINFO_basictypeTYPELESS:
10774       {
10775         ffetargetInteger1 ival;
10776         ffetargetTypeless tless;
10777         ffebad error;
10778
10779         tless = ffebld_cu_val_typeless (*cu);
10780         error = ffetarget_convert_integer1_typeless (&ival, tless);
10781         assert (error == FFEBAD);
10782
10783         item = build_int_2 ((int) ival, 0);
10784       }
10785       break;
10786
10787     default:
10788       assert ("not yet on constant type" == NULL);
10789       /* Fall through. */
10790     case FFEINFO_basictypeANY:
10791       return error_mark_node;
10792     }
10793
10794   TREE_CONSTANT (item) = 1;
10795
10796   return item;
10797 }
10798
10799 #endif
10800
10801 /* Transform expression into constant tree.
10802
10803    If the expression can be transformed into a tree that is constant,
10804    that is done, and the tree returned.  Else NULL_TREE is returned.
10805
10806    That way, a caller can attempt to provide compile-time initialization
10807    of a variable and, if that fails, *then* choose to start a new block
10808    and resort to using temporaries, as appropriate.  */
10809
10810 tree
10811 ffecom_const_expr (ffebld expr)
10812 {
10813   if (! expr)
10814     return integer_zero_node;
10815
10816   if (ffebld_op (expr) == FFEBLD_opANY)
10817     return error_mark_node;
10818
10819   if (ffebld_arity (expr) == 0
10820       && (ffebld_op (expr) != FFEBLD_opSYMTER
10821 #if NEWCOMMON
10822           /* ~~Enable once common/equivalence is handled properly?  */
10823           || ffebld_where (expr) == FFEINFO_whereCOMMON
10824 #endif
10825           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10826           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10827     {
10828       tree t;
10829
10830       t = ffecom_expr (expr);
10831       assert (TREE_CONSTANT (t));
10832       return t;
10833     }
10834
10835   return NULL_TREE;
10836 }
10837
10838 /* Handy way to make a field in a struct/union.  */
10839
10840 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10841 tree
10842 ffecom_decl_field (tree context, tree prevfield,
10843                    const char *name, tree type)
10844 {
10845   tree field;
10846
10847   field = build_decl (FIELD_DECL, get_identifier (name), type);
10848   DECL_CONTEXT (field) = context;
10849   DECL_ALIGN (field) = 0;
10850   DECL_USER_ALIGN (field) = 0;
10851   if (prevfield != NULL_TREE)
10852     TREE_CHAIN (prevfield) = field;
10853
10854   return field;
10855 }
10856
10857 #endif
10858
10859 void
10860 ffecom_close_include (FILE *f)
10861 {
10862 #if FFECOM_GCC_INCLUDE
10863   ffecom_close_include_ (f);
10864 #endif
10865 }
10866
10867 int
10868 ffecom_decode_include_option (char *spec)
10869 {
10870 #if FFECOM_GCC_INCLUDE
10871   return ffecom_decode_include_option_ (spec);
10872 #else
10873   return 1;
10874 #endif
10875 }
10876
10877 /* End a compound statement (block).  */
10878
10879 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10880 tree
10881 ffecom_end_compstmt (void)
10882 {
10883   return bison_rule_compstmt_ ();
10884 }
10885 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10886
10887 /* ffecom_end_transition -- Perform end transition on all symbols
10888
10889    ffecom_end_transition();
10890
10891    Calls ffecom_sym_end_transition for each global and local symbol.  */
10892
10893 void
10894 ffecom_end_transition ()
10895 {
10896 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10897   ffebld item;
10898 #endif
10899
10900   if (ffe_is_ffedebug ())
10901     fprintf (dmpout, "; end_stmt_transition\n");
10902
10903 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10904   ffecom_list_blockdata_ = NULL;
10905   ffecom_list_common_ = NULL;
10906 #endif
10907
10908   ffesymbol_drive (ffecom_sym_end_transition);
10909   if (ffe_is_ffedebug ())
10910     {
10911       ffestorag_report ();
10912 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10913       ffesymbol_report_all ();
10914 #endif
10915     }
10916
10917 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10918   ffecom_start_progunit_ ();
10919
10920   for (item = ffecom_list_blockdata_;
10921        item != NULL;
10922        item = ffebld_trail (item))
10923     {
10924       ffebld callee;
10925       ffesymbol s;
10926       tree dt;
10927       tree t;
10928       tree var;
10929       static int number = 0;
10930
10931       callee = ffebld_head (item);
10932       s = ffebld_symter (callee);
10933       t = ffesymbol_hook (s).decl_tree;
10934       if (t == NULL_TREE)
10935         {
10936           s = ffecom_sym_transform_ (s);
10937           t = ffesymbol_hook (s).decl_tree;
10938         }
10939
10940       dt = build_pointer_type (TREE_TYPE (t));
10941
10942       var = build_decl (VAR_DECL,
10943                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10944                                                         number++),
10945                         dt);
10946       DECL_EXTERNAL (var) = 0;
10947       TREE_STATIC (var) = 1;
10948       TREE_PUBLIC (var) = 0;
10949       DECL_INITIAL (var) = error_mark_node;
10950       TREE_USED (var) = 1;
10951
10952       var = start_decl (var, FALSE);
10953
10954       t = ffecom_1 (ADDR_EXPR, dt, t);
10955
10956       finish_decl (var, t, FALSE);
10957     }
10958
10959   /* This handles any COMMON areas that weren't referenced but have, for
10960      example, important initial data.  */
10961
10962   for (item = ffecom_list_common_;
10963        item != NULL;
10964        item = ffebld_trail (item))
10965     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10966
10967   ffecom_list_common_ = NULL;
10968 #endif
10969 }
10970
10971 /* ffecom_exec_transition -- Perform exec transition on all symbols
10972
10973    ffecom_exec_transition();
10974
10975    Calls ffecom_sym_exec_transition for each global and local symbol.
10976    Make sure error updating not inhibited.  */
10977
10978 void
10979 ffecom_exec_transition ()
10980 {
10981   bool inhibited;
10982
10983   if (ffe_is_ffedebug ())
10984     fprintf (dmpout, "; exec_stmt_transition\n");
10985
10986   inhibited = ffebad_inhibit ();
10987   ffebad_set_inhibit (FALSE);
10988
10989   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10990   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10991   if (ffe_is_ffedebug ())
10992     {
10993       ffestorag_report ();
10994 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10995       ffesymbol_report_all ();
10996 #endif
10997     }
10998
10999   if (inhibited)
11000     ffebad_set_inhibit (TRUE);
11001 }
11002
11003 /* Handle assignment statement.
11004
11005    Convert dest and source using ffecom_expr, then join them
11006    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11007
11008 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11009 void
11010 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11011 {
11012   tree dest_tree;
11013   tree dest_length;
11014   tree source_tree;
11015   tree expr_tree;
11016
11017   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11018     {
11019       bool dest_used;
11020       tree assign_temp;
11021
11022       /* This attempts to replicate the test below, but must not be
11023          true when the test below is false.  (Always err on the side
11024          of creating unused temporaries, to avoid ICEs.)  */
11025       if (ffebld_op (dest) != FFEBLD_opSYMTER
11026           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11027               && (TREE_CODE (dest_tree) != VAR_DECL
11028                   || TREE_ADDRESSABLE (dest_tree))))
11029         {
11030           ffecom_prepare_expr_ (source, dest);
11031           dest_used = TRUE;
11032         }
11033       else
11034         {
11035           ffecom_prepare_expr_ (source, NULL);
11036           dest_used = FALSE;
11037         }
11038
11039       ffecom_prepare_expr_w (NULL_TREE, dest);
11040
11041       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11042          create a temporary through which the assignment is to take place,
11043          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11044       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11045           && ffecom_possible_partial_overlap_ (dest, source))
11046         {
11047           assign_temp = ffecom_make_tempvar ("complex_let",
11048                                              ffecom_tree_type
11049                                              [ffebld_basictype (dest)]
11050                                              [ffebld_kindtype (dest)],
11051                                              FFETARGET_charactersizeNONE,
11052                                              -1);
11053         }
11054       else
11055         assign_temp = NULL_TREE;
11056
11057       ffecom_prepare_end ();
11058
11059       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11060       if (dest_tree == error_mark_node)
11061         return;
11062
11063       if ((TREE_CODE (dest_tree) != VAR_DECL)
11064           || TREE_ADDRESSABLE (dest_tree))
11065         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11066                                     FALSE, FALSE);
11067       else
11068         {
11069           assert (! dest_used);
11070           dest_used = FALSE;
11071           source_tree = ffecom_expr (source);
11072         }
11073       if (source_tree == error_mark_node)
11074         return;
11075
11076       if (dest_used)
11077         expr_tree = source_tree;
11078       else if (assign_temp)
11079         {
11080 #ifdef MOVE_EXPR
11081           /* The back end understands a conceptual move (evaluate source;
11082              store into dest), so use that, in case it can determine
11083              that it is going to use, say, two registers as temporaries
11084              anyway.  So don't use the temp (and someday avoid generating
11085              it, once this code starts triggering regularly).  */
11086           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11087                                  dest_tree,
11088                                  source_tree);
11089 #else
11090           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11091                                  assign_temp,
11092                                  source_tree);
11093           expand_expr_stmt (expr_tree);
11094           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11095                                  dest_tree,
11096                                  assign_temp);
11097 #endif
11098         }
11099       else
11100         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11101                                dest_tree,
11102                                source_tree);
11103
11104       expand_expr_stmt (expr_tree);
11105       return;
11106     }
11107
11108   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11109   ffecom_prepare_expr_w (NULL_TREE, dest);
11110
11111   ffecom_prepare_end ();
11112
11113   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11114   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11115                     source);
11116 }
11117
11118 #endif
11119 /* ffecom_expr -- Transform expr into gcc tree
11120
11121    tree t;
11122    ffebld expr;  // FFE expression.
11123    tree = ffecom_expr(expr);
11124
11125    Recursive descent on expr while making corresponding tree nodes and
11126    attaching type info and such.  */
11127
11128 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11129 tree
11130 ffecom_expr (ffebld expr)
11131 {
11132   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11133 }
11134
11135 #endif
11136 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11137
11138 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11139 tree
11140 ffecom_expr_assign (ffebld expr)
11141 {
11142   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11143 }
11144
11145 #endif
11146 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11147
11148 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11149 tree
11150 ffecom_expr_assign_w (ffebld expr)
11151 {
11152   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11153 }
11154
11155 #endif
11156 /* Transform expr for use as into read/write tree and stabilize the
11157    reference.  Not for use on CHARACTER expressions.
11158
11159    Recursive descent on expr while making corresponding tree nodes and
11160    attaching type info and such.  */
11161
11162 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11163 tree
11164 ffecom_expr_rw (tree type, ffebld expr)
11165 {
11166   assert (expr != NULL);
11167   /* Different target types not yet supported.  */
11168   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11169
11170   return stabilize_reference (ffecom_expr (expr));
11171 }
11172
11173 #endif
11174 /* Transform expr for use as into write tree and stabilize the
11175    reference.  Not for use on CHARACTER expressions.
11176
11177    Recursive descent on expr while making corresponding tree nodes and
11178    attaching type info and such.  */
11179
11180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11181 tree
11182 ffecom_expr_w (tree type, ffebld expr)
11183 {
11184   assert (expr != NULL);
11185   /* Different target types not yet supported.  */
11186   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11187
11188   return stabilize_reference (ffecom_expr (expr));
11189 }
11190
11191 #endif
11192 /* Do global stuff.  */
11193
11194 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11195 void
11196 ffecom_finish_compile ()
11197 {
11198   assert (ffecom_outer_function_decl_ == NULL_TREE);
11199   assert (current_function_decl == NULL_TREE);
11200
11201   ffeglobal_drive (ffecom_finish_global_);
11202 }
11203
11204 #endif
11205 /* Public entry point for front end to access finish_decl.  */
11206
11207 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11208 void
11209 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11210 {
11211   assert (!is_top_level);
11212   finish_decl (decl, init, FALSE);
11213 }
11214
11215 #endif
11216 /* Finish a program unit.  */
11217
11218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11219 void
11220 ffecom_finish_progunit ()
11221 {
11222   ffecom_end_compstmt ();
11223
11224   ffecom_previous_function_decl_ = current_function_decl;
11225   ffecom_which_entrypoint_decl_ = NULL_TREE;
11226
11227   finish_function (0);
11228 }
11229
11230 #endif
11231
11232 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11233
11234 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11235 tree
11236 ffecom_get_invented_identifier (const char *pattern, ...)
11237 {
11238   tree decl;
11239   char *nam;
11240   va_list ap;
11241
11242   va_start (ap, pattern);
11243   if (vasprintf (&nam, pattern, ap) == 0)
11244     abort ();
11245   va_end (ap);
11246   decl = get_identifier (nam);
11247   free (nam);
11248   IDENTIFIER_INVENTED (decl) = 1;
11249   return decl;
11250 }
11251
11252 ffeinfoBasictype
11253 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11254 {
11255   assert (gfrt < FFECOM_gfrt);
11256
11257   switch (ffecom_gfrt_type_[gfrt])
11258     {
11259     case FFECOM_rttypeVOID_:
11260     case FFECOM_rttypeVOIDSTAR_:
11261       return FFEINFO_basictypeNONE;
11262
11263     case FFECOM_rttypeFTNINT_:
11264       return FFEINFO_basictypeINTEGER;
11265
11266     case FFECOM_rttypeINTEGER_:
11267       return FFEINFO_basictypeINTEGER;
11268
11269     case FFECOM_rttypeLONGINT_:
11270       return FFEINFO_basictypeINTEGER;
11271
11272     case FFECOM_rttypeLOGICAL_:
11273       return FFEINFO_basictypeLOGICAL;
11274
11275     case FFECOM_rttypeREAL_F2C_:
11276     case FFECOM_rttypeREAL_GNU_:
11277       return FFEINFO_basictypeREAL;
11278
11279     case FFECOM_rttypeCOMPLEX_F2C_:
11280     case FFECOM_rttypeCOMPLEX_GNU_:
11281       return FFEINFO_basictypeCOMPLEX;
11282
11283     case FFECOM_rttypeDOUBLE_:
11284     case FFECOM_rttypeDOUBLEREAL_:
11285       return FFEINFO_basictypeREAL;
11286
11287     case FFECOM_rttypeDBLCMPLX_F2C_:
11288     case FFECOM_rttypeDBLCMPLX_GNU_:
11289       return FFEINFO_basictypeCOMPLEX;
11290
11291     case FFECOM_rttypeCHARACTER_:
11292       return FFEINFO_basictypeCHARACTER;
11293
11294     default:
11295       return FFEINFO_basictypeANY;
11296     }
11297 }
11298
11299 ffeinfoKindtype
11300 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11301 {
11302   assert (gfrt < FFECOM_gfrt);
11303
11304   switch (ffecom_gfrt_type_[gfrt])
11305     {
11306     case FFECOM_rttypeVOID_:
11307     case FFECOM_rttypeVOIDSTAR_:
11308       return FFEINFO_kindtypeNONE;
11309
11310     case FFECOM_rttypeFTNINT_:
11311       return FFEINFO_kindtypeINTEGER1;
11312
11313     case FFECOM_rttypeINTEGER_:
11314       return FFEINFO_kindtypeINTEGER1;
11315
11316     case FFECOM_rttypeLONGINT_:
11317       return FFEINFO_kindtypeINTEGER4;
11318
11319     case FFECOM_rttypeLOGICAL_:
11320       return FFEINFO_kindtypeLOGICAL1;
11321
11322     case FFECOM_rttypeREAL_F2C_:
11323     case FFECOM_rttypeREAL_GNU_:
11324       return FFEINFO_kindtypeREAL1;
11325
11326     case FFECOM_rttypeCOMPLEX_F2C_:
11327     case FFECOM_rttypeCOMPLEX_GNU_:
11328       return FFEINFO_kindtypeREAL1;
11329
11330     case FFECOM_rttypeDOUBLE_:
11331     case FFECOM_rttypeDOUBLEREAL_:
11332       return FFEINFO_kindtypeREAL2;
11333
11334     case FFECOM_rttypeDBLCMPLX_F2C_:
11335     case FFECOM_rttypeDBLCMPLX_GNU_:
11336       return FFEINFO_kindtypeREAL2;
11337
11338     case FFECOM_rttypeCHARACTER_:
11339       return FFEINFO_kindtypeCHARACTER1;
11340
11341     default:
11342       return FFEINFO_kindtypeANY;
11343     }
11344 }
11345
11346 void
11347 ffecom_init_0 ()
11348 {
11349   tree endlink;
11350   int i;
11351   int j;
11352   tree t;
11353   tree field;
11354   ffetype type;
11355   ffetype base_type;
11356   tree double_ftype_double;
11357   tree float_ftype_float;
11358   tree ldouble_ftype_ldouble;
11359   tree ffecom_tree_ptr_to_fun_type_void;
11360
11361   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11362      whether the compiler environment is buggy in known ways, some of which
11363      would, if not explicitly checked here, result in subtle bugs in g77.  */
11364
11365   if (ffe_is_do_internal_checks ())
11366     {
11367       static char names[][12]
11368         =
11369       {"bar", "bletch", "foo", "foobar"};
11370       char *name;
11371       unsigned long ul;
11372       double fl;
11373
11374       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11375                       (int (*)(const void *, const void *)) strcmp);
11376       if (name != (char *) &names[2])
11377         {
11378           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11379                   == NULL);
11380           abort ();
11381         }
11382
11383       ul = strtoul ("123456789", NULL, 10);
11384       if (ul != 123456789L)
11385         {
11386           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11387  in proj.h" == NULL);
11388           abort ();
11389         }
11390
11391       fl = atof ("56.789");
11392       if ((fl < 56.788) || (fl > 56.79))
11393         {
11394           assert ("atof not type double, fix your #include <stdio.h>"
11395                   == NULL);
11396           abort ();
11397         }
11398     }
11399
11400 #if FFECOM_GCC_INCLUDE
11401   ffecom_initialize_char_syntax_ ();
11402 #endif
11403
11404   ffecom_outer_function_decl_ = NULL_TREE;
11405   current_function_decl = NULL_TREE;
11406   named_labels = NULL_TREE;
11407   current_binding_level = NULL_BINDING_LEVEL;
11408   free_binding_level = NULL_BINDING_LEVEL;
11409   /* Make the binding_level structure for global names.  */
11410   pushlevel (0);
11411   global_binding_level = current_binding_level;
11412   current_binding_level->prep_state = 2;
11413
11414   build_common_tree_nodes (1);
11415
11416   /* Define `int' and `char' first so that dbx will output them first.  */
11417   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11418                         integer_type_node));
11419   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11420                         char_type_node));
11421   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11422                         long_integer_type_node));
11423   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11424                         unsigned_type_node));
11425   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11426                         long_unsigned_type_node));
11427   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11428                         long_long_integer_type_node));
11429   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11430                         long_long_unsigned_type_node));
11431   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11432                         short_integer_type_node));
11433   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11434                         short_unsigned_type_node));
11435
11436   /* Set the sizetype before we make other types.  This *should* be the
11437      first type we create.  */
11438
11439   set_sizetype
11440     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11441   ffecom_typesize_pointer_
11442     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11443
11444   build_common_tree_nodes_2 (0);
11445
11446   /* Define both `signed char' and `unsigned char'.  */
11447   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11448                         signed_char_type_node));
11449
11450   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11451                         unsigned_char_type_node));
11452
11453   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11454                         float_type_node));
11455   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11456                         double_type_node));
11457   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11458                         long_double_type_node));
11459
11460   /* For now, override what build_common_tree_nodes has done.  */
11461   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11462   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11463   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11464   complex_long_double_type_node
11465     = ffecom_make_complex_type_ (long_double_type_node);
11466
11467   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11468                         complex_integer_type_node));
11469   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11470                         complex_float_type_node));
11471   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11472                         complex_double_type_node));
11473   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11474                         complex_long_double_type_node));
11475
11476   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11477                         void_type_node));
11478   /* We are not going to have real types in C with less than byte alignment,
11479      so we might as well not have any types that claim to have it.  */
11480   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11481   TYPE_USER_ALIGN (void_type_node) = 0;
11482
11483   string_type_node = build_pointer_type (char_type_node);
11484
11485   ffecom_tree_fun_type_void
11486     = build_function_type (void_type_node, NULL_TREE);
11487
11488   ffecom_tree_ptr_to_fun_type_void
11489     = build_pointer_type (ffecom_tree_fun_type_void);
11490
11491   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11492
11493   float_ftype_float
11494     = build_function_type (float_type_node,
11495                            tree_cons (NULL_TREE, float_type_node, endlink));
11496
11497   double_ftype_double
11498     = build_function_type (double_type_node,
11499                            tree_cons (NULL_TREE, double_type_node, endlink));
11500
11501   ldouble_ftype_ldouble
11502     = build_function_type (long_double_type_node,
11503                            tree_cons (NULL_TREE, long_double_type_node,
11504                                       endlink));
11505
11506   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11507     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11508       {
11509         ffecom_tree_type[i][j] = NULL_TREE;
11510         ffecom_tree_fun_type[i][j] = NULL_TREE;
11511         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11512         ffecom_f2c_typecode_[i][j] = -1;
11513       }
11514
11515   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11516      to size FLOAT_TYPE_SIZE because they have to be the same size as
11517      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11518      Compiler options and other such stuff that change the ways these
11519      types are set should not affect this particular setup.  */
11520
11521   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11522     = t = make_signed_type (FLOAT_TYPE_SIZE);
11523   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11524                         t));
11525   type = ffetype_new ();
11526   base_type = type;
11527   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11528                     type);
11529   ffetype_set_ams (type,
11530                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11531                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11532   ffetype_set_star (base_type,
11533                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11534                     type);
11535   ffetype_set_kind (base_type, 1, type);
11536   ffecom_typesize_integer1_ = ffetype_size (type);
11537   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11538
11539   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11540     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11541   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11542                         t));
11543
11544   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11545     = t = make_signed_type (CHAR_TYPE_SIZE);
11546   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11547                         t));
11548   type = ffetype_new ();
11549   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11550                     type);
11551   ffetype_set_ams (type,
11552                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11553                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11554   ffetype_set_star (base_type,
11555                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11556                     type);
11557   ffetype_set_kind (base_type, 3, type);
11558   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11559
11560   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11561     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11562   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11563                         t));
11564
11565   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11566     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11567   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11568                         t));
11569   type = ffetype_new ();
11570   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11571                     type);
11572   ffetype_set_ams (type,
11573                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11574                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11575   ffetype_set_star (base_type,
11576                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11577                     type);
11578   ffetype_set_kind (base_type, 6, type);
11579   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11580
11581   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11582     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11583   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11584                         t));
11585
11586   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11587     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11588   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11589                         t));
11590   type = ffetype_new ();
11591   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11592                     type);
11593   ffetype_set_ams (type,
11594                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11595                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11596   ffetype_set_star (base_type,
11597                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11598                     type);
11599   ffetype_set_kind (base_type, 2, type);
11600   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11601
11602   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11603     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11604   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11605                         t));
11606
11607 #if 0
11608   if (ffe_is_do_internal_checks ()
11609       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11610       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11611       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11612       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11613     {
11614       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11615                LONG_TYPE_SIZE);
11616     }
11617 #endif
11618
11619   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11620     = t = make_signed_type (FLOAT_TYPE_SIZE);
11621   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11622                         t));
11623   type = ffetype_new ();
11624   base_type = type;
11625   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11626                     type);
11627   ffetype_set_ams (type,
11628                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11629                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11630   ffetype_set_star (base_type,
11631                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11632                     type);
11633   ffetype_set_kind (base_type, 1, type);
11634   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11635
11636   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11637     = t = make_signed_type (CHAR_TYPE_SIZE);
11638   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11639                         t));
11640   type = ffetype_new ();
11641   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11642                     type);
11643   ffetype_set_ams (type,
11644                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11645                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11646   ffetype_set_star (base_type,
11647                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11648                     type);
11649   ffetype_set_kind (base_type, 3, type);
11650   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11651
11652   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11653     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11654   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11655                         t));
11656   type = ffetype_new ();
11657   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11658                     type);
11659   ffetype_set_ams (type,
11660                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11661                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11662   ffetype_set_star (base_type,
11663                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11664                     type);
11665   ffetype_set_kind (base_type, 6, type);
11666   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11667
11668   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11669     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11670   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11671                         t));
11672   type = ffetype_new ();
11673   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11674                     type);
11675   ffetype_set_ams (type,
11676                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11677                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11678   ffetype_set_star (base_type,
11679                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11680                     type);
11681   ffetype_set_kind (base_type, 2, type);
11682   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11683
11684   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11685     = t = make_node (REAL_TYPE);
11686   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11687   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11688                         t));
11689   layout_type (t);
11690   type = ffetype_new ();
11691   base_type = type;
11692   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11693                     type);
11694   ffetype_set_ams (type,
11695                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11696                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11697   ffetype_set_star (base_type,
11698                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11699                     type);
11700   ffetype_set_kind (base_type, 1, type);
11701   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11702     = FFETARGET_f2cTYREAL;
11703   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11704
11705   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11706     = t = make_node (REAL_TYPE);
11707   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11708   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11709                         t));
11710   layout_type (t);
11711   type = ffetype_new ();
11712   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11713                     type);
11714   ffetype_set_ams (type,
11715                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11716                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11717   ffetype_set_star (base_type,
11718                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11719                     type);
11720   ffetype_set_kind (base_type, 2, type);
11721   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11722     = FFETARGET_f2cTYDREAL;
11723   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11724
11725   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11726     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11727   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11728                         t));
11729   type = ffetype_new ();
11730   base_type = type;
11731   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11732                     type);
11733   ffetype_set_ams (type,
11734                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11735                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11736   ffetype_set_star (base_type,
11737                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11738                     type);
11739   ffetype_set_kind (base_type, 1, type);
11740   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11741     = FFETARGET_f2cTYCOMPLEX;
11742   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11743
11744   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11745     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11746   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11747                         t));
11748   type = ffetype_new ();
11749   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11750                     type);
11751   ffetype_set_ams (type,
11752                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11753                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11754   ffetype_set_star (base_type,
11755                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11756                     type);
11757   ffetype_set_kind (base_type, 2,
11758                     type);
11759   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11760     = FFETARGET_f2cTYDCOMPLEX;
11761   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11762
11763   /* Make function and ptr-to-function types for non-CHARACTER types. */
11764
11765   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11766     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11767       {
11768         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11769           {
11770             if (i == FFEINFO_basictypeINTEGER)
11771               {
11772                 /* Figure out the smallest INTEGER type that can hold
11773                    a pointer on this machine. */
11774                 if (GET_MODE_SIZE (TYPE_MODE (t))
11775                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11776                   {
11777                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11778                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11779                             > GET_MODE_SIZE (TYPE_MODE (t))))
11780                       ffecom_pointer_kind_ = j;
11781                   }
11782               }
11783             else if (i == FFEINFO_basictypeCOMPLEX)
11784               t = void_type_node;
11785             /* For f2c compatibility, REAL functions are really
11786                implemented as DOUBLE PRECISION.  */
11787             else if ((i == FFEINFO_basictypeREAL)
11788                      && (j == FFEINFO_kindtypeREAL1))
11789               t = ffecom_tree_type
11790                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11791
11792             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11793                                                                   NULL_TREE);
11794             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11795           }
11796       }
11797
11798   /* Set up pointer types.  */
11799
11800   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11801     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11802   else if (0 && ffe_is_do_internal_checks ())
11803     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11804   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11805                                   FFEINFO_kindtypeINTEGERDEFAULT),
11806                     7,
11807                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11808                                   ffecom_pointer_kind_));
11809
11810   if (ffe_is_ugly_assign ())
11811     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11812   else
11813     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11814   if (0 && ffe_is_do_internal_checks ())
11815     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11816
11817   ffecom_integer_type_node
11818     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11819   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11820                                       integer_zero_node);
11821   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11822                                      integer_one_node);
11823
11824   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11825      Turns out that by TYLONG, runtime/libI77/lio.h really means
11826      "whatever size an ftnint is".  For consistency and sanity,
11827      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11828      all are INTEGER, which we also make out of whatever back-end
11829      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11830      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11831      accommodate machines like the Alpha.  Note that this suggests
11832      f2c and libf2c are missing a distinction perhaps needed on
11833      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11834
11835   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11836                             FFETARGET_f2cTYLONG);
11837   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11838                             FFETARGET_f2cTYSHORT);
11839   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11840                             FFETARGET_f2cTYINT1);
11841   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11842                             FFETARGET_f2cTYQUAD);
11843   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11844                             FFETARGET_f2cTYLOGICAL);
11845   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11846                             FFETARGET_f2cTYLOGICAL2);
11847   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11848                             FFETARGET_f2cTYLOGICAL1);
11849   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11850   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11851                             FFETARGET_f2cTYQUAD);
11852
11853   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11854      loop.  CHARACTER items are built as arrays of unsigned char.  */
11855
11856   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11857     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11858   type = ffetype_new ();
11859   base_type = type;
11860   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11861                     FFEINFO_kindtypeCHARACTER1,
11862                     type);
11863   ffetype_set_ams (type,
11864                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11865                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11866   ffetype_set_kind (base_type, 1, type);
11867   assert (ffetype_size (type)
11868           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11869
11870   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11871     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11872   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11873     [FFEINFO_kindtypeCHARACTER1]
11874     = ffecom_tree_ptr_to_fun_type_void;
11875   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11876     = FFETARGET_f2cTYCHAR;
11877
11878   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11879     = 0;
11880
11881   /* Make multi-return-value type and fields. */
11882
11883   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11884
11885   field = NULL_TREE;
11886
11887   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11888     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11889       {
11890         char name[30];
11891
11892         if (ffecom_tree_type[i][j] == NULL_TREE)
11893           continue;             /* Not supported. */
11894         sprintf (&name[0], "bt_%s_kt_%s",
11895                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11896                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11897         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11898                                                  get_identifier (name),
11899                                                  ffecom_tree_type[i][j]);
11900         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11901           = ffecom_multi_type_node_;
11902         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11903         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11904         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11905         field = ffecom_multi_fields_[i][j];
11906       }
11907
11908   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11909   layout_type (ffecom_multi_type_node_);
11910
11911   /* Subroutines usually return integer because they might have alternate
11912      returns. */
11913
11914   ffecom_tree_subr_type
11915     = build_function_type (integer_type_node, NULL_TREE);
11916   ffecom_tree_ptr_to_subr_type
11917     = build_pointer_type (ffecom_tree_subr_type);
11918   ffecom_tree_blockdata_type
11919     = build_function_type (void_type_node, NULL_TREE);
11920
11921   builtin_function ("__builtin_sqrtf", float_ftype_float,
11922                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11923   builtin_function ("__builtin_fsqrt", double_ftype_double,
11924                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11925   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11926                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11927   builtin_function ("__builtin_sinf", float_ftype_float,
11928                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11929   builtin_function ("__builtin_sin", double_ftype_double,
11930                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11931   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11932                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11933   builtin_function ("__builtin_cosf", float_ftype_float,
11934                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11935   builtin_function ("__builtin_cos", double_ftype_double,
11936                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11937   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11938                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11939
11940 #if BUILT_FOR_270
11941   pedantic_lvalues = FALSE;
11942 #endif
11943
11944   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11945                          FFECOM_f2cINTEGER,
11946                          "integer");
11947   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11948                          FFECOM_f2cADDRESS,
11949                          "address");
11950   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11951                          FFECOM_f2cREAL,
11952                          "real");
11953   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11954                          FFECOM_f2cDOUBLEREAL,
11955                          "doublereal");
11956   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11957                          FFECOM_f2cCOMPLEX,
11958                          "complex");
11959   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11960                          FFECOM_f2cDOUBLECOMPLEX,
11961                          "doublecomplex");
11962   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11963                          FFECOM_f2cLONGINT,
11964                          "longint");
11965   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11966                          FFECOM_f2cLOGICAL,
11967                          "logical");
11968   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11969                          FFECOM_f2cFLAG,
11970                          "flag");
11971   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11972                          FFECOM_f2cFTNLEN,
11973                          "ftnlen");
11974   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11975                          FFECOM_f2cFTNINT,
11976                          "ftnint");
11977
11978   ffecom_f2c_ftnlen_zero_node
11979     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11980
11981   ffecom_f2c_ftnlen_one_node
11982     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11983
11984   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11985   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11986
11987   ffecom_f2c_ptr_to_ftnlen_type_node
11988     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11989
11990   ffecom_f2c_ptr_to_ftnint_type_node
11991     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11992
11993   ffecom_f2c_ptr_to_integer_type_node
11994     = build_pointer_type (ffecom_f2c_integer_type_node);
11995
11996   ffecom_f2c_ptr_to_real_type_node
11997     = build_pointer_type (ffecom_f2c_real_type_node);
11998
11999   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12000   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12001   {
12002     REAL_VALUE_TYPE point_5;
12003
12004 #ifdef REAL_ARITHMETIC
12005     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12006 #else
12007     point_5 = .5;
12008 #endif
12009     ffecom_float_half_ = build_real (float_type_node, point_5);
12010     ffecom_double_half_ = build_real (double_type_node, point_5);
12011   }
12012
12013   /* Do "extern int xargc;".  */
12014
12015   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12016                                    get_identifier ("f__xargc"),
12017                                    integer_type_node);
12018   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12019   TREE_STATIC (ffecom_tree_xargc_) = 1;
12020   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12021   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12022   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12023
12024 #if 0   /* This is being fixed, and seems to be working now. */
12025   if ((FLOAT_TYPE_SIZE != 32)
12026       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12027     {
12028       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12029                (int) FLOAT_TYPE_SIZE);
12030       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12031           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12032       warning ("properly unless they all are 32 bits wide.");
12033       warning ("Please keep this in mind before you report bugs.  g77 should");
12034       warning ("support non-32-bit machines better as of version 0.6.");
12035     }
12036 #endif
12037
12038 #if 0   /* Code in ste.c that would crash has been commented out. */
12039   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12040       < TYPE_PRECISION (string_type_node))
12041     /* I/O will probably crash.  */
12042     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12043              TYPE_PRECISION (string_type_node),
12044              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12045 #endif
12046
12047 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12048   if (TYPE_PRECISION (ffecom_integer_type_node)
12049       < TYPE_PRECISION (string_type_node))
12050     /* ASSIGN 10 TO I will crash.  */
12051     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12052  ASSIGN statement might fail",
12053              TYPE_PRECISION (string_type_node),
12054              TYPE_PRECISION (ffecom_integer_type_node));
12055 #endif
12056 }
12057
12058 #endif
12059 /* ffecom_init_2 -- Initialize
12060
12061    ffecom_init_2();  */
12062
12063 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12064 void
12065 ffecom_init_2 ()
12066 {
12067   assert (ffecom_outer_function_decl_ == NULL_TREE);
12068   assert (current_function_decl == NULL_TREE);
12069   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12070
12071   ffecom_master_arglist_ = NULL;
12072   ++ffecom_num_fns_;
12073   ffecom_primary_entry_ = NULL;
12074   ffecom_is_altreturning_ = FALSE;
12075   ffecom_func_result_ = NULL_TREE;
12076   ffecom_multi_retval_ = NULL_TREE;
12077 }
12078
12079 #endif
12080 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12081
12082    tree t;
12083    ffebld expr;  // FFE opITEM list.
12084    tree = ffecom_list_expr(expr);
12085
12086    List of actual args is transformed into corresponding gcc backend list.  */
12087
12088 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12089 tree
12090 ffecom_list_expr (ffebld expr)
12091 {
12092   tree list;
12093   tree *plist = &list;
12094   tree trail = NULL_TREE;       /* Append char length args here. */
12095   tree *ptrail = &trail;
12096   tree length;
12097
12098   while (expr != NULL)
12099     {
12100       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12101
12102       if (texpr == error_mark_node)
12103         return error_mark_node;
12104
12105       *plist = build_tree_list (NULL_TREE, texpr);
12106       plist = &TREE_CHAIN (*plist);
12107       expr = ffebld_trail (expr);
12108       if (length != NULL_TREE)
12109         {
12110           *ptrail = build_tree_list (NULL_TREE, length);
12111           ptrail = &TREE_CHAIN (*ptrail);
12112         }
12113     }
12114
12115   *plist = trail;
12116
12117   return list;
12118 }
12119
12120 #endif
12121 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12122
12123    tree t;
12124    ffebld expr;  // FFE opITEM list.
12125    tree = ffecom_list_ptr_to_expr(expr);
12126
12127    List of actual args is transformed into corresponding gcc backend list for
12128    use in calling an external procedure (vs. a statement function).  */
12129
12130 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12131 tree
12132 ffecom_list_ptr_to_expr (ffebld expr)
12133 {
12134   tree list;
12135   tree *plist = &list;
12136   tree trail = NULL_TREE;       /* Append char length args here. */
12137   tree *ptrail = &trail;
12138   tree length;
12139
12140   while (expr != NULL)
12141     {
12142       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12143
12144       if (texpr == error_mark_node)
12145         return error_mark_node;
12146
12147       *plist = build_tree_list (NULL_TREE, texpr);
12148       plist = &TREE_CHAIN (*plist);
12149       expr = ffebld_trail (expr);
12150       if (length != NULL_TREE)
12151         {
12152           *ptrail = build_tree_list (NULL_TREE, length);
12153           ptrail = &TREE_CHAIN (*ptrail);
12154         }
12155     }
12156
12157   *plist = trail;
12158
12159   return list;
12160 }
12161
12162 #endif
12163 /* Obtain gcc's LABEL_DECL tree for label.  */
12164
12165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12166 tree
12167 ffecom_lookup_label (ffelab label)
12168 {
12169   tree glabel;
12170
12171   if (ffelab_hook (label) == NULL_TREE)
12172     {
12173       char labelname[16];
12174
12175       switch (ffelab_type (label))
12176         {
12177         case FFELAB_typeLOOPEND:
12178         case FFELAB_typeNOTLOOP:
12179         case FFELAB_typeENDIF:
12180           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12181           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12182                                void_type_node);
12183           DECL_CONTEXT (glabel) = current_function_decl;
12184           DECL_MODE (glabel) = VOIDmode;
12185           break;
12186
12187         case FFELAB_typeFORMAT:
12188           glabel = build_decl (VAR_DECL,
12189                                ffecom_get_invented_identifier
12190                                ("__g77_format_%d", (int) ffelab_value (label)),
12191                                build_type_variant (build_array_type
12192                                                    (char_type_node,
12193                                                     NULL_TREE),
12194                                                    1, 0));
12195           TREE_CONSTANT (glabel) = 1;
12196           TREE_STATIC (glabel) = 1;
12197           DECL_CONTEXT (glabel) = current_function_decl;
12198           DECL_INITIAL (glabel) = NULL;
12199           make_decl_rtl (glabel, NULL);
12200           expand_decl (glabel);
12201
12202           ffecom_save_tree_forever (glabel);
12203
12204           break;
12205
12206         case FFELAB_typeANY:
12207           glabel = error_mark_node;
12208           break;
12209
12210         default:
12211           assert ("bad label type" == NULL);
12212           glabel = NULL;
12213           break;
12214         }
12215       ffelab_set_hook (label, glabel);
12216     }
12217   else
12218     {
12219       glabel = ffelab_hook (label);
12220     }
12221
12222   return glabel;
12223 }
12224
12225 #endif
12226 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12227    a single source specification (as in the fourth argument of MVBITS).
12228    If the type is NULL_TREE, the type of lhs is used to make the type of
12229    the MODIFY_EXPR.  */
12230
12231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12232 tree
12233 ffecom_modify (tree newtype, tree lhs,
12234                tree rhs)
12235 {
12236   if (lhs == error_mark_node || rhs == error_mark_node)
12237     return error_mark_node;
12238
12239   if (newtype == NULL_TREE)
12240     newtype = TREE_TYPE (lhs);
12241
12242   if (TREE_SIDE_EFFECTS (lhs))
12243     lhs = stabilize_reference (lhs);
12244
12245   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12246 }
12247
12248 #endif
12249
12250 /* Register source file name.  */
12251
12252 void
12253 ffecom_file (const char *name)
12254 {
12255 #if FFECOM_GCC_INCLUDE
12256   ffecom_file_ (name);
12257 #endif
12258 }
12259
12260 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12261
12262    ffestorag st;
12263    ffecom_notify_init_storage(st);
12264
12265    Gets called when all possible units in an aggregate storage area (a LOCAL
12266    with equivalences or a COMMON) have been initialized.  The initialization
12267    info either is in ffestorag_init or, if that is NULL,
12268    ffestorag_accretion:
12269
12270    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12271    even for an array if the array is one element in length!
12272
12273    ffestorag_accretion will contain an opACCTER.  It is much like an
12274    opARRTER except it has an ffebit object in it instead of just a size.
12275    The back end can use the info in the ffebit object, if it wants, to
12276    reduce the amount of actual initialization, but in any case it should
12277    kill the ffebit object when done.  Also, set accretion to NULL but
12278    init to a non-NULL value.
12279
12280    After performing initialization, DO NOT set init to NULL, because that'll
12281    tell the front end it is ok for more initialization to happen.  Instead,
12282    set init to an opANY expression or some such thing that you can use to
12283    tell that you've already initialized the object.
12284
12285    27-Oct-91  JCB  1.1
12286       Support two-pass FFE.  */
12287
12288 void
12289 ffecom_notify_init_storage (ffestorag st)
12290 {
12291   ffebld init;                  /* The initialization expression. */
12292 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12293   ffetargetOffset size;         /* The size of the entity. */
12294   ffetargetAlign pad;           /* Its initial padding. */
12295 #endif
12296
12297   if (ffestorag_init (st) == NULL)
12298     {
12299       init = ffestorag_accretion (st);
12300       assert (init != NULL);
12301       ffestorag_set_accretion (st, NULL);
12302       ffestorag_set_accretes (st, 0);
12303
12304 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12305       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12306       size = ffebld_accter_size (init);
12307       pad = ffebld_accter_pad (init);
12308       ffebit_kill (ffebld_accter_bits (init));
12309       ffebld_set_op (init, FFEBLD_opARRTER);
12310       ffebld_set_arrter (init, ffebld_accter (init));
12311       ffebld_arrter_set_size (init, size);
12312       ffebld_arrter_set_pad (init, size);
12313 #endif
12314
12315 #if FFECOM_TWOPASS
12316       ffestorag_set_init (st, init);
12317 #endif
12318     }
12319 #if FFECOM_ONEPASS
12320   else
12321     init = ffestorag_init (st);
12322 #endif
12323
12324 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12325   ffestorag_set_init (st, ffebld_new_any ());
12326
12327   if (ffebld_op (init) == FFEBLD_opANY)
12328     return;                     /* Oh, we already did this! */
12329
12330 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12331   {
12332     ffesymbol s;
12333
12334     if (ffestorag_symbol (st) != NULL)
12335       s = ffestorag_symbol (st);
12336     else
12337       s = ffestorag_typesymbol (st);
12338
12339     fprintf (dmpout, "= initialize_storage \"%s\" ",
12340              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12341     ffebld_dump (init);
12342     fputc ('\n', dmpout);
12343   }
12344 #endif
12345
12346 #endif /* if FFECOM_ONEPASS */
12347 }
12348
12349 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12350
12351    ffesymbol s;
12352    ffecom_notify_init_symbol(s);
12353
12354    Gets called when all possible units in a symbol (not placed in COMMON
12355    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12356    have been initialized.  The initialization info either is in
12357    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12358
12359    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12360    even for an array if the array is one element in length!
12361
12362    ffesymbol_accretion will contain an opACCTER.  It is much like an
12363    opARRTER except it has an ffebit object in it instead of just a size.
12364    The back end can use the info in the ffebit object, if it wants, to
12365    reduce the amount of actual initialization, but in any case it should
12366    kill the ffebit object when done.  Also, set accretion to NULL but
12367    init to a non-NULL value.
12368
12369    After performing initialization, DO NOT set init to NULL, because that'll
12370    tell the front end it is ok for more initialization to happen.  Instead,
12371    set init to an opANY expression or some such thing that you can use to
12372    tell that you've already initialized the object.
12373
12374    27-Oct-91  JCB  1.1
12375       Support two-pass FFE.  */
12376
12377 void
12378 ffecom_notify_init_symbol (ffesymbol s)
12379 {
12380   ffebld init;                  /* The initialization expression. */
12381 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12382   ffetargetOffset size;         /* The size of the entity. */
12383   ffetargetAlign pad;           /* Its initial padding. */
12384 #endif
12385
12386   if (ffesymbol_storage (s) == NULL)
12387     return;                     /* Do nothing until COMMON/EQUIVALENCE
12388                                    possibilities checked. */
12389
12390   if ((ffesymbol_init (s) == NULL)
12391       && ((init = ffesymbol_accretion (s)) != NULL))
12392     {
12393       ffesymbol_set_accretion (s, NULL);
12394       ffesymbol_set_accretes (s, 0);
12395
12396 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12397       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12398       size = ffebld_accter_size (init);
12399       pad = ffebld_accter_pad (init);
12400       ffebit_kill (ffebld_accter_bits (init));
12401       ffebld_set_op (init, FFEBLD_opARRTER);
12402       ffebld_set_arrter (init, ffebld_accter (init));
12403       ffebld_arrter_set_size (init, size);
12404       ffebld_arrter_set_pad (init, size);
12405 #endif
12406
12407 #if FFECOM_TWOPASS
12408       ffesymbol_set_init (s, init);
12409 #endif
12410     }
12411 #if FFECOM_ONEPASS
12412   else
12413     init = ffesymbol_init (s);
12414 #endif
12415
12416 #if FFECOM_ONEPASS
12417   ffesymbol_set_init (s, ffebld_new_any ());
12418
12419   if (ffebld_op (init) == FFEBLD_opANY)
12420     return;                     /* Oh, we already did this! */
12421
12422 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12423   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12424   ffebld_dump (init);
12425   fputc ('\n', dmpout);
12426 #endif
12427
12428 #endif /* if FFECOM_ONEPASS */
12429 }
12430
12431 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12432
12433    ffesymbol s;
12434    ffecom_notify_primary_entry(s);
12435
12436    Gets called when implicit or explicit PROGRAM statement seen or when
12437    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12438    global symbol that serves as the entry point.  */
12439
12440 void
12441 ffecom_notify_primary_entry (ffesymbol s)
12442 {
12443   ffecom_primary_entry_ = s;
12444   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12445
12446   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12447       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12448     ffecom_primary_entry_is_proc_ = TRUE;
12449   else
12450     ffecom_primary_entry_is_proc_ = FALSE;
12451
12452   if (!ffe_is_silent ())
12453     {
12454       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12455         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12456       else
12457         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12458     }
12459
12460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12461   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12462     {
12463       ffebld list;
12464       ffebld arg;
12465
12466       for (list = ffesymbol_dummyargs (s);
12467            list != NULL;
12468            list = ffebld_trail (list))
12469         {
12470           arg = ffebld_head (list);
12471           if (ffebld_op (arg) == FFEBLD_opSTAR)
12472             {
12473               ffecom_is_altreturning_ = TRUE;
12474               break;
12475             }
12476         }
12477     }
12478 #endif
12479 }
12480
12481 FILE *
12482 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12483 {
12484 #if FFECOM_GCC_INCLUDE
12485   return ffecom_open_include_ (name, l, c);
12486 #else
12487   return fopen (name, "r");
12488 #endif
12489 }
12490
12491 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12492
12493    tree t;
12494    ffebld expr;  // FFE expression.
12495    tree = ffecom_ptr_to_expr(expr);
12496
12497    Like ffecom_expr, but sticks address-of in front of most things.  */
12498
12499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12500 tree
12501 ffecom_ptr_to_expr (ffebld expr)
12502 {
12503   tree item;
12504   ffeinfoBasictype bt;
12505   ffeinfoKindtype kt;
12506   ffesymbol s;
12507
12508   assert (expr != NULL);
12509
12510   switch (ffebld_op (expr))
12511     {
12512     case FFEBLD_opSYMTER:
12513       s = ffebld_symter (expr);
12514       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12515         {
12516           ffecomGfrt ix;
12517
12518           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12519           assert (ix != FFECOM_gfrt);
12520           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12521             {
12522               ffecom_make_gfrt_ (ix);
12523               item = ffecom_gfrt_[ix];
12524             }
12525         }
12526       else
12527         {
12528           item = ffesymbol_hook (s).decl_tree;
12529           if (item == NULL_TREE)
12530             {
12531               s = ffecom_sym_transform_ (s);
12532               item = ffesymbol_hook (s).decl_tree;
12533             }
12534         }
12535       assert (item != NULL);
12536       if (item == error_mark_node)
12537         return item;
12538       if (!ffesymbol_hook (s).addr)
12539         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12540                          item);
12541       return item;
12542
12543     case FFEBLD_opARRAYREF:
12544       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12545
12546     case FFEBLD_opCONTER:
12547
12548       bt = ffeinfo_basictype (ffebld_info (expr));
12549       kt = ffeinfo_kindtype (ffebld_info (expr));
12550
12551       item = ffecom_constantunion (&ffebld_constant_union
12552                                    (ffebld_conter (expr)), bt, kt,
12553                                    ffecom_tree_type[bt][kt]);
12554       if (item == error_mark_node)
12555         return error_mark_node;
12556       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12557                        item);
12558       return item;
12559
12560     case FFEBLD_opANY:
12561       return error_mark_node;
12562
12563     default:
12564       bt = ffeinfo_basictype (ffebld_info (expr));
12565       kt = ffeinfo_kindtype (ffebld_info (expr));
12566
12567       item = ffecom_expr (expr);
12568       if (item == error_mark_node)
12569         return error_mark_node;
12570
12571       /* The back end currently optimizes a bit too zealously for us, in that
12572          we fail JCB001 if the following block of code is omitted.  It checks
12573          to see if the transformed expression is a symbol or array reference,
12574          and encloses it in a SAVE_EXPR if that is the case.  */
12575
12576       STRIP_NOPS (item);
12577       if ((TREE_CODE (item) == VAR_DECL)
12578           || (TREE_CODE (item) == PARM_DECL)
12579           || (TREE_CODE (item) == RESULT_DECL)
12580           || (TREE_CODE (item) == INDIRECT_REF)
12581           || (TREE_CODE (item) == ARRAY_REF)
12582           || (TREE_CODE (item) == COMPONENT_REF)
12583 #ifdef OFFSET_REF
12584           || (TREE_CODE (item) == OFFSET_REF)
12585 #endif
12586           || (TREE_CODE (item) == BUFFER_REF)
12587           || (TREE_CODE (item) == REALPART_EXPR)
12588           || (TREE_CODE (item) == IMAGPART_EXPR))
12589         {
12590           item = ffecom_save_tree (item);
12591         }
12592
12593       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12594                        item);
12595       return item;
12596     }
12597
12598   assert ("fall-through error" == NULL);
12599   return error_mark_node;
12600 }
12601
12602 #endif
12603 /* Obtain a temp var with given data type.
12604
12605    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12606    or >= 0 for a CHARACTER type.
12607
12608    elements is -1 for a scalar or > 0 for an array of type.  */
12609
12610 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12611 tree
12612 ffecom_make_tempvar (const char *commentary, tree type,
12613                      ffetargetCharacterSize size, int elements)
12614 {
12615   tree t;
12616   static int mynumber;
12617
12618   assert (current_binding_level->prep_state < 2);
12619
12620   if (type == error_mark_node)
12621     return error_mark_node;
12622
12623   if (size != FFETARGET_charactersizeNONE)
12624     type = build_array_type (type,
12625                              build_range_type (ffecom_f2c_ftnlen_type_node,
12626                                                ffecom_f2c_ftnlen_one_node,
12627                                                build_int_2 (size, 0)));
12628   if (elements != -1)
12629     type = build_array_type (type,
12630                              build_range_type (integer_type_node,
12631                                                integer_zero_node,
12632                                                build_int_2 (elements - 1,
12633                                                             0)));
12634   t = build_decl (VAR_DECL,
12635                   ffecom_get_invented_identifier ("__g77_%s_%d",
12636                                                   commentary,
12637                                                   mynumber++),
12638                   type);
12639
12640   t = start_decl (t, FALSE);
12641   finish_decl (t, NULL_TREE, FALSE);
12642
12643   return t;
12644 }
12645 #endif
12646
12647 /* Prepare argument pointer to expression.
12648
12649    Like ffecom_prepare_expr, except for expressions to be evaluated
12650    via ffecom_arg_ptr_to_expr.  */
12651
12652 void
12653 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12654 {
12655   /* ~~For now, it seems to be the same thing.  */
12656   ffecom_prepare_expr (expr);
12657   return;
12658 }
12659
12660 /* End of preparations.  */
12661
12662 bool
12663 ffecom_prepare_end (void)
12664 {
12665   int prep_state = current_binding_level->prep_state;
12666
12667   assert (prep_state < 2);
12668   current_binding_level->prep_state = 2;
12669
12670   return (prep_state == 1) ? TRUE : FALSE;
12671 }
12672
12673 /* Prepare expression.
12674
12675    This is called before any code is generated for the current block.
12676    It scans the expression, declares any temporaries that might be needed
12677    during evaluation of the expression, and stores those temporaries in
12678    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12679    specifies the destination that ffecom_expr_ will see, in case that
12680    helps avoid generating unused temporaries.
12681
12682    ~~Improve to avoid allocating unused temporaries by taking `dest'
12683    into account vis-a-vis aliasing requirements of complex/character
12684    functions.  */
12685
12686 void
12687 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12688 {
12689   ffeinfoBasictype bt;
12690   ffeinfoKindtype kt;
12691   ffetargetCharacterSize sz;
12692   tree tempvar = NULL_TREE;
12693
12694   assert (current_binding_level->prep_state < 2);
12695
12696   if (! expr)
12697     return;
12698
12699   bt = ffeinfo_basictype (ffebld_info (expr));
12700   kt = ffeinfo_kindtype (ffebld_info (expr));
12701   sz = ffeinfo_size (ffebld_info (expr));
12702
12703   /* Generate whatever temporaries are needed to represent the result
12704      of the expression.  */
12705
12706   if (bt == FFEINFO_basictypeCHARACTER)
12707     {
12708       while (ffebld_op (expr) == FFEBLD_opPAREN)
12709         expr = ffebld_left (expr);
12710     }
12711
12712   switch (ffebld_op (expr))
12713     {
12714     default:
12715       /* Don't make temps for SYMTER, CONTER, etc.  */
12716       if (ffebld_arity (expr) == 0)
12717         break;
12718
12719       switch (bt)
12720         {
12721         case FFEINFO_basictypeCOMPLEX:
12722           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12723             {
12724               ffesymbol s;
12725
12726               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12727                 break;
12728
12729               s = ffebld_symter (ffebld_left (expr));
12730               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12731                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12732                       && ! ffesymbol_is_f2c (s))
12733                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12734                       && ! ffe_is_f2c_library ()))
12735                 break;
12736             }
12737           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12738             {
12739               /* Requires special treatment.  There's no POW_CC function
12740                  in libg2c, so POW_ZZ is used, which means we always
12741                  need a double-complex temp, not a single-complex.  */
12742               kt = FFEINFO_kindtypeREAL2;
12743             }
12744           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12745             /* The other ops don't need temps for complex operands.  */
12746             break;
12747
12748           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12749              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12750           tempvar = ffecom_make_tempvar ("complex",
12751                                          ffecom_tree_type
12752                                          [FFEINFO_basictypeCOMPLEX][kt],
12753                                          FFETARGET_charactersizeNONE,
12754                                          -1);
12755           break;
12756
12757         case FFEINFO_basictypeCHARACTER:
12758           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12759             break;
12760
12761           if (sz == FFETARGET_charactersizeNONE)
12762             /* ~~Kludge alert!  This should someday be fixed. */
12763             sz = 24;
12764
12765           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12766           break;
12767
12768         default:
12769           break;
12770         }
12771       break;
12772
12773 #ifdef HAHA
12774     case FFEBLD_opPOWER:
12775       {
12776         tree rtype, ltype;
12777         tree rtmp, ltmp, result;
12778
12779         ltype = ffecom_type_expr (ffebld_left (expr));
12780         rtype = ffecom_type_expr (ffebld_right (expr));
12781
12782         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12783         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12784         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12785
12786         tempvar = make_tree_vec (3);
12787         TREE_VEC_ELT (tempvar, 0) = rtmp;
12788         TREE_VEC_ELT (tempvar, 1) = ltmp;
12789         TREE_VEC_ELT (tempvar, 2) = result;
12790       }
12791       break;
12792 #endif  /* HAHA */
12793
12794     case FFEBLD_opCONCATENATE:
12795       {
12796         /* This gets special handling, because only one set of temps
12797            is needed for a tree of these -- the tree is treated as
12798            a flattened list of concatenations when generating code.  */
12799
12800         ffecomConcatList_ catlist;
12801         tree ltmp, itmp, result;
12802         int count;
12803         int i;
12804
12805         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12806         count = ffecom_concat_list_count_ (catlist);
12807
12808         if (count >= 2)
12809           {
12810             ltmp
12811               = ffecom_make_tempvar ("concat_len",
12812                                      ffecom_f2c_ftnlen_type_node,
12813                                      FFETARGET_charactersizeNONE, count);
12814             itmp
12815               = ffecom_make_tempvar ("concat_item",
12816                                      ffecom_f2c_address_type_node,
12817                                      FFETARGET_charactersizeNONE, count);
12818             result
12819               = ffecom_make_tempvar ("concat_res",
12820                                      char_type_node,
12821                                      ffecom_concat_list_maxlen_ (catlist),
12822                                      -1);
12823
12824             tempvar = make_tree_vec (3);
12825             TREE_VEC_ELT (tempvar, 0) = ltmp;
12826             TREE_VEC_ELT (tempvar, 1) = itmp;
12827             TREE_VEC_ELT (tempvar, 2) = result;
12828           }
12829
12830         for (i = 0; i < count; ++i)
12831           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12832                                                                     i));
12833
12834         ffecom_concat_list_kill_ (catlist);
12835
12836         if (tempvar)
12837           {
12838             ffebld_nonter_set_hook (expr, tempvar);
12839             current_binding_level->prep_state = 1;
12840           }
12841       }
12842       return;
12843
12844     case FFEBLD_opCONVERT:
12845       if (bt == FFEINFO_basictypeCHARACTER
12846           && ((ffebld_size_known (ffebld_left (expr))
12847                == FFETARGET_charactersizeNONE)
12848               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12849         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12850       break;
12851     }
12852
12853   if (tempvar)
12854     {
12855       ffebld_nonter_set_hook (expr, tempvar);
12856       current_binding_level->prep_state = 1;
12857     }
12858
12859   /* Prepare subexpressions for this expr.  */
12860
12861   switch (ffebld_op (expr))
12862     {
12863     case FFEBLD_opPERCENT_LOC:
12864       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12865       break;
12866
12867     case FFEBLD_opPERCENT_VAL:
12868     case FFEBLD_opPERCENT_REF:
12869       ffecom_prepare_expr (ffebld_left (expr));
12870       break;
12871
12872     case FFEBLD_opPERCENT_DESCR:
12873       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12874       break;
12875
12876     case FFEBLD_opITEM:
12877       {
12878         ffebld item;
12879
12880         for (item = expr;
12881              item != NULL;
12882              item = ffebld_trail (item))
12883           if (ffebld_head (item) != NULL)
12884             ffecom_prepare_expr (ffebld_head (item));
12885       }
12886       break;
12887
12888     default:
12889       /* Need to handle character conversion specially.  */
12890       switch (ffebld_arity (expr))
12891         {
12892         case 2:
12893           ffecom_prepare_expr (ffebld_left (expr));
12894           ffecom_prepare_expr (ffebld_right (expr));
12895           break;
12896
12897         case 1:
12898           ffecom_prepare_expr (ffebld_left (expr));
12899           break;
12900
12901         default:
12902           break;
12903         }
12904     }
12905
12906   return;
12907 }
12908
12909 /* Prepare expression for reading and writing.
12910
12911    Like ffecom_prepare_expr, except for expressions to be evaluated
12912    via ffecom_expr_rw.  */
12913
12914 void
12915 ffecom_prepare_expr_rw (tree type, ffebld expr)
12916 {
12917   /* This is all we support for now.  */
12918   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12919
12920   /* ~~For now, it seems to be the same thing.  */
12921   ffecom_prepare_expr (expr);
12922   return;
12923 }
12924
12925 /* Prepare expression for writing.
12926
12927    Like ffecom_prepare_expr, except for expressions to be evaluated
12928    via ffecom_expr_w.  */
12929
12930 void
12931 ffecom_prepare_expr_w (tree type, ffebld expr)
12932 {
12933   /* This is all we support for now.  */
12934   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12935
12936   /* ~~For now, it seems to be the same thing.  */
12937   ffecom_prepare_expr (expr);
12938   return;
12939 }
12940
12941 /* Prepare expression for returning.
12942
12943    Like ffecom_prepare_expr, except for expressions to be evaluated
12944    via ffecom_return_expr.  */
12945
12946 void
12947 ffecom_prepare_return_expr (ffebld expr)
12948 {
12949   assert (current_binding_level->prep_state < 2);
12950
12951   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12952       && ffecom_is_altreturning_
12953       && expr != NULL)
12954     ffecom_prepare_expr (expr);
12955 }
12956
12957 /* Prepare pointer to expression.
12958
12959    Like ffecom_prepare_expr, except for expressions to be evaluated
12960    via ffecom_ptr_to_expr.  */
12961
12962 void
12963 ffecom_prepare_ptr_to_expr (ffebld expr)
12964 {
12965   /* ~~For now, it seems to be the same thing.  */
12966   ffecom_prepare_expr (expr);
12967   return;
12968 }
12969
12970 /* Transform expression into constant pointer-to-expression tree.
12971
12972    If the expression can be transformed into a pointer-to-expression tree
12973    that is constant, that is done, and the tree returned.  Else NULL_TREE
12974    is returned.
12975
12976    That way, a caller can attempt to provide compile-time initialization
12977    of a variable and, if that fails, *then* choose to start a new block
12978    and resort to using temporaries, as appropriate.  */
12979
12980 tree
12981 ffecom_ptr_to_const_expr (ffebld expr)
12982 {
12983   if (! expr)
12984     return integer_zero_node;
12985
12986   if (ffebld_op (expr) == FFEBLD_opANY)
12987     return error_mark_node;
12988
12989   if (ffebld_arity (expr) == 0
12990       && (ffebld_op (expr) != FFEBLD_opSYMTER
12991           || ffebld_where (expr) == FFEINFO_whereCOMMON
12992           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12993           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12994     {
12995       tree t;
12996
12997       t = ffecom_ptr_to_expr (expr);
12998       assert (TREE_CONSTANT (t));
12999       return t;
13000     }
13001
13002   return NULL_TREE;
13003 }
13004
13005 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13006
13007    tree rtn;  // NULL_TREE means use expand_null_return()
13008    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13009    rtn = ffecom_return_expr(expr);
13010
13011    Based on the program unit type and other info (like return function
13012    type, return master function type when alternate ENTRY points,
13013    whether subroutine has any alternate RETURN points, etc), returns the
13014    appropriate expression to be returned to the caller, or NULL_TREE
13015    meaning no return value or the caller expects it to be returned somewhere
13016    else (which is handled by other parts of this module).  */
13017
13018 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13019 tree
13020 ffecom_return_expr (ffebld expr)
13021 {
13022   tree rtn;
13023
13024   switch (ffecom_primary_entry_kind_)
13025     {
13026     case FFEINFO_kindPROGRAM:
13027     case FFEINFO_kindBLOCKDATA:
13028       rtn = NULL_TREE;
13029       break;
13030
13031     case FFEINFO_kindSUBROUTINE:
13032       if (!ffecom_is_altreturning_)
13033         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13034       else if (expr == NULL)
13035         rtn = integer_zero_node;
13036       else
13037         rtn = ffecom_expr (expr);
13038       break;
13039
13040     case FFEINFO_kindFUNCTION:
13041       if ((ffecom_multi_retval_ != NULL_TREE)
13042           || (ffesymbol_basictype (ffecom_primary_entry_)
13043               == FFEINFO_basictypeCHARACTER)
13044           || ((ffesymbol_basictype (ffecom_primary_entry_)
13045                == FFEINFO_basictypeCOMPLEX)
13046               && (ffecom_num_entrypoints_ == 0)
13047               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13048         {                       /* Value is returned by direct assignment
13049                                    into (implicit) dummy. */
13050           rtn = NULL_TREE;
13051           break;
13052         }
13053       rtn = ffecom_func_result_;
13054 #if 0
13055       /* Spurious error if RETURN happens before first reference!  So elide
13056          this code.  In particular, for debugging registry, rtn should always
13057          be non-null after all, but TREE_USED won't be set until we encounter
13058          a reference in the code.  Perfectly okay (but weird) code that,
13059          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13060          this diagnostic for no reason.  Have people use -O -Wuninitialized
13061          and leave it to the back end to find obviously weird cases.  */
13062
13063       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13064          situation; if the return value has never been referenced, it won't
13065          have a tree under 2pass mode. */
13066       if ((rtn == NULL_TREE)
13067           || !TREE_USED (rtn))
13068         {
13069           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13070           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13071                        ffesymbol_where_column (ffecom_primary_entry_));
13072           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13073                                          (ffecom_primary_entry_)));
13074           ffebad_finish ();
13075         }
13076 #endif
13077       break;
13078
13079     default:
13080       assert ("bad unit kind" == NULL);
13081     case FFEINFO_kindANY:
13082       rtn = error_mark_node;
13083       break;
13084     }
13085
13086   return rtn;
13087 }
13088
13089 #endif
13090 /* Do save_expr only if tree is not error_mark_node.  */
13091
13092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13093 tree
13094 ffecom_save_tree (tree t)
13095 {
13096   return save_expr (t);
13097 }
13098 #endif
13099
13100 /* Start a compound statement (block).  */
13101
13102 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13103 void
13104 ffecom_start_compstmt (void)
13105 {
13106   bison_rule_pushlevel_ ();
13107 }
13108 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13109
13110 /* Public entry point for front end to access start_decl.  */
13111
13112 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13113 tree
13114 ffecom_start_decl (tree decl, bool is_initialized)
13115 {
13116   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13117   return start_decl (decl, FALSE);
13118 }
13119
13120 #endif
13121 /* ffecom_sym_commit -- Symbol's state being committed to reality
13122
13123    ffesymbol s;
13124    ffecom_sym_commit(s);
13125
13126    Does whatever the backend needs when a symbol is committed after having
13127    been backtrackable for a period of time.  */
13128
13129 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13130 void
13131 ffecom_sym_commit (ffesymbol s UNUSED)
13132 {
13133   assert (!ffesymbol_retractable ());
13134 }
13135
13136 #endif
13137 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13138
13139    ffecom_sym_end_transition();
13140
13141    Does backend-specific stuff and also calls ffest_sym_end_transition
13142    to do the necessary FFE stuff.
13143
13144    Backtracking is never enabled when this fn is called, so don't worry
13145    about it.  */
13146
13147 ffesymbol
13148 ffecom_sym_end_transition (ffesymbol s)
13149 {
13150   ffestorag st;
13151
13152   assert (!ffesymbol_retractable ());
13153
13154   s = ffest_sym_end_transition (s);
13155
13156 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13157   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13158       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13159     {
13160       ffecom_list_blockdata_
13161         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13162                                               FFEINTRIN_specNONE,
13163                                               FFEINTRIN_impNONE),
13164                            ffecom_list_blockdata_);
13165     }
13166 #endif
13167
13168   /* This is where we finally notice that a symbol has partial initialization
13169      and finalize it. */
13170
13171   if (ffesymbol_accretion (s) != NULL)
13172     {
13173       assert (ffesymbol_init (s) == NULL);
13174       ffecom_notify_init_symbol (s);
13175     }
13176   else if (((st = ffesymbol_storage (s)) != NULL)
13177            && ((st = ffestorag_parent (st)) != NULL)
13178            && (ffestorag_accretion (st) != NULL))
13179     {
13180       assert (ffestorag_init (st) == NULL);
13181       ffecom_notify_init_storage (st);
13182     }
13183
13184 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13185   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13186       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13187       && (ffesymbol_storage (s) != NULL))
13188     {
13189       ffecom_list_common_
13190         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13191                                               FFEINTRIN_specNONE,
13192                                               FFEINTRIN_impNONE),
13193                            ffecom_list_common_);
13194     }
13195 #endif
13196
13197   return s;
13198 }
13199
13200 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13201
13202    ffecom_sym_exec_transition();
13203
13204    Does backend-specific stuff and also calls ffest_sym_exec_transition
13205    to do the necessary FFE stuff.
13206
13207    See the long-winded description in ffecom_sym_learned for info
13208    on handling the situation where backtracking is inhibited.  */
13209
13210 ffesymbol
13211 ffecom_sym_exec_transition (ffesymbol s)
13212 {
13213   s = ffest_sym_exec_transition (s);
13214
13215   return s;
13216 }
13217
13218 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13219
13220    ffesymbol s;
13221    s = ffecom_sym_learned(s);
13222
13223    Called when a new symbol is seen after the exec transition or when more
13224    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13225    it arrives here is that all its latest info is updated already, so its
13226    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13227    field filled in if its gone through here or exec_transition first, and
13228    so on.
13229
13230    The backend probably wants to check ffesymbol_retractable() to see if
13231    backtracking is in effect.  If so, the FFE's changes to the symbol may
13232    be retracted (undone) or committed (ratified), at which time the
13233    appropriate ffecom_sym_retract or _commit function will be called
13234    for that function.
13235
13236    If the backend has its own backtracking mechanism, great, use it so that
13237    committal is a simple operation.  Though it doesn't make much difference,
13238    I suppose: the reason for tentative symbol evolution in the FFE is to
13239    enable error detection in weird incorrect statements early and to disable
13240    incorrect error detection on a correct statement.  The backend is not
13241    likely to introduce any information that'll get involved in these
13242    considerations, so it is probably just fine that the implementation
13243    model for this fn and for _exec_transition is to not do anything
13244    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13245    and instead wait until ffecom_sym_commit is called (which it never
13246    will be as long as we're using ambiguity-detecting statement analysis in
13247    the FFE, which we are initially to shake out the code, but don't depend
13248    on this), otherwise go ahead and do whatever is needed.
13249
13250    In essence, then, when this fn and _exec_transition get called while
13251    backtracking is enabled, a general mechanism would be to flag which (or
13252    both) of these were called (and in what order? neat question as to what
13253    might happen that I'm too lame to think through right now) and then when
13254    _commit is called reproduce the original calling sequence, if any, for
13255    the two fns (at which point backtracking will, of course, be disabled).  */
13256
13257 ffesymbol
13258 ffecom_sym_learned (ffesymbol s)
13259 {
13260   ffestorag_exec_layout (s);
13261
13262   return s;
13263 }
13264
13265 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13266
13267    ffesymbol s;
13268    ffecom_sym_retract(s);
13269
13270    Does whatever the backend needs when a symbol is retracted after having
13271    been backtrackable for a period of time.  */
13272
13273 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13274 void
13275 ffecom_sym_retract (ffesymbol s UNUSED)
13276 {
13277   assert (!ffesymbol_retractable ());
13278
13279 #if 0                           /* GCC doesn't commit any backtrackable sins,
13280                                    so nothing needed here. */
13281   switch (ffesymbol_hook (s).state)
13282     {
13283     case 0:                     /* nothing happened yet. */
13284       break;
13285
13286     case 1:                     /* exec transition happened. */
13287       break;
13288
13289     case 2:                     /* learned happened. */
13290       break;
13291
13292     case 3:                     /* learned then exec. */
13293       break;
13294
13295     case 4:                     /* exec then learned. */
13296       break;
13297
13298     default:
13299       assert ("bad hook state" == NULL);
13300       break;
13301     }
13302 #endif
13303 }
13304
13305 #endif
13306 /* Create temporary gcc label.  */
13307
13308 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13309 tree
13310 ffecom_temp_label ()
13311 {
13312   tree glabel;
13313   static int mynumber = 0;
13314
13315   glabel = build_decl (LABEL_DECL,
13316                        ffecom_get_invented_identifier ("__g77_label_%d",
13317                                                        mynumber++),
13318                        void_type_node);
13319   DECL_CONTEXT (glabel) = current_function_decl;
13320   DECL_MODE (glabel) = VOIDmode;
13321
13322   return glabel;
13323 }
13324
13325 #endif
13326 /* Return an expression that is usable as an arg in a conditional context
13327    (IF, DO WHILE, .NOT., and so on).
13328
13329    Use the one provided for the back end as of >2.6.0.  */
13330
13331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13332 tree
13333 ffecom_truth_value (tree expr)
13334 {
13335   return truthvalue_conversion (expr);
13336 }
13337
13338 #endif
13339 /* Return the inversion of a truth value (the inversion of what
13340    ffecom_truth_value builds).
13341
13342    Apparently invert_truthvalue, which is properly in the back end, is
13343    enough for now, so just use it.  */
13344
13345 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13346 tree
13347 ffecom_truth_value_invert (tree expr)
13348 {
13349   return invert_truthvalue (ffecom_truth_value (expr));
13350 }
13351
13352 #endif
13353
13354 /* Return the tree that is the type of the expression, as would be
13355    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13356    transforming the expression, generating temporaries, etc.  */
13357
13358 tree
13359 ffecom_type_expr (ffebld expr)
13360 {
13361   ffeinfoBasictype bt;
13362   ffeinfoKindtype kt;
13363   tree tree_type;
13364
13365   assert (expr != NULL);
13366
13367   bt = ffeinfo_basictype (ffebld_info (expr));
13368   kt = ffeinfo_kindtype (ffebld_info (expr));
13369   tree_type = ffecom_tree_type[bt][kt];
13370
13371   switch (ffebld_op (expr))
13372     {
13373     case FFEBLD_opCONTER:
13374     case FFEBLD_opSYMTER:
13375     case FFEBLD_opARRAYREF:
13376     case FFEBLD_opUPLUS:
13377     case FFEBLD_opPAREN:
13378     case FFEBLD_opUMINUS:
13379     case FFEBLD_opADD:
13380     case FFEBLD_opSUBTRACT:
13381     case FFEBLD_opMULTIPLY:
13382     case FFEBLD_opDIVIDE:
13383     case FFEBLD_opPOWER:
13384     case FFEBLD_opNOT:
13385     case FFEBLD_opFUNCREF:
13386     case FFEBLD_opSUBRREF:
13387     case FFEBLD_opAND:
13388     case FFEBLD_opOR:
13389     case FFEBLD_opXOR:
13390     case FFEBLD_opNEQV:
13391     case FFEBLD_opEQV:
13392     case FFEBLD_opCONVERT:
13393     case FFEBLD_opLT:
13394     case FFEBLD_opLE:
13395     case FFEBLD_opEQ:
13396     case FFEBLD_opNE:
13397     case FFEBLD_opGT:
13398     case FFEBLD_opGE:
13399     case FFEBLD_opPERCENT_LOC:
13400       return tree_type;
13401
13402     case FFEBLD_opACCTER:
13403     case FFEBLD_opARRTER:
13404     case FFEBLD_opITEM:
13405     case FFEBLD_opSTAR:
13406     case FFEBLD_opBOUNDS:
13407     case FFEBLD_opREPEAT:
13408     case FFEBLD_opLABTER:
13409     case FFEBLD_opLABTOK:
13410     case FFEBLD_opIMPDO:
13411     case FFEBLD_opCONCATENATE:
13412     case FFEBLD_opSUBSTR:
13413     default:
13414       assert ("bad op for ffecom_type_expr" == NULL);
13415       /* Fall through. */
13416     case FFEBLD_opANY:
13417       return error_mark_node;
13418     }
13419 }
13420
13421 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13422
13423    If the PARM_DECL already exists, return it, else create it.  It's an
13424    integer_type_node argument for the master function that implements a
13425    subroutine or function with more than one entrypoint and is bound at
13426    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13427    first ENTRY statement, and so on).  */
13428
13429 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13430 tree
13431 ffecom_which_entrypoint_decl ()
13432 {
13433   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13434
13435   return ffecom_which_entrypoint_decl_;
13436 }
13437
13438 #endif
13439 \f
13440 /* The following sections consists of private and public functions
13441    that have the same names and perform roughly the same functions
13442    as counterparts in the C front end.  Changes in the C front end
13443    might affect how things should be done here.  Only functions
13444    needed by the back end should be public here; the rest should
13445    be private (static in the C sense).  Functions needed by other
13446    g77 front-end modules should be accessed by them via public
13447    ffecom_* names, which should themselves call private versions
13448    in this section so the private versions are easy to recognize
13449    when upgrading to a new gcc and finding interesting changes
13450    in the front end.
13451
13452    Functions named after rule "foo:" in c-parse.y are named
13453    "bison_rule_foo_" so they are easy to find.  */
13454
13455 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13456
13457 static void
13458 bison_rule_pushlevel_ ()
13459 {
13460   emit_line_note (input_filename, lineno);
13461   pushlevel (0);
13462   clear_last_expr ();
13463   expand_start_bindings (0);
13464 }
13465
13466 static tree
13467 bison_rule_compstmt_ ()
13468 {
13469   tree t;
13470   int keep = kept_level_p ();
13471
13472   /* Make the temps go away.  */
13473   if (! keep)
13474     current_binding_level->names = NULL_TREE;
13475
13476   emit_line_note (input_filename, lineno);
13477   expand_end_bindings (getdecls (), keep, 0);
13478   t = poplevel (keep, 1, 0);
13479
13480   return t;
13481 }
13482
13483 /* Return a definition for a builtin function named NAME and whose data type
13484    is TYPE.  TYPE should be a function type with argument types.
13485    FUNCTION_CODE tells later passes how to compile calls to this function.
13486    See tree.h for its possible values.
13487
13488    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13489    the name to be called if we can't opencode the function.  */
13490
13491 tree
13492 builtin_function (const char *name, tree type, int function_code,
13493                   enum built_in_class class,
13494                   const char *library_name)
13495 {
13496   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13497   DECL_EXTERNAL (decl) = 1;
13498   TREE_PUBLIC (decl) = 1;
13499   if (library_name)
13500     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13501   make_decl_rtl (decl, NULL_PTR);
13502   pushdecl (decl);
13503   DECL_BUILT_IN_CLASS (decl) = class;
13504   DECL_FUNCTION_CODE (decl) = function_code;
13505
13506   return decl;
13507 }
13508
13509 /* Handle when a new declaration NEWDECL
13510    has the same name as an old one OLDDECL
13511    in the same binding contour.
13512    Prints an error message if appropriate.
13513
13514    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13515    Otherwise, return 0.  */
13516
13517 static int
13518 duplicate_decls (tree newdecl, tree olddecl)
13519 {
13520   int types_match = 1;
13521   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13522                            && DECL_INITIAL (newdecl) != 0);
13523   tree oldtype = TREE_TYPE (olddecl);
13524   tree newtype = TREE_TYPE (newdecl);
13525
13526   if (olddecl == newdecl)
13527     return 1;
13528
13529   if (TREE_CODE (newtype) == ERROR_MARK
13530       || TREE_CODE (oldtype) == ERROR_MARK)
13531     types_match = 0;
13532
13533   /* New decl is completely inconsistent with the old one =>
13534      tell caller to replace the old one.
13535      This is always an error except in the case of shadowing a builtin.  */
13536   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13537     return 0;
13538
13539   /* For real parm decl following a forward decl,
13540      return 1 so old decl will be reused.  */
13541   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13542       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13543     return 1;
13544
13545   /* The new declaration is the same kind of object as the old one.
13546      The declarations may partially match.  Print warnings if they don't
13547      match enough.  Ultimately, copy most of the information from the new
13548      decl to the old one, and keep using the old one.  */
13549
13550   if (TREE_CODE (olddecl) == FUNCTION_DECL
13551       && DECL_BUILT_IN (olddecl))
13552     {
13553       /* A function declaration for a built-in function.  */
13554       if (!TREE_PUBLIC (newdecl))
13555         return 0;
13556       else if (!types_match)
13557         {
13558           /* Accept the return type of the new declaration if same modes.  */
13559           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13560           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13561
13562           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13563             {
13564               /* Function types may be shared, so we can't just modify
13565                  the return type of olddecl's function type.  */
13566               tree newtype
13567                 = build_function_type (newreturntype,
13568                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13569
13570               types_match = 1;
13571               if (types_match)
13572                 TREE_TYPE (olddecl) = newtype;
13573             }
13574         }
13575       if (!types_match)
13576         return 0;
13577     }
13578   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13579            && DECL_SOURCE_LINE (olddecl) == 0)
13580     {
13581       /* A function declaration for a predeclared function
13582          that isn't actually built in.  */
13583       if (!TREE_PUBLIC (newdecl))
13584         return 0;
13585       else if (!types_match)
13586         {
13587           /* If the types don't match, preserve volatility indication.
13588              Later on, we will discard everything else about the
13589              default declaration.  */
13590           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13591         }
13592     }
13593
13594   /* Copy all the DECL_... slots specified in the new decl
13595      except for any that we copy here from the old type.
13596
13597      Past this point, we don't change OLDTYPE and NEWTYPE
13598      even if we change the types of NEWDECL and OLDDECL.  */
13599
13600   if (types_match)
13601     {
13602       /* Merge the data types specified in the two decls.  */
13603       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13604         TREE_TYPE (newdecl)
13605           = TREE_TYPE (olddecl)
13606             = TREE_TYPE (newdecl);
13607
13608       /* Lay the type out, unless already done.  */
13609       if (oldtype != TREE_TYPE (newdecl))
13610         {
13611           if (TREE_TYPE (newdecl) != error_mark_node)
13612             layout_type (TREE_TYPE (newdecl));
13613           if (TREE_CODE (newdecl) != FUNCTION_DECL
13614               && TREE_CODE (newdecl) != TYPE_DECL
13615               && TREE_CODE (newdecl) != CONST_DECL)
13616             layout_decl (newdecl, 0);
13617         }
13618       else
13619         {
13620           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13621           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13622           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13623           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13624             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13625               {
13626                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13627                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13628               }
13629         }
13630
13631       /* Keep the old rtl since we can safely use it.  */
13632       COPY_DECL_RTL (newdecl, olddecl);
13633
13634       /* Merge the type qualifiers.  */
13635       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13636           && !TREE_THIS_VOLATILE (newdecl))
13637         TREE_THIS_VOLATILE (olddecl) = 0;
13638       if (TREE_READONLY (newdecl))
13639         TREE_READONLY (olddecl) = 1;
13640       if (TREE_THIS_VOLATILE (newdecl))
13641         {
13642           TREE_THIS_VOLATILE (olddecl) = 1;
13643           if (TREE_CODE (newdecl) == VAR_DECL)
13644             make_var_volatile (newdecl);
13645         }
13646
13647       /* Keep source location of definition rather than declaration.
13648          Likewise, keep decl at outer scope.  */
13649       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13650           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13651         {
13652           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13653           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13654
13655           if (DECL_CONTEXT (olddecl) == 0
13656               && TREE_CODE (newdecl) != FUNCTION_DECL)
13657             DECL_CONTEXT (newdecl) = 0;
13658         }
13659
13660       /* Merge the unused-warning information.  */
13661       if (DECL_IN_SYSTEM_HEADER (olddecl))
13662         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13663       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13664         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13665
13666       /* Merge the initialization information.  */
13667       if (DECL_INITIAL (newdecl) == 0)
13668         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13669
13670       /* Merge the section attribute.
13671          We want to issue an error if the sections conflict but that must be
13672          done later in decl_attributes since we are called before attributes
13673          are assigned.  */
13674       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13675         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13676
13677 #if BUILT_FOR_270
13678       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13679         {
13680           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13681           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13682         }
13683 #endif
13684     }
13685   /* If cannot merge, then use the new type and qualifiers,
13686      and don't preserve the old rtl.  */
13687   else
13688     {
13689       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13690       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13691       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13692       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13693     }
13694
13695   /* Merge the storage class information.  */
13696   /* For functions, static overrides non-static.  */
13697   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13698     {
13699       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13700       /* This is since we don't automatically
13701          copy the attributes of NEWDECL into OLDDECL.  */
13702       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13703       /* If this clears `static', clear it in the identifier too.  */
13704       if (! TREE_PUBLIC (olddecl))
13705         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13706     }
13707   if (DECL_EXTERNAL (newdecl))
13708     {
13709       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13710       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13711       /* An extern decl does not override previous storage class.  */
13712       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13713     }
13714   else
13715     {
13716       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13717       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13718     }
13719
13720   /* If either decl says `inline', this fn is inline,
13721      unless its definition was passed already.  */
13722   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13723     DECL_INLINE (olddecl) = 1;
13724   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13725
13726   /* Get rid of any built-in function if new arg types don't match it
13727      or if we have a function definition.  */
13728   if (TREE_CODE (newdecl) == FUNCTION_DECL
13729       && DECL_BUILT_IN (olddecl)
13730       && (!types_match || new_is_definition))
13731     {
13732       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13733       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13734     }
13735
13736   /* If redeclaring a builtin function, and not a definition,
13737      it stays built in.
13738      Also preserve various other info from the definition.  */
13739   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13740     {
13741       if (DECL_BUILT_IN (olddecl))
13742         {
13743           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13744           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13745         }
13746
13747       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13748       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13749       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13750       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13751     }
13752
13753   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13754      But preserve olddecl's DECL_UID.  */
13755   {
13756     register unsigned olddecl_uid = DECL_UID (olddecl);
13757
13758     memcpy ((char *) olddecl + sizeof (struct tree_common),
13759             (char *) newdecl + sizeof (struct tree_common),
13760             sizeof (struct tree_decl) - sizeof (struct tree_common));
13761     DECL_UID (olddecl) = olddecl_uid;
13762   }
13763
13764   return 1;
13765 }
13766
13767 /* Finish processing of a declaration;
13768    install its initial value.
13769    If the length of an array type is not known before,
13770    it must be determined now, from the initial value, or it is an error.  */
13771
13772 static void
13773 finish_decl (tree decl, tree init, bool is_top_level)
13774 {
13775   register tree type = TREE_TYPE (decl);
13776   int was_incomplete = (DECL_SIZE (decl) == 0);
13777   bool at_top_level = (current_binding_level == global_binding_level);
13778   bool top_level = is_top_level || at_top_level;
13779
13780   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13781      level anyway.  */
13782   assert (!is_top_level || !at_top_level);
13783
13784   if (TREE_CODE (decl) == PARM_DECL)
13785     assert (init == NULL_TREE);
13786   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13787      overlaps DECL_ARG_TYPE.  */
13788   else if (init == NULL_TREE)
13789     assert (DECL_INITIAL (decl) == NULL_TREE);
13790   else
13791     assert (DECL_INITIAL (decl) == error_mark_node);
13792
13793   if (init != NULL_TREE)
13794     {
13795       if (TREE_CODE (decl) != TYPE_DECL)
13796         DECL_INITIAL (decl) = init;
13797       else
13798         {
13799           /* typedef foo = bar; store the type of bar as the type of foo.  */
13800           TREE_TYPE (decl) = TREE_TYPE (init);
13801           DECL_INITIAL (decl) = init = 0;
13802         }
13803     }
13804
13805   /* Deduce size of array from initialization, if not already known */
13806
13807   if (TREE_CODE (type) == ARRAY_TYPE
13808       && TYPE_DOMAIN (type) == 0
13809       && TREE_CODE (decl) != TYPE_DECL)
13810     {
13811       assert (top_level);
13812       assert (was_incomplete);
13813
13814       layout_decl (decl, 0);
13815     }
13816
13817   if (TREE_CODE (decl) == VAR_DECL)
13818     {
13819       if (DECL_SIZE (decl) == NULL_TREE
13820           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13821         layout_decl (decl, 0);
13822
13823       if (DECL_SIZE (decl) == NULL_TREE
13824           && (TREE_STATIC (decl)
13825               ?
13826       /* A static variable with an incomplete type is an error if it is
13827          initialized. Also if it is not file scope. Otherwise, let it
13828          through, but if it is not `extern' then it may cause an error
13829          message later.  */
13830               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13831               :
13832       /* An automatic variable with an incomplete type is an error.  */
13833               !DECL_EXTERNAL (decl)))
13834         {
13835           assert ("storage size not known" == NULL);
13836           abort ();
13837         }
13838
13839       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13840           && (DECL_SIZE (decl) != 0)
13841           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13842         {
13843           assert ("storage size not constant" == NULL);
13844           abort ();
13845         }
13846     }
13847
13848   /* Output the assembler code and/or RTL code for variables and functions,
13849      unless the type is an undefined structure or union. If not, it will get
13850      done when the type is completed.  */
13851
13852   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13853     {
13854       rest_of_decl_compilation (decl, NULL,
13855                                 DECL_CONTEXT (decl) == 0,
13856                                 0);
13857
13858       if (DECL_CONTEXT (decl) != 0)
13859         {
13860           /* Recompute the RTL of a local array now if it used to be an
13861              incomplete type.  */
13862           if (was_incomplete
13863               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13864             {
13865               /* If we used it already as memory, it must stay in memory.  */
13866               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13867               /* If it's still incomplete now, no init will save it.  */
13868               if (DECL_SIZE (decl) == 0)
13869                 DECL_INITIAL (decl) = 0;
13870               expand_decl (decl);
13871             }
13872           /* Compute and store the initial value.  */
13873           if (TREE_CODE (decl) != FUNCTION_DECL)
13874             expand_decl_init (decl);
13875         }
13876     }
13877   else if (TREE_CODE (decl) == TYPE_DECL)
13878     {
13879       rest_of_decl_compilation (decl, NULL_PTR,
13880                                 DECL_CONTEXT (decl) == 0,
13881                                 0);
13882     }
13883
13884   /* At the end of a declaration, throw away any variable type sizes of types
13885      defined inside that declaration.  There is no use computing them in the
13886      following function definition.  */
13887   if (current_binding_level == global_binding_level)
13888     get_pending_sizes ();
13889 }
13890
13891 /* Finish up a function declaration and compile that function
13892    all the way to assembler language output.  The free the storage
13893    for the function definition.
13894
13895    This is called after parsing the body of the function definition.
13896
13897    NESTED is nonzero if the function being finished is nested in another.  */
13898
13899 static void
13900 finish_function (int nested)
13901 {
13902   register tree fndecl = current_function_decl;
13903
13904   assert (fndecl != NULL_TREE);
13905   if (TREE_CODE (fndecl) != ERROR_MARK)
13906     {
13907       if (nested)
13908         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13909       else
13910         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13911     }
13912
13913 /*  TREE_READONLY (fndecl) = 1;
13914     This caused &foo to be of type ptr-to-const-function
13915     which then got a warning when stored in a ptr-to-function variable.  */
13916
13917   poplevel (1, 0, 1);
13918
13919   if (TREE_CODE (fndecl) != ERROR_MARK)
13920     {
13921       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13922
13923       /* Must mark the RESULT_DECL as being in this function.  */
13924
13925       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13926
13927       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13928       /* Generate rtl for function exit.  */
13929       expand_function_end (input_filename, lineno, 0);
13930
13931       /* If this is a nested function, protect the local variables in the stack
13932          above us from being collected while we're compiling this function.  */
13933       if (nested)
13934         ggc_push_context ();
13935
13936       /* Run the optimizers and output the assembler code for this function.  */
13937       rest_of_compilation (fndecl);
13938
13939       /* Undo the GC context switch.  */
13940       if (nested)
13941         ggc_pop_context ();
13942     }
13943
13944   if (TREE_CODE (fndecl) != ERROR_MARK
13945       && !nested
13946       && DECL_SAVED_INSNS (fndecl) == 0)
13947     {
13948       /* Stop pointing to the local nodes about to be freed.  */
13949       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13950          function definition.  */
13951       /* For a nested function, this is done in pop_f_function_context.  */
13952       /* If rest_of_compilation set this to 0, leave it 0.  */
13953       if (DECL_INITIAL (fndecl) != 0)
13954         DECL_INITIAL (fndecl) = error_mark_node;
13955       DECL_ARGUMENTS (fndecl) = 0;
13956     }
13957
13958   if (!nested)
13959     {
13960       /* Let the error reporting routines know that we're outside a function.
13961          For a nested function, this value is used in pop_c_function_context
13962          and then reset via pop_function_context.  */
13963       ffecom_outer_function_decl_ = current_function_decl = NULL;
13964     }
13965 }
13966
13967 /* Plug-in replacement for identifying the name of a decl and, for a
13968    function, what we call it in diagnostics.  For now, "program unit"
13969    should suffice, since it's a bit of a hassle to figure out which
13970    of several kinds of things it is.  Note that it could conceivably
13971    be a statement function, which probably isn't really a program unit
13972    per se, but if that comes up, it should be easy to check (being a
13973    nested function and all).  */
13974
13975 static const char *
13976 lang_printable_name (tree decl, int v)
13977 {
13978   /* Just to keep GCC quiet about the unused variable.
13979      In theory, differing values of V should produce different
13980      output.  */
13981   switch (v)
13982     {
13983     default:
13984       if (TREE_CODE (decl) == ERROR_MARK)
13985         return "erroneous code";
13986       return IDENTIFIER_POINTER (DECL_NAME (decl));
13987     }
13988 }
13989
13990 /* g77's function to print out name of current function that caused
13991    an error.  */
13992
13993 #if BUILT_FOR_270
13994 static void
13995 lang_print_error_function (const char *file)
13996 {
13997   static ffeglobal last_g = NULL;
13998   static ffesymbol last_s = NULL;
13999   ffeglobal g;
14000   ffesymbol s;
14001   const char *kind;
14002
14003   if ((ffecom_primary_entry_ == NULL)
14004       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14005     {
14006       g = NULL;
14007       s = NULL;
14008       kind = NULL;
14009     }
14010   else
14011     {
14012       g = ffesymbol_global (ffecom_primary_entry_);
14013       if (ffecom_nested_entry_ == NULL)
14014         {
14015           s = ffecom_primary_entry_;
14016           switch (ffesymbol_kind (s))
14017             {
14018             case FFEINFO_kindFUNCTION:
14019               kind = "function";
14020               break;
14021
14022             case FFEINFO_kindSUBROUTINE:
14023               kind = "subroutine";
14024               break;
14025
14026             case FFEINFO_kindPROGRAM:
14027               kind = "program";
14028               break;
14029
14030             case FFEINFO_kindBLOCKDATA:
14031               kind = "block-data";
14032               break;
14033
14034             default:
14035               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14036               break;
14037             }
14038         }
14039       else
14040         {
14041           s = ffecom_nested_entry_;
14042           kind = "statement function";
14043         }
14044     }
14045
14046   if ((last_g != g) || (last_s != s))
14047     {
14048       if (file)
14049         fprintf (stderr, "%s: ", file);
14050
14051       if (s == NULL)
14052         fprintf (stderr, "Outside of any program unit:\n");
14053       else
14054         {
14055           const char *name = ffesymbol_text (s);
14056
14057           fprintf (stderr, "In %s `%s':\n", kind, name);
14058         }
14059
14060       last_g = g;
14061       last_s = s;
14062     }
14063 }
14064 #endif
14065
14066 /* Similar to `lookup_name' but look only at current binding level.  */
14067
14068 static tree
14069 lookup_name_current_level (tree name)
14070 {
14071   register tree t;
14072
14073   if (current_binding_level == global_binding_level)
14074     return IDENTIFIER_GLOBAL_VALUE (name);
14075
14076   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14077     return 0;
14078
14079   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14080     if (DECL_NAME (t) == name)
14081       break;
14082
14083   return t;
14084 }
14085
14086 /* Create a new `struct binding_level'.  */
14087
14088 static struct binding_level *
14089 make_binding_level ()
14090 {
14091   /* NOSTRICT */
14092   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14093 }
14094
14095 /* Save and restore the variables in this file and elsewhere
14096    that keep track of the progress of compilation of the current function.
14097    Used for nested functions.  */
14098
14099 struct f_function
14100 {
14101   struct f_function *next;
14102   tree named_labels;
14103   tree shadowed_labels;
14104   struct binding_level *binding_level;
14105 };
14106
14107 struct f_function *f_function_chain;
14108
14109 /* Restore the variables used during compilation of a C function.  */
14110
14111 static void
14112 pop_f_function_context ()
14113 {
14114   struct f_function *p = f_function_chain;
14115   tree link;
14116
14117   /* Bring back all the labels that were shadowed.  */
14118   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14119     if (DECL_NAME (TREE_VALUE (link)) != 0)
14120       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14121         = TREE_VALUE (link);
14122
14123   if (current_function_decl != error_mark_node
14124       && DECL_SAVED_INSNS (current_function_decl) == 0)
14125     {
14126       /* Stop pointing to the local nodes about to be freed.  */
14127       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14128          function definition.  */
14129       DECL_INITIAL (current_function_decl) = error_mark_node;
14130       DECL_ARGUMENTS (current_function_decl) = 0;
14131     }
14132
14133   pop_function_context ();
14134
14135   f_function_chain = p->next;
14136
14137   named_labels = p->named_labels;
14138   shadowed_labels = p->shadowed_labels;
14139   current_binding_level = p->binding_level;
14140
14141   free (p);
14142 }
14143
14144 /* Save and reinitialize the variables
14145    used during compilation of a C function.  */
14146
14147 static void
14148 push_f_function_context ()
14149 {
14150   struct f_function *p
14151   = (struct f_function *) xmalloc (sizeof (struct f_function));
14152
14153   push_function_context ();
14154
14155   p->next = f_function_chain;
14156   f_function_chain = p;
14157
14158   p->named_labels = named_labels;
14159   p->shadowed_labels = shadowed_labels;
14160   p->binding_level = current_binding_level;
14161 }
14162
14163 static void
14164 push_parm_decl (tree parm)
14165 {
14166   int old_immediate_size_expand = immediate_size_expand;
14167
14168   /* Don't try computing parm sizes now -- wait till fn is called.  */
14169
14170   immediate_size_expand = 0;
14171
14172   /* Fill in arg stuff.  */
14173
14174   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14175   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14176   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14177
14178   parm = pushdecl (parm);
14179
14180   immediate_size_expand = old_immediate_size_expand;
14181
14182   finish_decl (parm, NULL_TREE, FALSE);
14183 }
14184
14185 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14186
14187 static tree
14188 pushdecl_top_level (x)
14189      tree x;
14190 {
14191   register tree t;
14192   register struct binding_level *b = current_binding_level;
14193   register tree f = current_function_decl;
14194
14195   current_binding_level = global_binding_level;
14196   current_function_decl = NULL_TREE;
14197   t = pushdecl (x);
14198   current_binding_level = b;
14199   current_function_decl = f;
14200   return t;
14201 }
14202
14203 /* Store the list of declarations of the current level.
14204    This is done for the parameter declarations of a function being defined,
14205    after they are modified in the light of any missing parameters.  */
14206
14207 static tree
14208 storedecls (decls)
14209      tree decls;
14210 {
14211   return current_binding_level->names = decls;
14212 }
14213
14214 /* Store the parameter declarations into the current function declaration.
14215    This is called after parsing the parameter declarations, before
14216    digesting the body of the function.
14217
14218    For an old-style definition, modify the function's type
14219    to specify at least the number of arguments.  */
14220
14221 static void
14222 store_parm_decls (int is_main_program UNUSED)
14223 {
14224   register tree fndecl = current_function_decl;
14225
14226   if (fndecl == error_mark_node)
14227     return;
14228
14229   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14230   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14231
14232   /* Initialize the RTL code for the function.  */
14233
14234   init_function_start (fndecl, input_filename, lineno);
14235
14236   /* Set up parameters and prepare for return, for the function.  */
14237
14238   expand_function_start (fndecl, 0);
14239 }
14240
14241 static tree
14242 start_decl (tree decl, bool is_top_level)
14243 {
14244   register tree tem;
14245   bool at_top_level = (current_binding_level == global_binding_level);
14246   bool top_level = is_top_level || at_top_level;
14247
14248   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14249      level anyway.  */
14250   assert (!is_top_level || !at_top_level);
14251
14252   if (DECL_INITIAL (decl) != NULL_TREE)
14253     {
14254       assert (DECL_INITIAL (decl) == error_mark_node);
14255       assert (!DECL_EXTERNAL (decl));
14256     }
14257   else if (top_level)
14258     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14259
14260   /* For Fortran, we by default put things in .common when possible.  */
14261   DECL_COMMON (decl) = 1;
14262
14263   /* Add this decl to the current binding level. TEM may equal DECL or it may
14264      be a previous decl of the same name.  */
14265   if (is_top_level)
14266     tem = pushdecl_top_level (decl);
14267   else
14268     tem = pushdecl (decl);
14269
14270   /* For a local variable, define the RTL now.  */
14271   if (!top_level
14272   /* But not if this is a duplicate decl and we preserved the rtl from the
14273      previous one (which may or may not happen).  */
14274       && !DECL_RTL_SET_P (tem))
14275     {
14276       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14277         expand_decl (tem);
14278       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14279                && DECL_INITIAL (tem) != 0)
14280         expand_decl (tem);
14281     }
14282
14283   return tem;
14284 }
14285
14286 /* Create the FUNCTION_DECL for a function definition.
14287    DECLSPECS and DECLARATOR are the parts of the declaration;
14288    they describe the function's name and the type it returns,
14289    but twisted together in a fashion that parallels the syntax of C.
14290
14291    This function creates a binding context for the function body
14292    as well as setting up the FUNCTION_DECL in current_function_decl.
14293
14294    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14295    (it defines a datum instead), we return 0, which tells
14296    yyparse to report a parse error.
14297
14298    NESTED is nonzero for a function nested within another function.  */
14299
14300 static void
14301 start_function (tree name, tree type, int nested, int public)
14302 {
14303   tree decl1;
14304   tree restype;
14305   int old_immediate_size_expand = immediate_size_expand;
14306
14307   named_labels = 0;
14308   shadowed_labels = 0;
14309
14310   /* Don't expand any sizes in the return type of the function.  */
14311   immediate_size_expand = 0;
14312
14313   if (nested)
14314     {
14315       assert (!public);
14316       assert (current_function_decl != NULL_TREE);
14317       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14318     }
14319   else
14320     {
14321       assert (current_function_decl == NULL_TREE);
14322     }
14323
14324   if (TREE_CODE (type) == ERROR_MARK)
14325     decl1 = current_function_decl = error_mark_node;
14326   else
14327     {
14328       decl1 = build_decl (FUNCTION_DECL,
14329                           name,
14330                           type);
14331       TREE_PUBLIC (decl1) = public ? 1 : 0;
14332       if (nested)
14333         DECL_INLINE (decl1) = 1;
14334       TREE_STATIC (decl1) = 1;
14335       DECL_EXTERNAL (decl1) = 0;
14336
14337       announce_function (decl1);
14338
14339       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14340          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14341       DECL_INITIAL (decl1) = error_mark_node;
14342
14343       /* Record the decl so that the function name is defined. If we already have
14344          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14345
14346       current_function_decl = pushdecl (decl1);
14347     }
14348
14349   if (!nested)
14350     ffecom_outer_function_decl_ = current_function_decl;
14351
14352   pushlevel (0);
14353   current_binding_level->prep_state = 2;
14354
14355   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14356     {
14357       make_decl_rtl (current_function_decl, NULL);
14358
14359       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14360       DECL_RESULT (current_function_decl)
14361         = build_decl (RESULT_DECL, NULL_TREE, restype);
14362     }
14363
14364   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14365     TREE_ADDRESSABLE (current_function_decl) = 1;
14366
14367   immediate_size_expand = old_immediate_size_expand;
14368 }
14369 \f
14370 /* Here are the public functions the GNU back end needs.  */
14371
14372 tree
14373 convert (type, expr)
14374      tree type, expr;
14375 {
14376   register tree e = expr;
14377   register enum tree_code code = TREE_CODE (type);
14378
14379   if (type == TREE_TYPE (e)
14380       || TREE_CODE (e) == ERROR_MARK)
14381     return e;
14382   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14383     return fold (build1 (NOP_EXPR, type, e));
14384   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14385       || code == ERROR_MARK)
14386     return error_mark_node;
14387   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14388     {
14389       assert ("void value not ignored as it ought to be" == NULL);
14390       return error_mark_node;
14391     }
14392   if (code == VOID_TYPE)
14393     return build1 (CONVERT_EXPR, type, e);
14394   if ((code != RECORD_TYPE)
14395       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14396     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14397                   e);
14398   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14399     return fold (convert_to_integer (type, e));
14400   if (code == POINTER_TYPE)
14401     return fold (convert_to_pointer (type, e));
14402   if (code == REAL_TYPE)
14403     return fold (convert_to_real (type, e));
14404   if (code == COMPLEX_TYPE)
14405     return fold (convert_to_complex (type, e));
14406   if (code == RECORD_TYPE)
14407     return fold (ffecom_convert_to_complex_ (type, e));
14408
14409   assert ("conversion to non-scalar type requested" == NULL);
14410   return error_mark_node;
14411 }
14412
14413 /* integrate_decl_tree calls this function, but since we don't use the
14414    DECL_LANG_SPECIFIC field, this is a no-op.  */
14415
14416 void
14417 copy_lang_decl (node)
14418      tree node UNUSED;
14419 {
14420 }
14421
14422 /* Return the list of declarations of the current level.
14423    Note that this list is in reverse order unless/until
14424    you nreverse it; and when you do nreverse it, you must
14425    store the result back using `storedecls' or you will lose.  */
14426
14427 tree
14428 getdecls ()
14429 {
14430   return current_binding_level->names;
14431 }
14432
14433 /* Nonzero if we are currently in the global binding level.  */
14434
14435 int
14436 global_bindings_p ()
14437 {
14438   return current_binding_level == global_binding_level;
14439 }
14440
14441 /* Print an error message for invalid use of an incomplete type.
14442    VALUE is the expression that was used (or 0 if that isn't known)
14443    and TYPE is the type that was invalid.  */
14444
14445 void
14446 incomplete_type_error (value, type)
14447      tree value UNUSED;
14448      tree type;
14449 {
14450   if (TREE_CODE (type) == ERROR_MARK)
14451     return;
14452
14453   assert ("incomplete type?!?" == NULL);
14454 }
14455
14456 /* Mark ARG for GC.  */
14457 static void
14458 mark_binding_level (void *arg)
14459 {
14460   struct binding_level *level = *(struct binding_level **) arg;
14461
14462   while (level)
14463     {
14464       ggc_mark_tree (level->names);
14465       ggc_mark_tree (level->blocks);
14466       ggc_mark_tree (level->this_block);
14467       level = level->level_chain;
14468     }
14469 }
14470
14471 void
14472 init_decl_processing ()
14473 {
14474   static tree *const tree_roots[] = {
14475     &current_function_decl,
14476     &string_type_node,
14477     &ffecom_tree_fun_type_void,
14478     &ffecom_integer_zero_node,
14479     &ffecom_integer_one_node,
14480     &ffecom_tree_subr_type,
14481     &ffecom_tree_ptr_to_subr_type,
14482     &ffecom_tree_blockdata_type,
14483     &ffecom_tree_xargc_,
14484     &ffecom_f2c_integer_type_node,
14485     &ffecom_f2c_ptr_to_integer_type_node,
14486     &ffecom_f2c_address_type_node,
14487     &ffecom_f2c_real_type_node,
14488     &ffecom_f2c_ptr_to_real_type_node,
14489     &ffecom_f2c_doublereal_type_node,
14490     &ffecom_f2c_complex_type_node,
14491     &ffecom_f2c_doublecomplex_type_node,
14492     &ffecom_f2c_longint_type_node,
14493     &ffecom_f2c_logical_type_node,
14494     &ffecom_f2c_flag_type_node,
14495     &ffecom_f2c_ftnlen_type_node,
14496     &ffecom_f2c_ftnlen_zero_node,
14497     &ffecom_f2c_ftnlen_one_node,
14498     &ffecom_f2c_ftnlen_two_node,
14499     &ffecom_f2c_ptr_to_ftnlen_type_node,
14500     &ffecom_f2c_ftnint_type_node,
14501     &ffecom_f2c_ptr_to_ftnint_type_node,
14502     &ffecom_outer_function_decl_,
14503     &ffecom_previous_function_decl_,
14504     &ffecom_which_entrypoint_decl_,
14505     &ffecom_float_zero_,
14506     &ffecom_float_half_,
14507     &ffecom_double_zero_,
14508     &ffecom_double_half_,
14509     &ffecom_func_result_,
14510     &ffecom_func_length_,
14511     &ffecom_multi_type_node_,
14512     &ffecom_multi_retval_,
14513     &named_labels,
14514     &shadowed_labels
14515   };
14516   size_t i;
14517
14518   malloc_init ();
14519
14520   /* Record our roots.  */
14521   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14522     ggc_add_tree_root (tree_roots[i], 1);
14523   ggc_add_tree_root (&ffecom_tree_type[0][0],
14524                      FFEINFO_basictype*FFEINFO_kindtype);
14525   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14526                      FFEINFO_basictype*FFEINFO_kindtype);
14527   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14528                      FFEINFO_basictype*FFEINFO_kindtype);
14529   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14530   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14531                 mark_binding_level);
14532   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14533                 mark_binding_level);
14534   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14535
14536   ffe_init_0 ();
14537 }
14538
14539 const char *
14540 init_parse (filename)
14541      const char *filename;
14542 {
14543   /* Open input file.  */
14544   if (filename == 0 || !strcmp (filename, "-"))
14545     {
14546       finput = stdin;
14547       filename = "stdin";
14548     }
14549   else
14550     finput = fopen (filename, "r");
14551   if (finput == 0)
14552     fatal_io_error ("can't open %s", filename);
14553
14554 #ifdef IO_BUFFER_SIZE
14555   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14556 #endif
14557
14558   /* Make identifier nodes long enough for the language-specific slots.  */
14559   set_identifier_size (sizeof (struct lang_identifier));
14560   decl_printable_name = lang_printable_name;
14561 #if BUILT_FOR_270
14562   print_error_function = lang_print_error_function;
14563 #endif
14564
14565   return filename;
14566 }
14567
14568 void
14569 finish_parse ()
14570 {
14571   fclose (finput);
14572 }
14573
14574 /* Delete the node BLOCK from the current binding level.
14575    This is used for the block inside a stmt expr ({...})
14576    so that the block can be reinserted where appropriate.  */
14577
14578 static void
14579 delete_block (block)
14580      tree block;
14581 {
14582   tree t;
14583   if (current_binding_level->blocks == block)
14584     current_binding_level->blocks = TREE_CHAIN (block);
14585   for (t = current_binding_level->blocks; t;)
14586     {
14587       if (TREE_CHAIN (t) == block)
14588         TREE_CHAIN (t) = TREE_CHAIN (block);
14589       else
14590         t = TREE_CHAIN (t);
14591     }
14592   TREE_CHAIN (block) = NULL;
14593   /* Clear TREE_USED which is always set by poplevel.
14594      The flag is set again if insert_block is called.  */
14595   TREE_USED (block) = 0;
14596 }
14597
14598 void
14599 insert_block (block)
14600      tree block;
14601 {
14602   TREE_USED (block) = 1;
14603   current_binding_level->blocks
14604     = chainon (current_binding_level->blocks, block);
14605 }
14606
14607 /* Each front end provides its own.  */
14608 static void ffe_init PARAMS ((void));
14609 static void ffe_finish PARAMS ((void));
14610 static void ffe_init_options PARAMS ((void));
14611
14612 struct lang_hooks lang_hooks = {ffe_init,
14613                                 ffe_finish,
14614                                 ffe_init_options,
14615                                 ffe_decode_option,
14616                                 NULL /* post_options */};
14617
14618 /* used by print-tree.c */
14619
14620 void
14621 lang_print_xnode (file, node, indent)
14622      FILE *file UNUSED;
14623      tree node UNUSED;
14624      int indent UNUSED;
14625 {
14626 }
14627
14628 static void
14629 ffe_finish ()
14630 {
14631   ffe_terminate_0 ();
14632
14633   if (ffe_is_ffedebug ())
14634     malloc_pool_display (malloc_pool_image ());
14635 }
14636
14637 const char *
14638 lang_identify ()
14639 {
14640   return "f77";
14641 }
14642
14643 /* Return the typed-based alias set for T, which may be an expression
14644    or a type.  Return -1 if we don't do anything special.  */
14645
14646 HOST_WIDE_INT
14647 lang_get_alias_set (t)
14648      tree t ATTRIBUTE_UNUSED;
14649 {
14650   /* We do not wish to use alias-set based aliasing at all.  Used in the
14651      extreme (every object with its own set, with equivalences recorded)
14652      it might be helpful, but there are problems when it comes to inlining.
14653      We get on ok with flag_argument_noalias, and alias-set aliasing does
14654      currently limit how stack slots can be reused, which is a lose.  */
14655   return 0;
14656 }
14657
14658 static void
14659 ffe_init_options ()
14660 {
14661   /* Set default options for Fortran.  */
14662   flag_move_all_movables = 1;
14663   flag_reduce_all_givs = 1;
14664   flag_argument_noalias = 2;
14665   flag_errno_math = 0;
14666   flag_complex_divide_method = 1;
14667 }
14668
14669 static void
14670 ffe_init ()
14671 {
14672   /* If the file is output from cpp, it should contain a first line
14673      `# 1 "real-filename"', and the current design of gcc (toplev.c
14674      in particular and the way it sets up information relied on by
14675      INCLUDE) requires that we read this now, and store the
14676      "real-filename" info in master_input_filename.  Ask the lexer
14677      to try doing this.  */
14678   ffelex_hash_kludge (finput);
14679 }
14680
14681 int
14682 mark_addressable (exp)
14683      tree exp;
14684 {
14685   register tree x = exp;
14686   while (1)
14687     switch (TREE_CODE (x))
14688       {
14689       case ADDR_EXPR:
14690       case COMPONENT_REF:
14691       case ARRAY_REF:
14692         x = TREE_OPERAND (x, 0);
14693         break;
14694
14695       case CONSTRUCTOR:
14696         TREE_ADDRESSABLE (x) = 1;
14697         return 1;
14698
14699       case VAR_DECL:
14700       case CONST_DECL:
14701       case PARM_DECL:
14702       case RESULT_DECL:
14703         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14704             && DECL_NONLOCAL (x))
14705           {
14706             if (TREE_PUBLIC (x))
14707               {
14708                 assert ("address of global register var requested" == NULL);
14709                 return 0;
14710               }
14711             assert ("address of register variable requested" == NULL);
14712           }
14713         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14714           {
14715             if (TREE_PUBLIC (x))
14716               {
14717                 assert ("address of global register var requested" == NULL);
14718                 return 0;
14719               }
14720             assert ("address of register var requested" == NULL);
14721           }
14722         put_var_into_stack (x);
14723
14724         /* drops in */
14725       case FUNCTION_DECL:
14726         TREE_ADDRESSABLE (x) = 1;
14727 #if 0                           /* poplevel deals with this now.  */
14728         if (DECL_CONTEXT (x) == 0)
14729           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14730 #endif
14731
14732       default:
14733         return 1;
14734       }
14735 }
14736
14737 /* If DECL has a cleanup, build and return that cleanup here.
14738    This is a callback called by expand_expr.  */
14739
14740 tree
14741 maybe_build_cleanup (decl)
14742      tree decl UNUSED;
14743 {
14744   /* There are no cleanups in Fortran.  */
14745   return NULL_TREE;
14746 }
14747
14748 /* Exit a binding level.
14749    Pop the level off, and restore the state of the identifier-decl mappings
14750    that were in effect when this level was entered.
14751
14752    If KEEP is nonzero, this level had explicit declarations, so
14753    and create a "block" (a BLOCK node) for the level
14754    to record its declarations and subblocks for symbol table output.
14755
14756    If FUNCTIONBODY is nonzero, this level is the body of a function,
14757    so create a block as if KEEP were set and also clear out all
14758    label names.
14759
14760    If REVERSE is nonzero, reverse the order of decls before putting
14761    them into the BLOCK.  */
14762
14763 tree
14764 poplevel (keep, reverse, functionbody)
14765      int keep;
14766      int reverse;
14767      int functionbody;
14768 {
14769   register tree link;
14770   /* The chain of decls was accumulated in reverse order.
14771      Put it into forward order, just for cleanliness.  */
14772   tree decls;
14773   tree subblocks = current_binding_level->blocks;
14774   tree block = 0;
14775   tree decl;
14776   int block_previously_created;
14777
14778   /* Get the decls in the order they were written.
14779      Usually current_binding_level->names is in reverse order.
14780      But parameter decls were previously put in forward order.  */
14781
14782   if (reverse)
14783     current_binding_level->names
14784       = decls = nreverse (current_binding_level->names);
14785   else
14786     decls = current_binding_level->names;
14787
14788   /* Output any nested inline functions within this block
14789      if they weren't already output.  */
14790
14791   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14792     if (TREE_CODE (decl) == FUNCTION_DECL
14793         && ! TREE_ASM_WRITTEN (decl)
14794         && DECL_INITIAL (decl) != 0
14795         && TREE_ADDRESSABLE (decl))
14796       {
14797         /* If this decl was copied from a file-scope decl
14798            on account of a block-scope extern decl,
14799            propagate TREE_ADDRESSABLE to the file-scope decl.
14800
14801            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14802            true, since then the decl goes through save_for_inline_copying.  */
14803         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14804             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14805           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14806         else if (DECL_SAVED_INSNS (decl) != 0)
14807           {
14808             push_function_context ();
14809             output_inline_function (decl);
14810             pop_function_context ();
14811           }
14812       }
14813
14814   /* If there were any declarations or structure tags in that level,
14815      or if this level is a function body,
14816      create a BLOCK to record them for the life of this function.  */
14817
14818   block = 0;
14819   block_previously_created = (current_binding_level->this_block != 0);
14820   if (block_previously_created)
14821     block = current_binding_level->this_block;
14822   else if (keep || functionbody)
14823     block = make_node (BLOCK);
14824   if (block != 0)
14825     {
14826       BLOCK_VARS (block) = decls;
14827       BLOCK_SUBBLOCKS (block) = subblocks;
14828     }
14829
14830   /* In each subblock, record that this is its superior.  */
14831
14832   for (link = subblocks; link; link = TREE_CHAIN (link))
14833     BLOCK_SUPERCONTEXT (link) = block;
14834
14835   /* Clear out the meanings of the local variables of this level.  */
14836
14837   for (link = decls; link; link = TREE_CHAIN (link))
14838     {
14839       if (DECL_NAME (link) != 0)
14840         {
14841           /* If the ident. was used or addressed via a local extern decl,
14842              don't forget that fact.  */
14843           if (DECL_EXTERNAL (link))
14844             {
14845               if (TREE_USED (link))
14846                 TREE_USED (DECL_NAME (link)) = 1;
14847               if (TREE_ADDRESSABLE (link))
14848                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14849             }
14850           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14851         }
14852     }
14853
14854   /* If the level being exited is the top level of a function,
14855      check over all the labels, and clear out the current
14856      (function local) meanings of their names.  */
14857
14858   if (functionbody)
14859     {
14860       /* If this is the top level block of a function,
14861          the vars are the function's parameters.
14862          Don't leave them in the BLOCK because they are
14863          found in the FUNCTION_DECL instead.  */
14864
14865       BLOCK_VARS (block) = 0;
14866     }
14867
14868   /* Pop the current level, and free the structure for reuse.  */
14869
14870   {
14871     register struct binding_level *level = current_binding_level;
14872     current_binding_level = current_binding_level->level_chain;
14873
14874     level->level_chain = free_binding_level;
14875     free_binding_level = level;
14876   }
14877
14878   /* Dispose of the block that we just made inside some higher level.  */
14879   if (functionbody
14880       && current_function_decl != error_mark_node)
14881     DECL_INITIAL (current_function_decl) = block;
14882   else if (block)
14883     {
14884       if (!block_previously_created)
14885         current_binding_level->blocks
14886           = chainon (current_binding_level->blocks, block);
14887     }
14888   /* If we did not make a block for the level just exited,
14889      any blocks made for inner levels
14890      (since they cannot be recorded as subblocks in that level)
14891      must be carried forward so they will later become subblocks
14892      of something else.  */
14893   else if (subblocks)
14894     current_binding_level->blocks
14895       = chainon (current_binding_level->blocks, subblocks);
14896
14897   if (block)
14898     TREE_USED (block) = 1;
14899   return block;
14900 }
14901
14902 void
14903 print_lang_decl (file, node, indent)
14904      FILE *file UNUSED;
14905      tree node UNUSED;
14906      int indent UNUSED;
14907 {
14908 }
14909
14910 void
14911 print_lang_identifier (file, node, indent)
14912      FILE *file;
14913      tree node;
14914      int indent;
14915 {
14916   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14917   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14918 }
14919
14920 void
14921 print_lang_statistics ()
14922 {
14923 }
14924
14925 void
14926 print_lang_type (file, node, indent)
14927      FILE *file UNUSED;
14928      tree node UNUSED;
14929      int indent UNUSED;
14930 {
14931 }
14932
14933 /* Record a decl-node X as belonging to the current lexical scope.
14934    Check for errors (such as an incompatible declaration for the same
14935    name already seen in the same scope).
14936
14937    Returns either X or an old decl for the same name.
14938    If an old decl is returned, it may have been smashed
14939    to agree with what X says.  */
14940
14941 tree
14942 pushdecl (x)
14943      tree x;
14944 {
14945   register tree t;
14946   register tree name = DECL_NAME (x);
14947   register struct binding_level *b = current_binding_level;
14948
14949   if ((TREE_CODE (x) == FUNCTION_DECL)
14950       && (DECL_INITIAL (x) == 0)
14951       && DECL_EXTERNAL (x))
14952     DECL_CONTEXT (x) = NULL_TREE;
14953   else
14954     DECL_CONTEXT (x) = current_function_decl;
14955
14956   if (name)
14957     {
14958       if (IDENTIFIER_INVENTED (name))
14959         {
14960 #if BUILT_FOR_270
14961           DECL_ARTIFICIAL (x) = 1;
14962 #endif
14963           DECL_IN_SYSTEM_HEADER (x) = 1;
14964         }
14965
14966       t = lookup_name_current_level (name);
14967
14968       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14969
14970       /* Don't push non-parms onto list for parms until we understand
14971          why we're doing this and whether it works.  */
14972
14973       assert ((b == global_binding_level)
14974               || !ffecom_transform_only_dummies_
14975               || TREE_CODE (x) == PARM_DECL);
14976
14977       if ((t != NULL_TREE) && duplicate_decls (x, t))
14978         return t;
14979
14980       /* If we are processing a typedef statement, generate a whole new
14981          ..._TYPE node (which will be just an variant of the existing
14982          ..._TYPE node with identical properties) and then install the
14983          TYPE_DECL node generated to represent the typedef name as the
14984          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14985
14986          The whole point here is to end up with a situation where each and every
14987          ..._TYPE node the compiler creates will be uniquely associated with
14988          AT MOST one node representing a typedef name. This way, even though
14989          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14990          (i.e. "typedef name") nodes very early on, later parts of the
14991          compiler can always do the reverse translation and get back the
14992          corresponding typedef name.  For example, given:
14993
14994          typedef struct S MY_TYPE; MY_TYPE object;
14995
14996          Later parts of the compiler might only know that `object' was of type
14997          `struct S' if it were not for code just below.  With this code
14998          however, later parts of the compiler see something like:
14999
15000          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15001
15002          And they can then deduce (from the node for type struct S') that the
15003          original object declaration was:
15004
15005          MY_TYPE object;
15006
15007          Being able to do this is important for proper support of protoize, and
15008          also for generating precise symbolic debugging information which
15009          takes full account of the programmer's (typedef) vocabulary.
15010
15011          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15012          TYPE_DECL node that we are now processing really represents a
15013          standard built-in type.
15014
15015          Since all standard types are effectively declared at line zero in the
15016          source file, we can easily check to see if we are working on a
15017          standard type by checking the current value of lineno.  */
15018
15019       if (TREE_CODE (x) == TYPE_DECL)
15020         {
15021           if (DECL_SOURCE_LINE (x) == 0)
15022             {
15023               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15024                 TYPE_NAME (TREE_TYPE (x)) = x;
15025             }
15026           else if (TREE_TYPE (x) != error_mark_node)
15027             {
15028               tree tt = TREE_TYPE (x);
15029
15030               tt = build_type_copy (tt);
15031               TYPE_NAME (tt) = x;
15032               TREE_TYPE (x) = tt;
15033             }
15034         }
15035
15036       /* This name is new in its binding level. Install the new declaration
15037          and return it.  */
15038       if (b == global_binding_level)
15039         IDENTIFIER_GLOBAL_VALUE (name) = x;
15040       else
15041         IDENTIFIER_LOCAL_VALUE (name) = x;
15042     }
15043
15044   /* Put decls on list in reverse order. We will reverse them later if
15045      necessary.  */
15046   TREE_CHAIN (x) = b->names;
15047   b->names = x;
15048
15049   return x;
15050 }
15051
15052 /* Nonzero if the current level needs to have a BLOCK made.  */
15053
15054 static int
15055 kept_level_p ()
15056 {
15057   tree decl;
15058
15059   for (decl = current_binding_level->names;
15060        decl;
15061        decl = TREE_CHAIN (decl))
15062     {
15063       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15064           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15065         /* Currently, there aren't supposed to be non-artificial names
15066            at other than the top block for a function -- they're
15067            believed to always be temps.  But it's wise to check anyway.  */
15068         return 1;
15069     }
15070   return 0;
15071 }
15072
15073 /* Enter a new binding level.
15074    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15075    not for that of tags.  */
15076
15077 void
15078 pushlevel (tag_transparent)
15079      int tag_transparent;
15080 {
15081   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15082
15083   assert (! tag_transparent);
15084
15085   if (current_binding_level == global_binding_level)
15086     {
15087       named_labels = 0;
15088     }
15089
15090   /* Reuse or create a struct for this binding level.  */
15091
15092   if (free_binding_level)
15093     {
15094       newlevel = free_binding_level;
15095       free_binding_level = free_binding_level->level_chain;
15096     }
15097   else
15098     {
15099       newlevel = make_binding_level ();
15100     }
15101
15102   /* Add this level to the front of the chain (stack) of levels that
15103      are active.  */
15104
15105   *newlevel = clear_binding_level;
15106   newlevel->level_chain = current_binding_level;
15107   current_binding_level = newlevel;
15108 }
15109
15110 /* Set the BLOCK node for the innermost scope
15111    (the one we are currently in).  */
15112
15113 void
15114 set_block (block)
15115      register tree block;
15116 {
15117   current_binding_level->this_block = block;
15118   current_binding_level->names = chainon (current_binding_level->names,
15119                                           BLOCK_VARS (block));
15120   current_binding_level->blocks = chainon (current_binding_level->blocks,
15121                                            BLOCK_SUBBLOCKS (block));
15122 }
15123
15124 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15125
15126 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15127
15128 void
15129 set_yydebug (value)
15130      int value;
15131 {
15132   if (value)
15133     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15134 }
15135
15136 tree
15137 signed_or_unsigned_type (unsignedp, type)
15138      int unsignedp;
15139      tree type;
15140 {
15141   tree type2;
15142
15143   if (! INTEGRAL_TYPE_P (type))
15144     return type;
15145   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15146     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15147   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15148     return unsignedp ? unsigned_type_node : integer_type_node;
15149   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15150     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15151   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15152     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15153   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15154     return (unsignedp ? long_long_unsigned_type_node
15155             : long_long_integer_type_node);
15156
15157   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15158   if (type2 == NULL_TREE)
15159     return type;
15160
15161   return type2;
15162 }
15163
15164 tree
15165 signed_type (type)
15166      tree type;
15167 {
15168   tree type1 = TYPE_MAIN_VARIANT (type);
15169   ffeinfoKindtype kt;
15170   tree type2;
15171
15172   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15173     return signed_char_type_node;
15174   if (type1 == unsigned_type_node)
15175     return integer_type_node;
15176   if (type1 == short_unsigned_type_node)
15177     return short_integer_type_node;
15178   if (type1 == long_unsigned_type_node)
15179     return long_integer_type_node;
15180   if (type1 == long_long_unsigned_type_node)
15181     return long_long_integer_type_node;
15182 #if 0   /* gcc/c-* files only */
15183   if (type1 == unsigned_intDI_type_node)
15184     return intDI_type_node;
15185   if (type1 == unsigned_intSI_type_node)
15186     return intSI_type_node;
15187   if (type1 == unsigned_intHI_type_node)
15188     return intHI_type_node;
15189   if (type1 == unsigned_intQI_type_node)
15190     return intQI_type_node;
15191 #endif
15192
15193   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15194   if (type2 != NULL_TREE)
15195     return type2;
15196
15197   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15198     {
15199       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15200
15201       if (type1 == type2)
15202         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15203     }
15204
15205   return type;
15206 }
15207
15208 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15209    or validate its data type for an `if' or `while' statement or ?..: exp.
15210
15211    This preparation consists of taking the ordinary
15212    representation of an expression expr and producing a valid tree
15213    boolean expression describing whether expr is nonzero.  We could
15214    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15215    but we optimize comparisons, &&, ||, and !.
15216
15217    The resulting type should always be `integer_type_node'.  */
15218
15219 tree
15220 truthvalue_conversion (expr)
15221      tree expr;
15222 {
15223   if (TREE_CODE (expr) == ERROR_MARK)
15224     return expr;
15225
15226 #if 0 /* This appears to be wrong for C++.  */
15227   /* These really should return error_mark_node after 2.4 is stable.
15228      But not all callers handle ERROR_MARK properly.  */
15229   switch (TREE_CODE (TREE_TYPE (expr)))
15230     {
15231     case RECORD_TYPE:
15232       error ("struct type value used where scalar is required");
15233       return integer_zero_node;
15234
15235     case UNION_TYPE:
15236       error ("union type value used where scalar is required");
15237       return integer_zero_node;
15238
15239     case ARRAY_TYPE:
15240       error ("array type value used where scalar is required");
15241       return integer_zero_node;
15242
15243     default:
15244       break;
15245     }
15246 #endif /* 0 */
15247
15248   switch (TREE_CODE (expr))
15249     {
15250       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15251          or comparison expressions as truth values at this level.  */
15252 #if 0
15253     case COMPONENT_REF:
15254       /* A one-bit unsigned bit-field is already acceptable.  */
15255       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15256           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15257         return expr;
15258       break;
15259 #endif
15260
15261     case EQ_EXPR:
15262       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15263          or comparison expressions as truth values at this level.  */
15264 #if 0
15265       if (integer_zerop (TREE_OPERAND (expr, 1)))
15266         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15267 #endif
15268     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15269     case TRUTH_ANDIF_EXPR:
15270     case TRUTH_ORIF_EXPR:
15271     case TRUTH_AND_EXPR:
15272     case TRUTH_OR_EXPR:
15273     case TRUTH_XOR_EXPR:
15274       TREE_TYPE (expr) = integer_type_node;
15275       return expr;
15276
15277     case ERROR_MARK:
15278       return expr;
15279
15280     case INTEGER_CST:
15281       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15282
15283     case REAL_CST:
15284       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15285
15286     case ADDR_EXPR:
15287       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15288         return build (COMPOUND_EXPR, integer_type_node,
15289                       TREE_OPERAND (expr, 0), integer_one_node);
15290       else
15291         return integer_one_node;
15292
15293     case COMPLEX_EXPR:
15294       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15295                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15296                        integer_type_node,
15297                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15298                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15299
15300     case NEGATE_EXPR:
15301     case ABS_EXPR:
15302     case FLOAT_EXPR:
15303     case FFS_EXPR:
15304       /* These don't change whether an object is non-zero or zero.  */
15305       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15306
15307     case LROTATE_EXPR:
15308     case RROTATE_EXPR:
15309       /* These don't change whether an object is zero or non-zero, but
15310          we can't ignore them if their second arg has side-effects.  */
15311       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15312         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15313                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15314       else
15315         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15316
15317     case COND_EXPR:
15318       /* Distribute the conversion into the arms of a COND_EXPR.  */
15319       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15320                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15321                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15322
15323     case CONVERT_EXPR:
15324       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15325          since that affects how `default_conversion' will behave.  */
15326       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15327           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15328         break;
15329       /* fall through... */
15330     case NOP_EXPR:
15331       /* If this is widening the argument, we can ignore it.  */
15332       if (TYPE_PRECISION (TREE_TYPE (expr))
15333           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15334         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15335       break;
15336
15337     case MINUS_EXPR:
15338       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15339          this case.  */
15340       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15341           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15342         break;
15343       /* fall through... */
15344     case BIT_XOR_EXPR:
15345       /* This and MINUS_EXPR can be changed into a comparison of the
15346          two objects.  */
15347       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15348           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15349         return ffecom_2 (NE_EXPR, integer_type_node,
15350                          TREE_OPERAND (expr, 0),
15351                          TREE_OPERAND (expr, 1));
15352       return ffecom_2 (NE_EXPR, integer_type_node,
15353                        TREE_OPERAND (expr, 0),
15354                        fold (build1 (NOP_EXPR,
15355                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15356                                      TREE_OPERAND (expr, 1))));
15357
15358     case BIT_AND_EXPR:
15359       if (integer_onep (TREE_OPERAND (expr, 1)))
15360         return expr;
15361       break;
15362
15363     case MODIFY_EXPR:
15364 #if 0                           /* No such thing in Fortran. */
15365       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15366         warning ("suggest parentheses around assignment used as truth value");
15367 #endif
15368       break;
15369
15370     default:
15371       break;
15372     }
15373
15374   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15375     return (ffecom_2
15376             ((TREE_SIDE_EFFECTS (expr)
15377               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15378              integer_type_node,
15379              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15380                                               TREE_TYPE (TREE_TYPE (expr)),
15381                                               expr)),
15382              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15383                                               TREE_TYPE (TREE_TYPE (expr)),
15384                                               expr))));
15385
15386   return ffecom_2 (NE_EXPR, integer_type_node,
15387                    expr,
15388                    convert (TREE_TYPE (expr), integer_zero_node));
15389 }
15390
15391 tree
15392 type_for_mode (mode, unsignedp)
15393      enum machine_mode mode;
15394      int unsignedp;
15395 {
15396   int i;
15397   int j;
15398   tree t;
15399
15400   if (mode == TYPE_MODE (integer_type_node))
15401     return unsignedp ? unsigned_type_node : integer_type_node;
15402
15403   if (mode == TYPE_MODE (signed_char_type_node))
15404     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15405
15406   if (mode == TYPE_MODE (short_integer_type_node))
15407     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15408
15409   if (mode == TYPE_MODE (long_integer_type_node))
15410     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15411
15412   if (mode == TYPE_MODE (long_long_integer_type_node))
15413     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15414
15415 #if HOST_BITS_PER_WIDE_INT >= 64
15416   if (mode == TYPE_MODE (intTI_type_node))
15417     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15418 #endif
15419
15420   if (mode == TYPE_MODE (float_type_node))
15421     return float_type_node;
15422
15423   if (mode == TYPE_MODE (double_type_node))
15424     return double_type_node;
15425
15426   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15427     return build_pointer_type (char_type_node);
15428
15429   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15430     return build_pointer_type (integer_type_node);
15431
15432   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15433     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15434       {
15435         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15436             && (mode == TYPE_MODE (t)))
15437           {
15438             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15439               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15440             else
15441               return t;
15442           }
15443       }
15444
15445   return 0;
15446 }
15447
15448 tree
15449 type_for_size (bits, unsignedp)
15450      unsigned bits;
15451      int unsignedp;
15452 {
15453   ffeinfoKindtype kt;
15454   tree type_node;
15455
15456   if (bits == TYPE_PRECISION (integer_type_node))
15457     return unsignedp ? unsigned_type_node : integer_type_node;
15458
15459   if (bits == TYPE_PRECISION (signed_char_type_node))
15460     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15461
15462   if (bits == TYPE_PRECISION (short_integer_type_node))
15463     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15464
15465   if (bits == TYPE_PRECISION (long_integer_type_node))
15466     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15467
15468   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15469     return (unsignedp ? long_long_unsigned_type_node
15470             : long_long_integer_type_node);
15471
15472   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15473     {
15474       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15475
15476       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15477         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15478           : type_node;
15479     }
15480
15481   return 0;
15482 }
15483
15484 tree
15485 unsigned_type (type)
15486      tree type;
15487 {
15488   tree type1 = TYPE_MAIN_VARIANT (type);
15489   ffeinfoKindtype kt;
15490   tree type2;
15491
15492   if (type1 == signed_char_type_node || type1 == char_type_node)
15493     return unsigned_char_type_node;
15494   if (type1 == integer_type_node)
15495     return unsigned_type_node;
15496   if (type1 == short_integer_type_node)
15497     return short_unsigned_type_node;
15498   if (type1 == long_integer_type_node)
15499     return long_unsigned_type_node;
15500   if (type1 == long_long_integer_type_node)
15501     return long_long_unsigned_type_node;
15502 #if 0   /* gcc/c-* files only */
15503   if (type1 == intDI_type_node)
15504     return unsigned_intDI_type_node;
15505   if (type1 == intSI_type_node)
15506     return unsigned_intSI_type_node;
15507   if (type1 == intHI_type_node)
15508     return unsigned_intHI_type_node;
15509   if (type1 == intQI_type_node)
15510     return unsigned_intQI_type_node;
15511 #endif
15512
15513   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15514   if (type2 != NULL_TREE)
15515     return type2;
15516
15517   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15518     {
15519       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15520
15521       if (type1 == type2)
15522         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15523     }
15524
15525   return type;
15526 }
15527
15528 void
15529 lang_mark_tree (t)
15530      union tree_node *t ATTRIBUTE_UNUSED;
15531 {
15532   if (TREE_CODE (t) == IDENTIFIER_NODE)
15533     {
15534       struct lang_identifier *i = (struct lang_identifier *) t;
15535       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15536       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15537       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15538     }
15539   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15540     ggc_mark (TYPE_LANG_SPECIFIC (t));
15541 }
15542
15543 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15544 \f
15545 #if FFECOM_GCC_INCLUDE
15546
15547 /* From gcc/cccp.c, the code to handle -I.  */
15548
15549 /* Skip leading "./" from a directory name.
15550    This may yield the empty string, which represents the current directory.  */
15551
15552 static const char *
15553 skip_redundant_dir_prefix (const char *dir)
15554 {
15555   while (dir[0] == '.' && dir[1] == '/')
15556     for (dir += 2; *dir == '/'; dir++)
15557       continue;
15558   if (dir[0] == '.' && !dir[1])
15559     dir++;
15560   return dir;
15561 }
15562
15563 /* The file_name_map structure holds a mapping of file names for a
15564    particular directory.  This mapping is read from the file named
15565    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15566    map filenames on a file system with severe filename restrictions,
15567    such as DOS.  The format of the file name map file is just a series
15568    of lines with two tokens on each line.  The first token is the name
15569    to map, and the second token is the actual name to use.  */
15570
15571 struct file_name_map
15572 {
15573   struct file_name_map *map_next;
15574   char *map_from;
15575   char *map_to;
15576 };
15577
15578 #define FILE_NAME_MAP_FILE "header.gcc"
15579
15580 /* Current maximum length of directory names in the search path
15581    for include files.  (Altered as we get more of them.)  */
15582
15583 static int max_include_len = 0;
15584
15585 struct file_name_list
15586   {
15587     struct file_name_list *next;
15588     char *fname;
15589     /* Mapping of file names for this directory.  */
15590     struct file_name_map *name_map;
15591     /* Non-zero if name_map is valid.  */
15592     int got_name_map;
15593   };
15594
15595 static struct file_name_list *include = NULL;   /* First dir to search */
15596 static struct file_name_list *last_include = NULL;      /* Last in chain */
15597
15598 /* I/O buffer structure.
15599    The `fname' field is nonzero for source files and #include files
15600    and for the dummy text used for -D and -U.
15601    It is zero for rescanning results of macro expansion
15602    and for expanding macro arguments.  */
15603 #define INPUT_STACK_MAX 400
15604 static struct file_buf {
15605   const char *fname;
15606   /* Filename specified with #line command.  */
15607   const char *nominal_fname;
15608   /* Record where in the search path this file was found.
15609      For #include_next.  */
15610   struct file_name_list *dir;
15611   ffewhereLine line;
15612   ffewhereColumn column;
15613 } instack[INPUT_STACK_MAX];
15614
15615 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15616 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15617
15618 /* Current nesting level of input sources.
15619    `instack[indepth]' is the level currently being read.  */
15620 static int indepth = -1;
15621
15622 typedef struct file_buf FILE_BUF;
15623
15624 typedef unsigned char U_CHAR;
15625
15626 /* table to tell if char can be part of a C identifier. */
15627 U_CHAR is_idchar[256];
15628 /* table to tell if char can be first char of a c identifier. */
15629 U_CHAR is_idstart[256];
15630 /* table to tell if c is horizontal space.  */
15631 U_CHAR is_hor_space[256];
15632 /* table to tell if c is horizontal or vertical space.  */
15633 static U_CHAR is_space[256];
15634
15635 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15636 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15637
15638 /* Nonzero means -I- has been seen,
15639    so don't look for #include "foo" the source-file directory.  */
15640 static int ignore_srcdir;
15641
15642 #ifndef INCLUDE_LEN_FUDGE
15643 #define INCLUDE_LEN_FUDGE 0
15644 #endif
15645
15646 static void append_include_chain (struct file_name_list *first,
15647                                   struct file_name_list *last);
15648 static FILE *open_include_file (char *filename,
15649                                 struct file_name_list *searchptr);
15650 static void print_containing_files (ffebadSeverity sev);
15651 static const char *skip_redundant_dir_prefix (const char *);
15652 static char *read_filename_string (int ch, FILE *f);
15653 static struct file_name_map *read_name_map (const char *dirname);
15654
15655 /* Append a chain of `struct file_name_list's
15656    to the end of the main include chain.
15657    FIRST is the beginning of the chain to append, and LAST is the end.  */
15658
15659 static void
15660 append_include_chain (first, last)
15661      struct file_name_list *first, *last;
15662 {
15663   struct file_name_list *dir;
15664
15665   if (!first || !last)
15666     return;
15667
15668   if (include == 0)
15669     include = first;
15670   else
15671     last_include->next = first;
15672
15673   for (dir = first; ; dir = dir->next) {
15674     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15675     if (len > max_include_len)
15676       max_include_len = len;
15677     if (dir == last)
15678       break;
15679   }
15680
15681   last->next = NULL;
15682   last_include = last;
15683 }
15684
15685 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15686    being tried from the include file search path.  This function maps
15687    filenames on file systems based on information read by
15688    read_name_map.  */
15689
15690 static FILE *
15691 open_include_file (filename, searchptr)
15692      char *filename;
15693      struct file_name_list *searchptr;
15694 {
15695   register struct file_name_map *map;
15696   register char *from;
15697   char *p, *dir;
15698
15699   if (searchptr && ! searchptr->got_name_map)
15700     {
15701       searchptr->name_map = read_name_map (searchptr->fname
15702                                            ? searchptr->fname : ".");
15703       searchptr->got_name_map = 1;
15704     }
15705
15706   /* First check the mapping for the directory we are using.  */
15707   if (searchptr && searchptr->name_map)
15708     {
15709       from = filename;
15710       if (searchptr->fname)
15711         from += strlen (searchptr->fname) + 1;
15712       for (map = searchptr->name_map; map; map = map->map_next)
15713         {
15714           if (! strcmp (map->map_from, from))
15715             {
15716               /* Found a match.  */
15717               return fopen (map->map_to, "r");
15718             }
15719         }
15720     }
15721
15722   /* Try to find a mapping file for the particular directory we are
15723      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15724      in /usr/include/header.gcc and look up types.h in
15725      /usr/include/sys/header.gcc.  */
15726   p = strrchr (filename, '/');
15727 #ifdef DIR_SEPARATOR
15728   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15729   else {
15730     char *tmp = strrchr (filename, DIR_SEPARATOR);
15731     if (tmp != NULL && tmp > p) p = tmp;
15732   }
15733 #endif
15734   if (! p)
15735     p = filename;
15736   if (searchptr
15737       && searchptr->fname
15738       && strlen (searchptr->fname) == (size_t) (p - filename)
15739       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15740     {
15741       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15742       return fopen (filename, "r");
15743     }
15744
15745   if (p == filename)
15746     {
15747       from = filename;
15748       map = read_name_map (".");
15749     }
15750   else
15751     {
15752       dir = (char *) xmalloc (p - filename + 1);
15753       memcpy (dir, filename, p - filename);
15754       dir[p - filename] = '\0';
15755       from = p + 1;
15756       map = read_name_map (dir);
15757       free (dir);
15758     }
15759   for (; map; map = map->map_next)
15760     if (! strcmp (map->map_from, from))
15761       return fopen (map->map_to, "r");
15762
15763   return fopen (filename, "r");
15764 }
15765
15766 /* Print the file names and line numbers of the #include
15767    commands which led to the current file.  */
15768
15769 static void
15770 print_containing_files (ffebadSeverity sev)
15771 {
15772   FILE_BUF *ip = NULL;
15773   int i;
15774   int first = 1;
15775   const char *str1;
15776   const char *str2;
15777
15778   /* If stack of files hasn't changed since we last printed
15779      this info, don't repeat it.  */
15780   if (last_error_tick == input_file_stack_tick)
15781     return;
15782
15783   for (i = indepth; i >= 0; i--)
15784     if (instack[i].fname != NULL) {
15785       ip = &instack[i];
15786       break;
15787     }
15788
15789   /* Give up if we don't find a source file.  */
15790   if (ip == NULL)
15791     return;
15792
15793   /* Find the other, outer source files.  */
15794   for (i--; i >= 0; i--)
15795     if (instack[i].fname != NULL)
15796       {
15797         ip = &instack[i];
15798         if (first)
15799           {
15800             first = 0;
15801             str1 = "In file included";
15802           }
15803         else
15804           {
15805             str1 = "...          ...";
15806           }
15807
15808         if (i == 1)
15809           str2 = ":";
15810         else
15811           str2 = "";
15812
15813         ffebad_start_msg ("%A from %B at %0%C", sev);
15814         ffebad_here (0, ip->line, ip->column);
15815         ffebad_string (str1);
15816         ffebad_string (ip->nominal_fname);
15817         ffebad_string (str2);
15818         ffebad_finish ();
15819       }
15820
15821   /* Record we have printed the status as of this time.  */
15822   last_error_tick = input_file_stack_tick;
15823 }
15824
15825 /* Read a space delimited string of unlimited length from a stdio
15826    file.  */
15827
15828 static char *
15829 read_filename_string (ch, f)
15830      int ch;
15831      FILE *f;
15832 {
15833   char *alloc, *set;
15834   int len;
15835
15836   len = 20;
15837   set = alloc = xmalloc (len + 1);
15838   if (! is_space[ch])
15839     {
15840       *set++ = ch;
15841       while ((ch = getc (f)) != EOF && ! is_space[ch])
15842         {
15843           if (set - alloc == len)
15844             {
15845               len *= 2;
15846               alloc = xrealloc (alloc, len + 1);
15847               set = alloc + len / 2;
15848             }
15849           *set++ = ch;
15850         }
15851     }
15852   *set = '\0';
15853   ungetc (ch, f);
15854   return alloc;
15855 }
15856
15857 /* Read the file name map file for DIRNAME.  */
15858
15859 static struct file_name_map *
15860 read_name_map (dirname)
15861      const char *dirname;
15862 {
15863   /* This structure holds a linked list of file name maps, one per
15864      directory.  */
15865   struct file_name_map_list
15866     {
15867       struct file_name_map_list *map_list_next;
15868       char *map_list_name;
15869       struct file_name_map *map_list_map;
15870     };
15871   static struct file_name_map_list *map_list;
15872   register struct file_name_map_list *map_list_ptr;
15873   char *name;
15874   FILE *f;
15875   size_t dirlen;
15876   int separator_needed;
15877
15878   dirname = skip_redundant_dir_prefix (dirname);
15879
15880   for (map_list_ptr = map_list; map_list_ptr;
15881        map_list_ptr = map_list_ptr->map_list_next)
15882     if (! strcmp (map_list_ptr->map_list_name, dirname))
15883       return map_list_ptr->map_list_map;
15884
15885   map_list_ptr = ((struct file_name_map_list *)
15886                   xmalloc (sizeof (struct file_name_map_list)));
15887   map_list_ptr->map_list_name = xstrdup (dirname);
15888   map_list_ptr->map_list_map = NULL;
15889
15890   dirlen = strlen (dirname);
15891   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15892   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15893   strcpy (name, dirname);
15894   name[dirlen] = '/';
15895   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15896   f = fopen (name, "r");
15897   free (name);
15898   if (!f)
15899     map_list_ptr->map_list_map = NULL;
15900   else
15901     {
15902       int ch;
15903
15904       while ((ch = getc (f)) != EOF)
15905         {
15906           char *from, *to;
15907           struct file_name_map *ptr;
15908
15909           if (is_space[ch])
15910             continue;
15911           from = read_filename_string (ch, f);
15912           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15913             ;
15914           to = read_filename_string (ch, f);
15915
15916           ptr = ((struct file_name_map *)
15917                  xmalloc (sizeof (struct file_name_map)));
15918           ptr->map_from = from;
15919
15920           /* Make the real filename absolute.  */
15921           if (*to == '/')
15922             ptr->map_to = to;
15923           else
15924             {
15925               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15926               strcpy (ptr->map_to, dirname);
15927               ptr->map_to[dirlen] = '/';
15928               strcpy (ptr->map_to + dirlen + separator_needed, to);
15929               free (to);
15930             }
15931
15932           ptr->map_next = map_list_ptr->map_list_map;
15933           map_list_ptr->map_list_map = ptr;
15934
15935           while ((ch = getc (f)) != '\n')
15936             if (ch == EOF)
15937               break;
15938         }
15939       fclose (f);
15940     }
15941
15942   map_list_ptr->map_list_next = map_list;
15943   map_list = map_list_ptr;
15944
15945   return map_list_ptr->map_list_map;
15946 }
15947
15948 static void
15949 ffecom_file_ (const char *name)
15950 {
15951   FILE_BUF *fp;
15952
15953   /* Do partial setup of input buffer for the sake of generating
15954      early #line directives (when -g is in effect).  */
15955
15956   fp = &instack[++indepth];
15957   memset ((char *) fp, 0, sizeof (FILE_BUF));
15958   if (name == NULL)
15959     name = "";
15960   fp->nominal_fname = fp->fname = name;
15961 }
15962
15963 /* Initialize syntactic classifications of characters.  */
15964
15965 static void
15966 ffecom_initialize_char_syntax_ ()
15967 {
15968   register int i;
15969
15970   /*
15971    * Set up is_idchar and is_idstart tables.  These should be
15972    * faster than saying (is_alpha (c) || c == '_'), etc.
15973    * Set up these things before calling any routines tthat
15974    * refer to them.
15975    */
15976   for (i = 'a'; i <= 'z'; i++) {
15977     is_idchar[i - 'a' + 'A'] = 1;
15978     is_idchar[i] = 1;
15979     is_idstart[i - 'a' + 'A'] = 1;
15980     is_idstart[i] = 1;
15981   }
15982   for (i = '0'; i <= '9'; i++)
15983     is_idchar[i] = 1;
15984   is_idchar['_'] = 1;
15985   is_idstart['_'] = 1;
15986
15987   /* horizontal space table */
15988   is_hor_space[' '] = 1;
15989   is_hor_space['\t'] = 1;
15990   is_hor_space['\v'] = 1;
15991   is_hor_space['\f'] = 1;
15992   is_hor_space['\r'] = 1;
15993
15994   is_space[' '] = 1;
15995   is_space['\t'] = 1;
15996   is_space['\v'] = 1;
15997   is_space['\f'] = 1;
15998   is_space['\n'] = 1;
15999   is_space['\r'] = 1;
16000 }
16001
16002 static void
16003 ffecom_close_include_ (FILE *f)
16004 {
16005   fclose (f);
16006
16007   indepth--;
16008   input_file_stack_tick++;
16009
16010   ffewhere_line_kill (instack[indepth].line);
16011   ffewhere_column_kill (instack[indepth].column);
16012 }
16013
16014 static int
16015 ffecom_decode_include_option_ (char *spec)
16016 {
16017   struct file_name_list *dirtmp;
16018
16019   if (! ignore_srcdir && !strcmp (spec, "-"))
16020     ignore_srcdir = 1;
16021   else
16022     {
16023       dirtmp = (struct file_name_list *)
16024         xmalloc (sizeof (struct file_name_list));
16025       dirtmp->next = 0;         /* New one goes on the end */
16026       dirtmp->fname = spec;
16027       dirtmp->got_name_map = 0;
16028       if (spec[0] == 0)
16029         error ("Directory name must immediately follow -I");
16030       else
16031         append_include_chain (dirtmp, dirtmp);
16032     }
16033   return 1;
16034 }
16035
16036 /* Open INCLUDEd file.  */
16037
16038 static FILE *
16039 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16040 {
16041   char *fbeg = name;
16042   size_t flen = strlen (fbeg);
16043   struct file_name_list *search_start = include; /* Chain of dirs to search */
16044   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16045   struct file_name_list *searchptr = 0;
16046   char *fname;          /* Dynamically allocated fname buffer */
16047   FILE *f;
16048   FILE_BUF *fp;
16049
16050   if (flen == 0)
16051     return NULL;
16052
16053   dsp[0].fname = NULL;
16054
16055   /* If -I- was specified, don't search current dir, only spec'd ones. */
16056   if (!ignore_srcdir)
16057     {
16058       for (fp = &instack[indepth]; fp >= instack; fp--)
16059         {
16060           int n;
16061           char *ep;
16062           const char *nam;
16063
16064           if ((nam = fp->nominal_fname) != NULL)
16065             {
16066               /* Found a named file.  Figure out dir of the file,
16067                  and put it in front of the search list.  */
16068               dsp[0].next = search_start;
16069               search_start = dsp;
16070 #ifndef VMS
16071               ep = strrchr (nam, '/');
16072 #ifdef DIR_SEPARATOR
16073             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16074             else {
16075               char *tmp = strrchr (nam, DIR_SEPARATOR);
16076               if (tmp != NULL && tmp > ep) ep = tmp;
16077             }
16078 #endif
16079 #else                           /* VMS */
16080               ep = strrchr (nam, ']');
16081               if (ep == NULL) ep = strrchr (nam, '>');
16082               if (ep == NULL) ep = strrchr (nam, ':');
16083               if (ep != NULL) ep++;
16084 #endif                          /* VMS */
16085               if (ep != NULL)
16086                 {
16087                   n = ep - nam;
16088                   dsp[0].fname = (char *) xmalloc (n + 1);
16089                   strncpy (dsp[0].fname, nam, n);
16090                   dsp[0].fname[n] = '\0';
16091                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16092                     max_include_len = n + INCLUDE_LEN_FUDGE;
16093                 }
16094               else
16095                 dsp[0].fname = NULL; /* Current directory */
16096               dsp[0].got_name_map = 0;
16097               break;
16098             }
16099         }
16100     }
16101
16102   /* Allocate this permanently, because it gets stored in the definitions
16103      of macros.  */
16104   fname = xmalloc (max_include_len + flen + 4);
16105   /* + 2 above for slash and terminating null.  */
16106   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16107      for g77 yet).  */
16108
16109   /* If specified file name is absolute, just open it.  */
16110
16111   if (*fbeg == '/'
16112 #ifdef DIR_SEPARATOR
16113       || *fbeg == DIR_SEPARATOR
16114 #endif
16115       )
16116     {
16117       strncpy (fname, (char *) fbeg, flen);
16118       fname[flen] = 0;
16119       f = open_include_file (fname, NULL_PTR);
16120     }
16121   else
16122     {
16123       f = NULL;
16124
16125       /* Search directory path, trying to open the file.
16126          Copy each filename tried into FNAME.  */
16127
16128       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16129         {
16130           if (searchptr->fname)
16131             {
16132               /* The empty string in a search path is ignored.
16133                  This makes it possible to turn off entirely
16134                  a standard piece of the list.  */
16135               if (searchptr->fname[0] == 0)
16136                 continue;
16137               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16138               if (fname[0] && fname[strlen (fname) - 1] != '/')
16139                 strcat (fname, "/");
16140               fname[strlen (fname) + flen] = 0;
16141             }
16142           else
16143             fname[0] = 0;
16144
16145           strncat (fname, fbeg, flen);
16146 #ifdef VMS
16147           /* Change this 1/2 Unix 1/2 VMS file specification into a
16148              full VMS file specification */
16149           if (searchptr->fname && (searchptr->fname[0] != 0))
16150             {
16151               /* Fix up the filename */
16152               hack_vms_include_specification (fname);
16153             }
16154           else
16155             {
16156               /* This is a normal VMS filespec, so use it unchanged.  */
16157               strncpy (fname, (char *) fbeg, flen);
16158               fname[flen] = 0;
16159 #if 0   /* Not for g77.  */
16160               /* if it's '#include filename', add the missing .h */
16161               if (strchr (fname, '.') == NULL)
16162                 strcat (fname, ".h");
16163 #endif
16164             }
16165 #endif /* VMS */
16166           f = open_include_file (fname, searchptr);
16167 #ifdef EACCES
16168           if (f == NULL && errno == EACCES)
16169             {
16170               print_containing_files (FFEBAD_severityWARNING);
16171               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16172                                 FFEBAD_severityWARNING);
16173               ffebad_string (fname);
16174               ffebad_here (0, l, c);
16175               ffebad_finish ();
16176             }
16177 #endif
16178           if (f != NULL)
16179             break;
16180         }
16181     }
16182
16183   if (f == NULL)
16184     {
16185       /* A file that was not found.  */
16186
16187       strncpy (fname, (char *) fbeg, flen);
16188       fname[flen] = 0;
16189       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16190       ffebad_start (FFEBAD_OPEN_INCLUDE);
16191       ffebad_here (0, l, c);
16192       ffebad_string (fname);
16193       ffebad_finish ();
16194     }
16195
16196   if (dsp[0].fname != NULL)
16197     free (dsp[0].fname);
16198
16199   if (f == NULL)
16200     return NULL;
16201
16202   if (indepth >= (INPUT_STACK_MAX - 1))
16203     {
16204       print_containing_files (FFEBAD_severityFATAL);
16205       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16206                         FFEBAD_severityFATAL);
16207       ffebad_string (fname);
16208       ffebad_here (0, l, c);
16209       ffebad_finish ();
16210       return NULL;
16211     }
16212
16213   instack[indepth].line = ffewhere_line_use (l);
16214   instack[indepth].column = ffewhere_column_use (c);
16215
16216   fp = &instack[indepth + 1];
16217   memset ((char *) fp, 0, sizeof (FILE_BUF));
16218   fp->nominal_fname = fp->fname = fname;
16219   fp->dir = searchptr;
16220
16221   indepth++;
16222   input_file_stack_tick++;
16223
16224   return f;
16225 }
16226 #endif  /* FFECOM_GCC_INCLUDE */
16227
16228 /**INDENT* (Do not reformat this comment even with -fca option.)
16229    Data-gathering files: Given the source file listed below, compiled with
16230    f2c I obtained the output file listed after that, and from the output
16231    file I derived the above code.
16232
16233 -------- (begin input file to f2c)
16234         implicit none
16235         character*10 A1,A2
16236         complex C1,C2
16237         integer I1,I2
16238         real R1,R2
16239         double precision D1,D2
16240 C
16241         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16242 c /
16243         call fooI(I1/I2)
16244         call fooR(R1/I1)
16245         call fooD(D1/I1)
16246         call fooC(C1/I1)
16247         call fooR(R1/R2)
16248         call fooD(R1/D1)
16249         call fooD(D1/D2)
16250         call fooD(D1/R1)
16251         call fooC(C1/C2)
16252         call fooC(C1/R1)
16253         call fooZ(C1/D1)
16254 c **
16255         call fooI(I1**I2)
16256         call fooR(R1**I1)
16257         call fooD(D1**I1)
16258         call fooC(C1**I1)
16259         call fooR(R1**R2)
16260         call fooD(R1**D1)
16261         call fooD(D1**D2)
16262         call fooD(D1**R1)
16263         call fooC(C1**C2)
16264         call fooC(C1**R1)
16265         call fooZ(C1**D1)
16266 c FFEINTRIN_impABS
16267         call fooR(ABS(R1))
16268 c FFEINTRIN_impACOS
16269         call fooR(ACOS(R1))
16270 c FFEINTRIN_impAIMAG
16271         call fooR(AIMAG(C1))
16272 c FFEINTRIN_impAINT
16273         call fooR(AINT(R1))
16274 c FFEINTRIN_impALOG
16275         call fooR(ALOG(R1))
16276 c FFEINTRIN_impALOG10
16277         call fooR(ALOG10(R1))
16278 c FFEINTRIN_impAMAX0
16279         call fooR(AMAX0(I1,I2))
16280 c FFEINTRIN_impAMAX1
16281         call fooR(AMAX1(R1,R2))
16282 c FFEINTRIN_impAMIN0
16283         call fooR(AMIN0(I1,I2))
16284 c FFEINTRIN_impAMIN1
16285         call fooR(AMIN1(R1,R2))
16286 c FFEINTRIN_impAMOD
16287         call fooR(AMOD(R1,R2))
16288 c FFEINTRIN_impANINT
16289         call fooR(ANINT(R1))
16290 c FFEINTRIN_impASIN
16291         call fooR(ASIN(R1))
16292 c FFEINTRIN_impATAN
16293         call fooR(ATAN(R1))
16294 c FFEINTRIN_impATAN2
16295         call fooR(ATAN2(R1,R2))
16296 c FFEINTRIN_impCABS
16297         call fooR(CABS(C1))
16298 c FFEINTRIN_impCCOS
16299         call fooC(CCOS(C1))
16300 c FFEINTRIN_impCEXP
16301         call fooC(CEXP(C1))
16302 c FFEINTRIN_impCHAR
16303         call fooA(CHAR(I1))
16304 c FFEINTRIN_impCLOG
16305         call fooC(CLOG(C1))
16306 c FFEINTRIN_impCONJG
16307         call fooC(CONJG(C1))
16308 c FFEINTRIN_impCOS
16309         call fooR(COS(R1))
16310 c FFEINTRIN_impCOSH
16311         call fooR(COSH(R1))
16312 c FFEINTRIN_impCSIN
16313         call fooC(CSIN(C1))
16314 c FFEINTRIN_impCSQRT
16315         call fooC(CSQRT(C1))
16316 c FFEINTRIN_impDABS
16317         call fooD(DABS(D1))
16318 c FFEINTRIN_impDACOS
16319         call fooD(DACOS(D1))
16320 c FFEINTRIN_impDASIN
16321         call fooD(DASIN(D1))
16322 c FFEINTRIN_impDATAN
16323         call fooD(DATAN(D1))
16324 c FFEINTRIN_impDATAN2
16325         call fooD(DATAN2(D1,D2))
16326 c FFEINTRIN_impDCOS
16327         call fooD(DCOS(D1))
16328 c FFEINTRIN_impDCOSH
16329         call fooD(DCOSH(D1))
16330 c FFEINTRIN_impDDIM
16331         call fooD(DDIM(D1,D2))
16332 c FFEINTRIN_impDEXP
16333         call fooD(DEXP(D1))
16334 c FFEINTRIN_impDIM
16335         call fooR(DIM(R1,R2))
16336 c FFEINTRIN_impDINT
16337         call fooD(DINT(D1))
16338 c FFEINTRIN_impDLOG
16339         call fooD(DLOG(D1))
16340 c FFEINTRIN_impDLOG10
16341         call fooD(DLOG10(D1))
16342 c FFEINTRIN_impDMAX1
16343         call fooD(DMAX1(D1,D2))
16344 c FFEINTRIN_impDMIN1
16345         call fooD(DMIN1(D1,D2))
16346 c FFEINTRIN_impDMOD
16347         call fooD(DMOD(D1,D2))
16348 c FFEINTRIN_impDNINT
16349         call fooD(DNINT(D1))
16350 c FFEINTRIN_impDPROD
16351         call fooD(DPROD(R1,R2))
16352 c FFEINTRIN_impDSIGN
16353         call fooD(DSIGN(D1,D2))
16354 c FFEINTRIN_impDSIN
16355         call fooD(DSIN(D1))
16356 c FFEINTRIN_impDSINH
16357         call fooD(DSINH(D1))
16358 c FFEINTRIN_impDSQRT
16359         call fooD(DSQRT(D1))
16360 c FFEINTRIN_impDTAN
16361         call fooD(DTAN(D1))
16362 c FFEINTRIN_impDTANH
16363         call fooD(DTANH(D1))
16364 c FFEINTRIN_impEXP
16365         call fooR(EXP(R1))
16366 c FFEINTRIN_impIABS
16367         call fooI(IABS(I1))
16368 c FFEINTRIN_impICHAR
16369         call fooI(ICHAR(A1))
16370 c FFEINTRIN_impIDIM
16371         call fooI(IDIM(I1,I2))
16372 c FFEINTRIN_impIDNINT
16373         call fooI(IDNINT(D1))
16374 c FFEINTRIN_impINDEX
16375         call fooI(INDEX(A1,A2))
16376 c FFEINTRIN_impISIGN
16377         call fooI(ISIGN(I1,I2))
16378 c FFEINTRIN_impLEN
16379         call fooI(LEN(A1))
16380 c FFEINTRIN_impLGE
16381         call fooL(LGE(A1,A2))
16382 c FFEINTRIN_impLGT
16383         call fooL(LGT(A1,A2))
16384 c FFEINTRIN_impLLE
16385         call fooL(LLE(A1,A2))
16386 c FFEINTRIN_impLLT
16387         call fooL(LLT(A1,A2))
16388 c FFEINTRIN_impMAX0
16389         call fooI(MAX0(I1,I2))
16390 c FFEINTRIN_impMAX1
16391         call fooI(MAX1(R1,R2))
16392 c FFEINTRIN_impMIN0
16393         call fooI(MIN0(I1,I2))
16394 c FFEINTRIN_impMIN1
16395         call fooI(MIN1(R1,R2))
16396 c FFEINTRIN_impMOD
16397         call fooI(MOD(I1,I2))
16398 c FFEINTRIN_impNINT
16399         call fooI(NINT(R1))
16400 c FFEINTRIN_impSIGN
16401         call fooR(SIGN(R1,R2))
16402 c FFEINTRIN_impSIN
16403         call fooR(SIN(R1))
16404 c FFEINTRIN_impSINH
16405         call fooR(SINH(R1))
16406 c FFEINTRIN_impSQRT
16407         call fooR(SQRT(R1))
16408 c FFEINTRIN_impTAN
16409         call fooR(TAN(R1))
16410 c FFEINTRIN_impTANH
16411         call fooR(TANH(R1))
16412 c FFEINTRIN_imp_CMPLX_C
16413         call fooC(cmplx(C1,C2))
16414 c FFEINTRIN_imp_CMPLX_D
16415         call fooZ(cmplx(D1,D2))
16416 c FFEINTRIN_imp_CMPLX_I
16417         call fooC(cmplx(I1,I2))
16418 c FFEINTRIN_imp_CMPLX_R
16419         call fooC(cmplx(R1,R2))
16420 c FFEINTRIN_imp_DBLE_C
16421         call fooD(dble(C1))
16422 c FFEINTRIN_imp_DBLE_D
16423         call fooD(dble(D1))
16424 c FFEINTRIN_imp_DBLE_I
16425         call fooD(dble(I1))
16426 c FFEINTRIN_imp_DBLE_R
16427         call fooD(dble(R1))
16428 c FFEINTRIN_imp_INT_C
16429         call fooI(int(C1))
16430 c FFEINTRIN_imp_INT_D
16431         call fooI(int(D1))
16432 c FFEINTRIN_imp_INT_I
16433         call fooI(int(I1))
16434 c FFEINTRIN_imp_INT_R
16435         call fooI(int(R1))
16436 c FFEINTRIN_imp_REAL_C
16437         call fooR(real(C1))
16438 c FFEINTRIN_imp_REAL_D
16439         call fooR(real(D1))
16440 c FFEINTRIN_imp_REAL_I
16441         call fooR(real(I1))
16442 c FFEINTRIN_imp_REAL_R
16443         call fooR(real(R1))
16444 c
16445 c FFEINTRIN_imp_INT_D:
16446 c
16447 c FFEINTRIN_specIDINT
16448         call fooI(IDINT(D1))
16449 c
16450 c FFEINTRIN_imp_INT_R:
16451 c
16452 c FFEINTRIN_specIFIX
16453         call fooI(IFIX(R1))
16454 c FFEINTRIN_specINT
16455         call fooI(INT(R1))
16456 c
16457 c FFEINTRIN_imp_REAL_D:
16458 c
16459 c FFEINTRIN_specSNGL
16460         call fooR(SNGL(D1))
16461 c
16462 c FFEINTRIN_imp_REAL_I:
16463 c
16464 c FFEINTRIN_specFLOAT
16465         call fooR(FLOAT(I1))
16466 c FFEINTRIN_specREAL
16467         call fooR(REAL(I1))
16468 c
16469         end
16470 -------- (end input file to f2c)
16471
16472 -------- (begin output from providing above input file as input to:
16473 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16474 --------     -e "s:^#.*$::g"')
16475
16476 //  -- translated by f2c (version 19950223).
16477    You must link the resulting object file with the libraries:
16478         -lf2c -lm   (in that order)
16479 //
16480
16481
16482 // f2c.h  --  Standard Fortran to C header file //
16483
16484 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16485
16486         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16487
16488
16489
16490
16491 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16492 // we assume short, float are OK //
16493 typedef long int // long int // integer;
16494 typedef char *address;
16495 typedef short int shortint;
16496 typedef float real;
16497 typedef double doublereal;
16498 typedef struct { real r, i; } complex;
16499 typedef struct { doublereal r, i; } doublecomplex;
16500 typedef long int // long int // logical;
16501 typedef short int shortlogical;
16502 typedef char logical1;
16503 typedef char integer1;
16504 // typedef long long longint; // // system-dependent //
16505
16506
16507
16508
16509 // Extern is for use with -E //
16510
16511
16512
16513
16514 // I/O stuff //
16515
16516
16517
16518
16519
16520
16521
16522
16523 typedef long int // int or long int // flag;
16524 typedef long int // int or long int // ftnlen;
16525 typedef long int // int or long int // ftnint;
16526
16527
16528 //external read, write//
16529 typedef struct
16530 {       flag cierr;
16531         ftnint ciunit;
16532         flag ciend;
16533         char *cifmt;
16534         ftnint cirec;
16535 } cilist;
16536
16537 //internal read, write//
16538 typedef struct
16539 {       flag icierr;
16540         char *iciunit;
16541         flag iciend;
16542         char *icifmt;
16543         ftnint icirlen;
16544         ftnint icirnum;
16545 } icilist;
16546
16547 //open//
16548 typedef struct
16549 {       flag oerr;
16550         ftnint ounit;
16551         char *ofnm;
16552         ftnlen ofnmlen;
16553         char *osta;
16554         char *oacc;
16555         char *ofm;
16556         ftnint orl;
16557         char *oblnk;
16558 } olist;
16559
16560 //close//
16561 typedef struct
16562 {       flag cerr;
16563         ftnint cunit;
16564         char *csta;
16565 } cllist;
16566
16567 //rewind, backspace, endfile//
16568 typedef struct
16569 {       flag aerr;
16570         ftnint aunit;
16571 } alist;
16572
16573 // inquire //
16574 typedef struct
16575 {       flag inerr;
16576         ftnint inunit;
16577         char *infile;
16578         ftnlen infilen;
16579         ftnint  *inex;  //parameters in standard's order//
16580         ftnint  *inopen;
16581         ftnint  *innum;
16582         ftnint  *innamed;
16583         char    *inname;
16584         ftnlen  innamlen;
16585         char    *inacc;
16586         ftnlen  inacclen;
16587         char    *inseq;
16588         ftnlen  inseqlen;
16589         char    *indir;
16590         ftnlen  indirlen;
16591         char    *infmt;
16592         ftnlen  infmtlen;
16593         char    *inform;
16594         ftnint  informlen;
16595         char    *inunf;
16596         ftnlen  inunflen;
16597         ftnint  *inrecl;
16598         ftnint  *innrec;
16599         char    *inblank;
16600         ftnlen  inblanklen;
16601 } inlist;
16602
16603
16604
16605 union Multitype {       // for multiple entry points //
16606         integer1 g;
16607         shortint h;
16608         integer i;
16609         // longint j; //
16610         real r;
16611         doublereal d;
16612         complex c;
16613         doublecomplex z;
16614         };
16615
16616 typedef union Multitype Multitype;
16617
16618 typedef long Long;      // No longer used; formerly in Namelist //
16619
16620 struct Vardesc {        // for Namelist //
16621         char *name;
16622         char *addr;
16623         ftnlen *dims;
16624         int  type;
16625         };
16626 typedef struct Vardesc Vardesc;
16627
16628 struct Namelist {
16629         char *name;
16630         Vardesc **vars;
16631         int nvars;
16632         };
16633 typedef struct Namelist Namelist;
16634
16635
16636
16637
16638
16639
16640
16641
16642 // procedure parameter types for -A and -C++ //
16643
16644
16645
16646
16647 typedef int // Unknown procedure type // (*U_fp)();
16648 typedef shortint (*J_fp)();
16649 typedef integer (*I_fp)();
16650 typedef real (*R_fp)();
16651 typedef doublereal (*D_fp)(), (*E_fp)();
16652 typedef // Complex // void  (*C_fp)();
16653 typedef // Double Complex // void  (*Z_fp)();
16654 typedef logical (*L_fp)();
16655 typedef shortlogical (*K_fp)();
16656 typedef // Character // void  (*H_fp)();
16657 typedef // Subroutine // int (*S_fp)();
16658
16659 // E_fp is for real functions when -R is not specified //
16660 typedef void  C_f;      // complex function //
16661 typedef void  H_f;      // character function //
16662 typedef void  Z_f;      // double complex function //
16663 typedef doublereal E_f; // real function with -R not specified //
16664
16665 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16666
16667
16668 // (No such symbols should be defined in a strict ANSI C compiler.
16669    We can avoid trouble with f2c-translated code by using
16670    gcc -ansi [-traditional].) //
16671
16672
16673
16674
16675
16676
16677
16678
16679
16680
16681
16682
16683
16684
16685
16686
16687
16688
16689
16690
16691
16692
16693
16694 // Main program // MAIN__()
16695 {
16696     // System generated locals //
16697     integer i__1;
16698     real r__1, r__2;
16699     doublereal d__1, d__2;
16700     complex q__1;
16701     doublecomplex z__1, z__2, z__3;
16702     logical L__1;
16703     char ch__1[1];
16704
16705     // Builtin functions //
16706     void c_div();
16707     integer pow_ii();
16708     double pow_ri(), pow_di();
16709     void pow_ci();
16710     double pow_dd();
16711     void pow_zz();
16712     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16713             asin(), atan(), atan2(), c_abs();
16714     void c_cos(), c_exp(), c_log(), r_cnjg();
16715     double cos(), cosh();
16716     void c_sin(), c_sqrt();
16717     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16718             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16719     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16720     logical l_ge(), l_gt(), l_le(), l_lt();
16721     integer i_nint();
16722     double r_sign();
16723
16724     // Local variables //
16725     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16726             fool_(), fooz_(), getem_();
16727     static char a1[10], a2[10];
16728     static complex c1, c2;
16729     static doublereal d1, d2;
16730     static integer i1, i2;
16731     static real r1, r2;
16732
16733
16734     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16735 // / //
16736     i__1 = i1 / i2;
16737     fooi_(&i__1);
16738     r__1 = r1 / i1;
16739     foor_(&r__1);
16740     d__1 = d1 / i1;
16741     food_(&d__1);
16742     d__1 = (doublereal) i1;
16743     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16744     fooc_(&q__1);
16745     r__1 = r1 / r2;
16746     foor_(&r__1);
16747     d__1 = r1 / d1;
16748     food_(&d__1);
16749     d__1 = d1 / d2;
16750     food_(&d__1);
16751     d__1 = d1 / r1;
16752     food_(&d__1);
16753     c_div(&q__1, &c1, &c2);
16754     fooc_(&q__1);
16755     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16756     fooc_(&q__1);
16757     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16758     fooz_(&z__1);
16759 // ** //
16760     i__1 = pow_ii(&i1, &i2);
16761     fooi_(&i__1);
16762     r__1 = pow_ri(&r1, &i1);
16763     foor_(&r__1);
16764     d__1 = pow_di(&d1, &i1);
16765     food_(&d__1);
16766     pow_ci(&q__1, &c1, &i1);
16767     fooc_(&q__1);
16768     d__1 = (doublereal) r1;
16769     d__2 = (doublereal) r2;
16770     r__1 = pow_dd(&d__1, &d__2);
16771     foor_(&r__1);
16772     d__2 = (doublereal) r1;
16773     d__1 = pow_dd(&d__2, &d1);
16774     food_(&d__1);
16775     d__1 = pow_dd(&d1, &d2);
16776     food_(&d__1);
16777     d__2 = (doublereal) r1;
16778     d__1 = pow_dd(&d1, &d__2);
16779     food_(&d__1);
16780     z__2.r = c1.r, z__2.i = c1.i;
16781     z__3.r = c2.r, z__3.i = c2.i;
16782     pow_zz(&z__1, &z__2, &z__3);
16783     q__1.r = z__1.r, q__1.i = z__1.i;
16784     fooc_(&q__1);
16785     z__2.r = c1.r, z__2.i = c1.i;
16786     z__3.r = r1, z__3.i = 0.;
16787     pow_zz(&z__1, &z__2, &z__3);
16788     q__1.r = z__1.r, q__1.i = z__1.i;
16789     fooc_(&q__1);
16790     z__2.r = c1.r, z__2.i = c1.i;
16791     z__3.r = d1, z__3.i = 0.;
16792     pow_zz(&z__1, &z__2, &z__3);
16793     fooz_(&z__1);
16794 // FFEINTRIN_impABS //
16795     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16796     foor_(&r__1);
16797 // FFEINTRIN_impACOS //
16798     r__1 = acos(r1);
16799     foor_(&r__1);
16800 // FFEINTRIN_impAIMAG //
16801     r__1 = r_imag(&c1);
16802     foor_(&r__1);
16803 // FFEINTRIN_impAINT //
16804     r__1 = r_int(&r1);
16805     foor_(&r__1);
16806 // FFEINTRIN_impALOG //
16807     r__1 = log(r1);
16808     foor_(&r__1);
16809 // FFEINTRIN_impALOG10 //
16810     r__1 = r_lg10(&r1);
16811     foor_(&r__1);
16812 // FFEINTRIN_impAMAX0 //
16813     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16814     foor_(&r__1);
16815 // FFEINTRIN_impAMAX1 //
16816     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16817     foor_(&r__1);
16818 // FFEINTRIN_impAMIN0 //
16819     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16820     foor_(&r__1);
16821 // FFEINTRIN_impAMIN1 //
16822     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16823     foor_(&r__1);
16824 // FFEINTRIN_impAMOD //
16825     r__1 = r_mod(&r1, &r2);
16826     foor_(&r__1);
16827 // FFEINTRIN_impANINT //
16828     r__1 = r_nint(&r1);
16829     foor_(&r__1);
16830 // FFEINTRIN_impASIN //
16831     r__1 = asin(r1);
16832     foor_(&r__1);
16833 // FFEINTRIN_impATAN //
16834     r__1 = atan(r1);
16835     foor_(&r__1);
16836 // FFEINTRIN_impATAN2 //
16837     r__1 = atan2(r1, r2);
16838     foor_(&r__1);
16839 // FFEINTRIN_impCABS //
16840     r__1 = c_abs(&c1);
16841     foor_(&r__1);
16842 // FFEINTRIN_impCCOS //
16843     c_cos(&q__1, &c1);
16844     fooc_(&q__1);
16845 // FFEINTRIN_impCEXP //
16846     c_exp(&q__1, &c1);
16847     fooc_(&q__1);
16848 // FFEINTRIN_impCHAR //
16849     *(unsigned char *)&ch__1[0] = i1;
16850     fooa_(ch__1, 1L);
16851 // FFEINTRIN_impCLOG //
16852     c_log(&q__1, &c1);
16853     fooc_(&q__1);
16854 // FFEINTRIN_impCONJG //
16855     r_cnjg(&q__1, &c1);
16856     fooc_(&q__1);
16857 // FFEINTRIN_impCOS //
16858     r__1 = cos(r1);
16859     foor_(&r__1);
16860 // FFEINTRIN_impCOSH //
16861     r__1 = cosh(r1);
16862     foor_(&r__1);
16863 // FFEINTRIN_impCSIN //
16864     c_sin(&q__1, &c1);
16865     fooc_(&q__1);
16866 // FFEINTRIN_impCSQRT //
16867     c_sqrt(&q__1, &c1);
16868     fooc_(&q__1);
16869 // FFEINTRIN_impDABS //
16870     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16871     food_(&d__1);
16872 // FFEINTRIN_impDACOS //
16873     d__1 = acos(d1);
16874     food_(&d__1);
16875 // FFEINTRIN_impDASIN //
16876     d__1 = asin(d1);
16877     food_(&d__1);
16878 // FFEINTRIN_impDATAN //
16879     d__1 = atan(d1);
16880     food_(&d__1);
16881 // FFEINTRIN_impDATAN2 //
16882     d__1 = atan2(d1, d2);
16883     food_(&d__1);
16884 // FFEINTRIN_impDCOS //
16885     d__1 = cos(d1);
16886     food_(&d__1);
16887 // FFEINTRIN_impDCOSH //
16888     d__1 = cosh(d1);
16889     food_(&d__1);
16890 // FFEINTRIN_impDDIM //
16891     d__1 = d_dim(&d1, &d2);
16892     food_(&d__1);
16893 // FFEINTRIN_impDEXP //
16894     d__1 = exp(d1);
16895     food_(&d__1);
16896 // FFEINTRIN_impDIM //
16897     r__1 = r_dim(&r1, &r2);
16898     foor_(&r__1);
16899 // FFEINTRIN_impDINT //
16900     d__1 = d_int(&d1);
16901     food_(&d__1);
16902 // FFEINTRIN_impDLOG //
16903     d__1 = log(d1);
16904     food_(&d__1);
16905 // FFEINTRIN_impDLOG10 //
16906     d__1 = d_lg10(&d1);
16907     food_(&d__1);
16908 // FFEINTRIN_impDMAX1 //
16909     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16910     food_(&d__1);
16911 // FFEINTRIN_impDMIN1 //
16912     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16913     food_(&d__1);
16914 // FFEINTRIN_impDMOD //
16915     d__1 = d_mod(&d1, &d2);
16916     food_(&d__1);
16917 // FFEINTRIN_impDNINT //
16918     d__1 = d_nint(&d1);
16919     food_(&d__1);
16920 // FFEINTRIN_impDPROD //
16921     d__1 = (doublereal) r1 * r2;
16922     food_(&d__1);
16923 // FFEINTRIN_impDSIGN //
16924     d__1 = d_sign(&d1, &d2);
16925     food_(&d__1);
16926 // FFEINTRIN_impDSIN //
16927     d__1 = sin(d1);
16928     food_(&d__1);
16929 // FFEINTRIN_impDSINH //
16930     d__1 = sinh(d1);
16931     food_(&d__1);
16932 // FFEINTRIN_impDSQRT //
16933     d__1 = sqrt(d1);
16934     food_(&d__1);
16935 // FFEINTRIN_impDTAN //
16936     d__1 = tan(d1);
16937     food_(&d__1);
16938 // FFEINTRIN_impDTANH //
16939     d__1 = tanh(d1);
16940     food_(&d__1);
16941 // FFEINTRIN_impEXP //
16942     r__1 = exp(r1);
16943     foor_(&r__1);
16944 // FFEINTRIN_impIABS //
16945     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16946     fooi_(&i__1);
16947 // FFEINTRIN_impICHAR //
16948     i__1 = *(unsigned char *)a1;
16949     fooi_(&i__1);
16950 // FFEINTRIN_impIDIM //
16951     i__1 = i_dim(&i1, &i2);
16952     fooi_(&i__1);
16953 // FFEINTRIN_impIDNINT //
16954     i__1 = i_dnnt(&d1);
16955     fooi_(&i__1);
16956 // FFEINTRIN_impINDEX //
16957     i__1 = i_indx(a1, a2, 10L, 10L);
16958     fooi_(&i__1);
16959 // FFEINTRIN_impISIGN //
16960     i__1 = i_sign(&i1, &i2);
16961     fooi_(&i__1);
16962 // FFEINTRIN_impLEN //
16963     i__1 = i_len(a1, 10L);
16964     fooi_(&i__1);
16965 // FFEINTRIN_impLGE //
16966     L__1 = l_ge(a1, a2, 10L, 10L);
16967     fool_(&L__1);
16968 // FFEINTRIN_impLGT //
16969     L__1 = l_gt(a1, a2, 10L, 10L);
16970     fool_(&L__1);
16971 // FFEINTRIN_impLLE //
16972     L__1 = l_le(a1, a2, 10L, 10L);
16973     fool_(&L__1);
16974 // FFEINTRIN_impLLT //
16975     L__1 = l_lt(a1, a2, 10L, 10L);
16976     fool_(&L__1);
16977 // FFEINTRIN_impMAX0 //
16978     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16979     fooi_(&i__1);
16980 // FFEINTRIN_impMAX1 //
16981     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16982     fooi_(&i__1);
16983 // FFEINTRIN_impMIN0 //
16984     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16985     fooi_(&i__1);
16986 // FFEINTRIN_impMIN1 //
16987     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16988     fooi_(&i__1);
16989 // FFEINTRIN_impMOD //
16990     i__1 = i1 % i2;
16991     fooi_(&i__1);
16992 // FFEINTRIN_impNINT //
16993     i__1 = i_nint(&r1);
16994     fooi_(&i__1);
16995 // FFEINTRIN_impSIGN //
16996     r__1 = r_sign(&r1, &r2);
16997     foor_(&r__1);
16998 // FFEINTRIN_impSIN //
16999     r__1 = sin(r1);
17000     foor_(&r__1);
17001 // FFEINTRIN_impSINH //
17002     r__1 = sinh(r1);
17003     foor_(&r__1);
17004 // FFEINTRIN_impSQRT //
17005     r__1 = sqrt(r1);
17006     foor_(&r__1);
17007 // FFEINTRIN_impTAN //
17008     r__1 = tan(r1);
17009     foor_(&r__1);
17010 // FFEINTRIN_impTANH //
17011     r__1 = tanh(r1);
17012     foor_(&r__1);
17013 // FFEINTRIN_imp_CMPLX_C //
17014     r__1 = c1.r;
17015     r__2 = c2.r;
17016     q__1.r = r__1, q__1.i = r__2;
17017     fooc_(&q__1);
17018 // FFEINTRIN_imp_CMPLX_D //
17019     z__1.r = d1, z__1.i = d2;
17020     fooz_(&z__1);
17021 // FFEINTRIN_imp_CMPLX_I //
17022     r__1 = (real) i1;
17023     r__2 = (real) i2;
17024     q__1.r = r__1, q__1.i = r__2;
17025     fooc_(&q__1);
17026 // FFEINTRIN_imp_CMPLX_R //
17027     q__1.r = r1, q__1.i = r2;
17028     fooc_(&q__1);
17029 // FFEINTRIN_imp_DBLE_C //
17030     d__1 = (doublereal) c1.r;
17031     food_(&d__1);
17032 // FFEINTRIN_imp_DBLE_D //
17033     d__1 = d1;
17034     food_(&d__1);
17035 // FFEINTRIN_imp_DBLE_I //
17036     d__1 = (doublereal) i1;
17037     food_(&d__1);
17038 // FFEINTRIN_imp_DBLE_R //
17039     d__1 = (doublereal) r1;
17040     food_(&d__1);
17041 // FFEINTRIN_imp_INT_C //
17042     i__1 = (integer) c1.r;
17043     fooi_(&i__1);
17044 // FFEINTRIN_imp_INT_D //
17045     i__1 = (integer) d1;
17046     fooi_(&i__1);
17047 // FFEINTRIN_imp_INT_I //
17048     i__1 = i1;
17049     fooi_(&i__1);
17050 // FFEINTRIN_imp_INT_R //
17051     i__1 = (integer) r1;
17052     fooi_(&i__1);
17053 // FFEINTRIN_imp_REAL_C //
17054     r__1 = c1.r;
17055     foor_(&r__1);
17056 // FFEINTRIN_imp_REAL_D //
17057     r__1 = (real) d1;
17058     foor_(&r__1);
17059 // FFEINTRIN_imp_REAL_I //
17060     r__1 = (real) i1;
17061     foor_(&r__1);
17062 // FFEINTRIN_imp_REAL_R //
17063     r__1 = r1;
17064     foor_(&r__1);
17065
17066 // FFEINTRIN_imp_INT_D: //
17067
17068 // FFEINTRIN_specIDINT //
17069     i__1 = (integer) d1;
17070     fooi_(&i__1);
17071
17072 // FFEINTRIN_imp_INT_R: //
17073
17074 // FFEINTRIN_specIFIX //
17075     i__1 = (integer) r1;
17076     fooi_(&i__1);
17077 // FFEINTRIN_specINT //
17078     i__1 = (integer) r1;
17079     fooi_(&i__1);
17080
17081 // FFEINTRIN_imp_REAL_D: //
17082
17083 // FFEINTRIN_specSNGL //
17084     r__1 = (real) d1;
17085     foor_(&r__1);
17086
17087 // FFEINTRIN_imp_REAL_I: //
17088
17089 // FFEINTRIN_specFLOAT //
17090     r__1 = (real) i1;
17091     foor_(&r__1);
17092 // FFEINTRIN_specREAL //
17093     r__1 = (real) i1;
17094     foor_(&r__1);
17095
17096 } // MAIN__ //
17097
17098 -------- (end output file from f2c)
17099
17100 */