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 #include "diagnostic.h"
  93 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  94
  95 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  96
  97 /* VMS-specific definitions */
  98 #ifdef VMS
  99 #include <descrip.h>
 100 #define O_RDONLY        0       /* Open arg for Read/Only  */
 101 #define O_WRONLY        1       /* Open arg for Write/Only */
 102 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 103 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 104 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 105 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 106 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 107 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 108 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 109 static int VMS_fstat (), VMS_stat ();
 110 static char * VMS_strncat ();
 111 static int VMS_read ();
 112 static int VMS_write ();
 113 static int VMS_open ();
 114 static FILE * VMS_fopen ();
 115 static FILE * VMS_freopen ();
 116 static void hack_vms_include_specification ();
 117 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 118 #define ino_t vms_ino_t
 119 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 120 #endif /* VMS */
 121
 122 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 123 #include "com.h"
 124 #include "bad.h"
 125 #include "bld.h"
 126 #include "equiv.h"
 127 #include "expr.h"
 128 #include "implic.h"
 129 #include "info.h"
 130 #include "malloc.h"
 131 #include "src.h"
 132 #include "st.h"
 133 #include "storag.h"
 134 #include "symbol.h"
 135 #include "target.h"
 136 #include "top.h"
 137 #include "type.h"
 138
 139 /* Externals defined here.  */
 140
 141 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 142
 143 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 144    reference it.  */
 145
 146 const char * const language_string = "GNU F77";
 147
 148 /* Stream for reading from the input file.  */
 149 FILE *finput;
 150
 151 /* These definitions parallel those in c-decl.c so that code from that
 152    module can be used pretty much as is.  Much of these defs aren't
 153    otherwise used, i.e. by g77 code per se, except some of them are used
 154    to build some of them that are.  The ones that are global (i.e. not
 155    "static") are those that ste.c and such might use (directly
 156    or by using com macros that reference them in their definitions).  */
 157
 158 tree string_type_node;
 159
 160 /* The rest of these are inventions for g77, though there might be
 161    similar things in the C front end.  As they are found, these
 162    inventions should be renamed to be canonical.  Note that only
 163    the ones currently required to be global are so.  */
 164
 165 static tree ffecom_tree_fun_type_void;
 166
 167 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 168 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 169 tree ffecom_integer_one_node;   /* " */
 170 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 171
 172 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 173    just use build_function_type and build_pointer_type on the
 174    appropriate _tree_type array element.  */
 175
 176 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 177 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 178 static tree ffecom_tree_subr_type;
 179 static tree ffecom_tree_ptr_to_subr_type;
 180 static tree ffecom_tree_blockdata_type;
 181
 182 static tree ffecom_tree_xargc_;
 183
 184 ffecomSymbol ffecom_symbol_null_
 185 =
 186 {
 187   NULL_TREE,
 188   NULL_TREE,
 189   NULL_TREE,
 190   NULL_TREE,
 191   false
 192 };
 193 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 194 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 195
 196 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 197 tree ffecom_f2c_integer_type_node;
 198 tree ffecom_f2c_ptr_to_integer_type_node;
 199 tree ffecom_f2c_address_type_node;
 200 tree ffecom_f2c_real_type_node;
 201 tree ffecom_f2c_ptr_to_real_type_node;
 202 tree ffecom_f2c_doublereal_type_node;
 203 tree ffecom_f2c_complex_type_node;
 204 tree ffecom_f2c_doublecomplex_type_node;
 205 tree ffecom_f2c_longint_type_node;
 206 tree ffecom_f2c_logical_type_node;
 207 tree ffecom_f2c_flag_type_node;
 208 tree ffecom_f2c_ftnlen_type_node;
 209 tree ffecom_f2c_ftnlen_zero_node;
 210 tree ffecom_f2c_ftnlen_one_node;
 211 tree ffecom_f2c_ftnlen_two_node;
 212 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 213 tree ffecom_f2c_ftnint_type_node;
 214 tree ffecom_f2c_ptr_to_ftnint_type_node;
 215 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 216
 217 /* Simple definitions and enumerations. */
 218
 219 #ifndef FFECOM_sizeMAXSTACKITEM
 220 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 221                                            larger than this # bytes
 222                                            off stack if possible. */
 223 #endif
 224
 225 /* For systems that have large enough stacks, they should define
 226    this to 0, and here, for ease of use later on, we just undefine
 227    it if it is 0.  */
 228
 229 #if FFECOM_sizeMAXSTACKITEM == 0
 230 #undef FFECOM_sizeMAXSTACKITEM
 231 #endif
 232
 233 typedef enum
 234   {
 235     FFECOM_rttypeVOID_,
 236     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 237     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 238     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 239     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 240     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 241     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 242     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 243     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 244     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 245     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 246     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 247     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 248     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 249     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 250     FFECOM_rttype_
 251   } ffecomRttype_;
 252
 253 /* Internal typedefs. */
 254
 255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 256 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 257 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 258
 259 /* Private include files. */
 260
 261
 262 /* Internal structure definitions. */
 263
 264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 265 struct _ffecom_concat_list_
 266   {
 267     ffebld *exprs;
 268     int count;
 269     int max;
 270     ffetargetCharacterSize minlen;
 271     ffetargetCharacterSize maxlen;
 272   };
 273 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 274
 275 /* Static functions (internal). */
 276
 277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 278 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 279 static tree ffecom_widest_expr_type_ (ffebld list);
 280 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 281                              tree dest_size, tree source_tree,
 282                              ffebld source, bool scalar_arg);
 283 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 284                                       tree args, tree callee_commons,
 285                                       bool scalar_args);
 286 static tree ffecom_build_f2c_string_ (int i, const char *s);
 287 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 288                           bool is_f2c_complex, tree type,
 289                           tree args, tree dest_tree,
 290                           ffebld dest, bool *dest_used,
 291                           tree callee_commons, bool scalar_args, tree hook);
 292 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 293                                 bool is_f2c_complex, tree type,
 294                                 ffebld left, ffebld right,
 295                                 tree dest_tree, ffebld dest,
 296                                 bool *dest_used, tree callee_commons,
 297                                 bool scalar_args, bool ref, tree hook);
 298 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 299                                  ffebld expr, bool with_null);
 300 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 301 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 302 static ffecomConcatList_
 303   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 304                               ffebld expr,
 305                               ffetargetCharacterSize max);
 306 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 307 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 308                                                 ffetargetCharacterSize max);
 309 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 310                                   ffesymbol member, tree member_type,
 311                                   ffetargetOffset offset);
 312 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 313 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 314                           bool *dest_used, bool assignp, bool widenp);
 315 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 316                                     ffebld dest, bool *dest_used);
 317 static tree ffecom_expr_power_integer_ (ffebld expr);
 318 static void ffecom_expr_transform_ (ffebld expr);
 319 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 320 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 321                                       int code);
 322 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 323 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 324 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 325 static tree ffecom_get_external_identifier_ (ffesymbol s);
 326 static tree ffecom_get_identifier_ (const char *text);
 327 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 328                                   ffeinfoBasictype bt,
 329                                   ffeinfoKindtype kt);
 330 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 331 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 332 static tree ffecom_init_zero_ (tree decl);
 333 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 334                                      tree *maybe_tree);
 335 static tree ffecom_intrinsic_len_ (ffebld expr);
 336 static void ffecom_let_char_ (tree dest_tree,
 337                               tree dest_length,
 338                               ffetargetCharacterSize dest_size,
 339                               ffebld source);
 340 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 341 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 342 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 343 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 344                                       ffebld source);
 345 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 346                                       bool stmtfunc);
 347 static void ffecom_start_progunit_ (void);
 348 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 349 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 350 static void ffecom_transform_common_ (ffesymbol s);
 351 static void ffecom_transform_equiv_ (ffestorag st);
 352 static tree ffecom_transform_namelist_ (ffesymbol s);
 353 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 354                                        tree t);
 355 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 356                                        tree *size, tree tree);
 357 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 358                                  tree dest_tree, ffebld dest,
 359                                  bool *dest_used, tree hook);
 360 static tree ffecom_type_localvar_ (ffesymbol s,
 361                                    ffeinfoBasictype bt,
 362                                    ffeinfoKindtype kt);
 363 static tree ffecom_type_namelist_ (void);
 364 static tree ffecom_type_vardesc_ (void);
 365 static tree ffecom_vardesc_ (ffebld expr);
 366 static tree ffecom_vardesc_array_ (ffesymbol s);
 367 static tree ffecom_vardesc_dims_ (ffesymbol s);
 368 static tree ffecom_convert_narrow_ (tree type, tree expr);
 369 static tree ffecom_convert_widen_ (tree type, tree expr);
 370 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 371
 372 /* These are static functions that parallel those found in the C front
 373    end and thus have the same names.  */
 374
 375 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 376 static tree bison_rule_compstmt_ (void);
 377 static void bison_rule_pushlevel_ (void);
 378 static void delete_block (tree block);
 379 static int duplicate_decls (tree newdecl, tree olddecl);
 380 static void finish_decl (tree decl, tree init, bool is_top_level);
 381 static void finish_function (int nested);
 382 static const char *lang_printable_name (tree decl, int v);
 383 static tree lookup_name_current_level (tree name);
 384 static struct binding_level *make_binding_level (void);
 385 static void pop_f_function_context (void);
 386 static void push_f_function_context (void);
 387 static void push_parm_decl (tree parm);
 388 static tree pushdecl_top_level (tree decl);
 389 static int kept_level_p (void);
 390 static tree storedecls (tree decls);
 391 static void store_parm_decls (int is_main_program);
 392 static tree start_decl (tree decl, bool is_top_level);
 393 static void start_function (tree name, tree type, int nested, int public);
 394 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 395 #if FFECOM_GCC_INCLUDE
 396 static void ffecom_file_ (const char *name);
 397 static void ffecom_initialize_char_syntax_ (void);
 398 static void ffecom_close_include_ (FILE *f);
 399 static int ffecom_decode_include_option_ (char *spec);
 400 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 401                                    ffewhereColumn c);
 402 #endif  /* FFECOM_GCC_INCLUDE */
 403
 404 /* Static objects accessed by functions in this module. */
 405
 406 static ffesymbol ffecom_primary_entry_ = NULL;
 407 static ffesymbol ffecom_nested_entry_ = NULL;
 408 static ffeinfoKind ffecom_primary_entry_kind_;
 409 static bool ffecom_primary_entry_is_proc_;
 410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 411 static tree ffecom_outer_function_decl_;
 412 static tree ffecom_previous_function_decl_;
 413 static tree ffecom_which_entrypoint_decl_;
 414 static tree ffecom_float_zero_ = NULL_TREE;
 415 static tree ffecom_float_half_ = NULL_TREE;
 416 static tree ffecom_double_zero_ = NULL_TREE;
 417 static tree ffecom_double_half_ = NULL_TREE;
 418 static tree ffecom_func_result_;/* For functions. */
 419 static tree ffecom_func_length_;/* For CHARACTER fns. */
 420 static ffebld ffecom_list_blockdata_;
 421 static ffebld ffecom_list_common_;
 422 static ffebld ffecom_master_arglist_;
 423 static ffeinfoBasictype ffecom_master_bt_;
 424 static ffeinfoKindtype ffecom_master_kt_;
 425 static ffetargetCharacterSize ffecom_master_size_;
 426 static int ffecom_num_fns_ = 0;
 427 static int ffecom_num_entrypoints_ = 0;
 428 static bool ffecom_is_altreturning_ = FALSE;
 429 static tree ffecom_multi_type_node_;
 430 static tree ffecom_multi_retval_;
 431 static tree
 432   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 433 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 434 static bool ffecom_doing_entry_ = FALSE;
 435 static bool ffecom_transform_only_dummies_ = FALSE;
 436 static int ffecom_typesize_pointer_;
 437 static int ffecom_typesize_integer1_;
 438
 439 /* Holds pointer-to-function expressions.  */
 440
 441 static tree ffecom_gfrt_[FFECOM_gfrt]
 442 =
 443 {
 444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 445 #include "com-rt.def"
 446 #undef DEFGFRT
 447 };
 448
 449 /* Holds the external names of the functions.  */
 450
 451 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 452 =
 453 {
 454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 455 #include "com-rt.def"
 456 #undef DEFGFRT
 457 };
 458
 459 /* Whether the function returns.  */
 460
 461 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 462 =
 463 {
 464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 465 #include "com-rt.def"
 466 #undef DEFGFRT
 467 };
 468
 469 /* Whether the function returns type complex.  */
 470
 471 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 472 =
 473 {
 474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 475 #include "com-rt.def"
 476 #undef DEFGFRT
 477 };
 478
 479 /* Whether the function is const
 480    (i.e., has no side effects and only depends on its arguments).  */
 481
 482 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 483 =
 484 {
 485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 486 #include "com-rt.def"
 487 #undef DEFGFRT
 488 };
 489
 490 /* Type code for the function return value.  */
 491
 492 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 493 =
 494 {
 495 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 496 #include "com-rt.def"
 497 #undef DEFGFRT
 498 };
 499
 500 /* String of codes for the function's arguments.  */
 501
 502 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 503 =
 504 {
 505 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 506 #include "com-rt.def"
 507 #undef DEFGFRT
 508 };
 509 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 510
 511 /* Internal macros. */
 512
 513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 514
 515 /* We let tm.h override the types used here, to handle trivial differences
 516    such as the choice of unsigned int or long unsigned int for size_t.
 517    When machines start needing nontrivial differences in the size type,
 518    it would be best to do something here to figure out automatically
 519    from other information what type to use.  */
 520
 521 #ifndef SIZE_TYPE
 522 #define SIZE_TYPE "long unsigned int"
 523 #endif
 524
 525 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 526 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 527 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 528 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 529
 530 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 531 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 532
 533 /* For each binding contour we allocate a binding_level structure
 534  * which records the names defined in that contour.
 535  * Contours include:
 536  *  0) the global one
 537  *  1) one for each function definition,
 538  *     where internal declarations of the parameters appear.
 539  *
 540  * The current meaning of a name can be found by searching the levels from
 541  * the current one out to the global one.
 542  */
 543
 544 /* Note that the information in the `names' component of the global contour
 545    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 546
 547 struct binding_level
 548   {
 549     /* A chain of _DECL nodes for all variables, constants, functions,
 550        and typedef types.  These are in the reverse of the order supplied.
 551      */
 552     tree names;
 553
 554     /* For each level (except not the global one),
 555        a chain of BLOCK nodes for all the levels
 556        that were entered and exited one level down.  */
 557     tree blocks;
 558
 559     /* The BLOCK node for this level, if one has been preallocated.
 560        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 561     tree this_block;
 562
 563     /* The binding level which this one is contained in (inherits from).  */
 564     struct binding_level *level_chain;
 565
 566     /* 0: no ffecom_prepare_* functions called at this level yet;
 567        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 568        2: ffecom_prepare_end called.  */
 569     int prep_state;
 570   };
 571
 572 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 573
 574 /* The binding level currently in effect.  */
 575
 576 static struct binding_level *current_binding_level;
 577
 578 /* A chain of binding_level structures awaiting reuse.  */
 579
 580 static struct binding_level *free_binding_level;
 581
 582 /* The outermost binding level, for names of file scope.
 583    This is created when the compiler is started and exists
 584    through the entire run.  */
 585
 586 static struct binding_level *global_binding_level;
 587
 588 /* Binding level structures are initialized by copying this one.  */
 589
 590 static struct binding_level clear_binding_level
 591 =
 592 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 593
 594 /* Language-dependent contents of an identifier.  */
 595
 596 struct lang_identifier
 597   {
 598     struct tree_identifier ignore;
 599     tree global_value, local_value, label_value;
 600     bool invented;
 601   };
 602
 603 /* Macros for access to language-specific slots in an identifier.  */
 604 /* Each of these slots contains a DECL node or null.  */
 605
 606 /* This represents the value which the identifier has in the
 607    file-scope namespace.  */
 608 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 609   (((struct lang_identifier *)(NODE))->global_value)
 610 /* This represents the value which the identifier has in the current
 611    scope.  */
 612 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 613   (((struct lang_identifier *)(NODE))->local_value)
 614 /* This represents the value which the identifier has as a label in
 615    the current label scope.  */
 616 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 617   (((struct lang_identifier *)(NODE))->label_value)
 618 /* This is nonzero if the identifier was "made up" by g77 code.  */
 619 #define IDENTIFIER_INVENTED(NODE)       \
 620   (((struct lang_identifier *)(NODE))->invented)
 621
 622 /* In identifiers, C uses the following fields in a special way:
 623    TREE_PUBLIC        to record that there was a previous local extern decl.
 624    TREE_USED          to record that such a decl was used.
 625    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 626
 627 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 628    that have names.  Here so we can clear out their names' definitions
 629    at the end of the function.  */
 630
 631 static tree named_labels;
 632
 633 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 634
 635 static tree shadowed_labels;
 636
 637 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 638 \f
 639 /* Return the subscript expression, modified to do range-checking.
 640
 641    `array' is the array to be checked against.
 642    `element' is the subscript expression to check.
 643    `dim' is the dimension number (starting at 0).
 644    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 645 */
 646
 647 static tree
 648 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 649                          const char *array_name)
 650 {
 651   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 652   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 653   tree cond;
 654   tree die;
 655   tree args;
 656
 657   if (element == error_mark_node)
 658     return element;
 659
 660   if (TREE_TYPE (low) != TREE_TYPE (element))
 661     {
 662       if (TYPE_PRECISION (TREE_TYPE (low))
 663           > TYPE_PRECISION (TREE_TYPE (element)))
 664         element = convert (TREE_TYPE (low), element);
 665       else
 666         {
 667           low = convert (TREE_TYPE (element), low);
 668           if (high)
 669             high = convert (TREE_TYPE (element), high);
 670         }
 671     }
 672
 673   element = ffecom_save_tree (element);
 674   cond = ffecom_2 (LE_EXPR, integer_type_node,
 675                    low,
 676                    element);
 677   if (high)
 678     {
 679       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 680                        cond,
 681                        ffecom_2 (LE_EXPR, integer_type_node,
 682                                  element,
 683                                  high));
 684     }
 685
 686   {
 687     int len;
 688     char *proc;
 689     char *var;
 690     tree arg3;
 691     tree arg2;
 692     tree arg1;
 693     tree arg4;
 694
 695     switch (total_dims)
 696       {
 697       case 0:
 698         var = concat (array_name, "[", (dim ? "end" : "start"),
 699                       "-substring]", NULL);
 700         len = strlen (var) + 1;
 701         arg1 = build_string (len, var);
 702         free (var);
 703         break;
 704
 705       case 1:
 706         len = strlen (array_name) + 1;
 707         arg1 = build_string (len, array_name);
 708         break;
 709
 710       default:
 711         var = xmalloc (strlen (array_name) + 40);
 712         sprintf (var, "%s[subscript-%d-of-%d]",
 713                  array_name,
 714                  dim + 1, total_dims);
 715         len = strlen (var) + 1;
 716         arg1 = build_string (len, var);
 717         free (var);
 718         break;
 719       }
 720
 721     TREE_TYPE (arg1)
 722       = build_type_variant (build_array_type (char_type_node,
 723                                               build_range_type
 724                                               (integer_type_node,
 725                                                integer_one_node,
 726                                                build_int_2 (len, 0))),
 727                             1, 0);
 728     TREE_CONSTANT (arg1) = 1;
 729     TREE_STATIC (arg1) = 1;
 730     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 731                      arg1);
 732
 733     /* s_rnge adds one to the element to print it, so bias against
 734        that -- want to print a faithful *subscript* value.  */
 735     arg2 = convert (ffecom_f2c_ftnint_type_node,
 736                     ffecom_2 (MINUS_EXPR,
 737                               TREE_TYPE (element),
 738                               element,
 739                               convert (TREE_TYPE (element),
 740                                        integer_one_node)));
 741
 742     proc = concat (input_filename, "/",
 743                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 744                    NULL);
 745     len = strlen (proc) + 1;
 746     arg3 = build_string (len, proc);
 747
 748     free (proc);
 749
 750     TREE_TYPE (arg3)
 751       = build_type_variant (build_array_type (char_type_node,
 752                                               build_range_type
 753                                               (integer_type_node,
 754                                                integer_one_node,
 755                                                build_int_2 (len, 0))),
 756                             1, 0);
 757     TREE_CONSTANT (arg3) = 1;
 758     TREE_STATIC (arg3) = 1;
 759     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 760                      arg3);
 761
 762     arg4 = convert (ffecom_f2c_ftnint_type_node,
 763                     build_int_2 (lineno, 0));
 764
 765     arg1 = build_tree_list (NULL_TREE, arg1);
 766     arg2 = build_tree_list (NULL_TREE, arg2);
 767     arg3 = build_tree_list (NULL_TREE, arg3);
 768     arg4 = build_tree_list (NULL_TREE, arg4);
 769     TREE_CHAIN (arg3) = arg4;
 770     TREE_CHAIN (arg2) = arg3;
 771     TREE_CHAIN (arg1) = arg2;
 772
 773     args = arg1;
 774   }
 775   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 776                           args, NULL_TREE);
 777   TREE_SIDE_EFFECTS (die) = 1;
 778
 779   element = ffecom_3 (COND_EXPR,
 780                       TREE_TYPE (element),
 781                       cond,
 782                       element,
 783                       die);
 784
 785   return element;
 786 }
 787
 788 /* Return the computed element of an array reference.
 789
 790    `item' is NULL_TREE, or the transformed pointer to the array.
 791    `expr' is the original opARRAYREF expression, which is transformed
 792      if `item' is NULL_TREE.
 793    `want_ptr' is non-zero if a pointer to the element, instead of
 794      the element itself, is to be returned.  */
 795
 796 static tree
 797 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 798 {
 799   ffebld dims[FFECOM_dimensionsMAX];
 800   int i;
 801   int total_dims;
 802   int flatten = ffe_is_flatten_arrays ();
 803   int need_ptr;
 804   tree array;
 805   tree element;
 806   tree tree_type;
 807   tree tree_type_x;
 808   const char *array_name;
 809   ffetype type;
 810   ffebld list;
 811
 812   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 813     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 814   else
 815     array_name = "[expr?]";
 816
 817   /* Build up ARRAY_REFs in reverse order (since we're column major
 818      here in Fortran land). */
 819
 820   for (i = 0, list = ffebld_right (expr);
 821        list != NULL;
 822        ++i, list = ffebld_trail (list))
 823     {
 824       dims[i] = ffebld_head (list);
 825       type = ffeinfo_type (ffebld_basictype (dims[i]),
 826                            ffebld_kindtype (dims[i]));
 827       if (! flatten
 828           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 829           && ffetype_size (type) > ffecom_typesize_integer1_)
 830         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 831            pointers and 32-bit integers.  Do the full 64-bit pointer
 832            arithmetic, for codes using arrays for nonstandard heap-like
 833            work.  */
 834         flatten = 1;
 835     }
 836
 837   total_dims = i;
 838
 839   need_ptr = want_ptr || flatten;
 840
 841   if (! item)
 842     {
 843       if (need_ptr)
 844         item = ffecom_ptr_to_expr (ffebld_left (expr));
 845       else
 846         item = ffecom_expr (ffebld_left (expr));
 847
 848       if (item == error_mark_node)
 849         return item;
 850
 851       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 852           && ! mark_addressable (item))
 853         return error_mark_node;
 854     }
 855
 856   if (item == error_mark_node)
 857     return item;
 858
 859   if (need_ptr)
 860     {
 861       tree min;
 862
 863       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 864            i >= 0;
 865            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 866         {
 867           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 868           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 869           if (flag_bounds_check)
 870             element = ffecom_subscript_check_ (array, element, i, total_dims,
 871                                                array_name);
 872           if (element == error_mark_node)
 873             return element;
 874
 875           /* Widen integral arithmetic as desired while preserving
 876              signedness.  */
 877           tree_type = TREE_TYPE (element);
 878           tree_type_x = tree_type;
 879           if (tree_type
 880               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 881               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 882             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 883
 884           if (TREE_TYPE (min) != tree_type_x)
 885             min = convert (tree_type_x, min);
 886           if (TREE_TYPE (element) != tree_type_x)
 887             element = convert (tree_type_x, element);
 888
 889           item = ffecom_2 (PLUS_EXPR,
 890                            build_pointer_type (TREE_TYPE (array)),
 891                            item,
 892                            size_binop (MULT_EXPR,
 893                                        size_in_bytes (TREE_TYPE (array)),
 894                                        convert (sizetype,
 895                                                 fold (build (MINUS_EXPR,
 896                                                              tree_type_x,
 897                                                              element, min)))));
 898         }
 899       if (! want_ptr)
 900         {
 901           item = ffecom_1 (INDIRECT_REF,
 902                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 903                            item);
 904         }
 905     }
 906   else
 907     {
 908       for (--i;
 909            i >= 0;
 910            --i)
 911         {
 912           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 913
 914           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 915           if (flag_bounds_check)
 916             element = ffecom_subscript_check_ (array, element, i, total_dims,
 917                                                array_name);
 918           if (element == error_mark_node)
 919             return element;
 920
 921           /* Widen integral arithmetic as desired while preserving
 922              signedness.  */
 923           tree_type = TREE_TYPE (element);
 924           tree_type_x = tree_type;
 925           if (tree_type
 926               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 927               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 928             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 929
 930           element = convert (tree_type_x, element);
 931
 932           item = ffecom_2 (ARRAY_REF,
 933                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 934                            item,
 935                            element);
 936         }
 937     }
 938
 939   return item;
 940 }
 941
 942 /* This is like gcc's stabilize_reference -- in fact, most of the code
 943    comes from that -- but it handles the situation where the reference
 944    is going to have its subparts picked at, and it shouldn't change
 945    (or trigger extra invocations of functions in the subtrees) due to
 946    this.  save_expr is a bit overzealous, because we don't need the
 947    entire thing calculated and saved like a temp.  So, for DECLs, no
 948    change is needed, because these are stable aggregates, and ARRAY_REF
 949    and such might well be stable too, but for things like calculations,
 950    we do need to calculate a snapshot of a value before picking at it.  */
 951
 952 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 953 static tree
 954 ffecom_stabilize_aggregate_ (tree ref)
 955 {
 956   tree result;
 957   enum tree_code code = TREE_CODE (ref);
 958
 959   switch (code)
 960     {
 961     case VAR_DECL:
 962     case PARM_DECL:
 963     case RESULT_DECL:
 964       /* No action is needed in this case.  */
 965       return ref;
 966
 967     case NOP_EXPR:
 968     case CONVERT_EXPR:
 969     case FLOAT_EXPR:
 970     case FIX_TRUNC_EXPR:
 971     case FIX_FLOOR_EXPR:
 972     case FIX_ROUND_EXPR:
 973     case FIX_CEIL_EXPR:
 974       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 975       break;
 976
 977     case INDIRECT_REF:
 978       result = build_nt (INDIRECT_REF,
 979                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 980       break;
 981
 982     case COMPONENT_REF:
 983       result = build_nt (COMPONENT_REF,
 984                          stabilize_reference (TREE_OPERAND (ref, 0)),
 985                          TREE_OPERAND (ref, 1));
 986       break;
 987
 988     case BIT_FIELD_REF:
 989       result = build_nt (BIT_FIELD_REF,
 990                          stabilize_reference (TREE_OPERAND (ref, 0)),
 991                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 992                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 993       break;
 994
 995     case ARRAY_REF:
 996       result = build_nt (ARRAY_REF,
 997                          stabilize_reference (TREE_OPERAND (ref, 0)),
 998                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
 999       break;
1000
1001     case COMPOUND_EXPR:
1002       result = build_nt (COMPOUND_EXPR,
1003                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1004                          stabilize_reference (TREE_OPERAND (ref, 1)));
1005       break;
1006
1007     case RTL_EXPR:
1008       abort ();
1009
1010
1011     default:
1012       return save_expr (ref);
1013
1014     case ERROR_MARK:
1015       return error_mark_node;
1016     }
1017
1018   TREE_TYPE (result) = TREE_TYPE (ref);
1019   TREE_READONLY (result) = TREE_READONLY (ref);
1020   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1021   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1022
1023   return result;
1024 }
1025 #endif
1026
1027 /* A rip-off of gcc's convert.c convert_to_complex function,
1028    reworked to handle complex implemented as C structures
1029    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1030
1031 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1032 static tree
1033 ffecom_convert_to_complex_ (tree type, tree expr)
1034 {
1035   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1036   tree subtype;
1037
1038   assert (TREE_CODE (type) == RECORD_TYPE);
1039
1040   subtype = TREE_TYPE (TYPE_FIELDS (type));
1041
1042   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1043     {
1044       expr = convert (subtype, expr);
1045       return ffecom_2 (COMPLEX_EXPR, type, expr,
1046                        convert (subtype, integer_zero_node));
1047     }
1048
1049   if (form == RECORD_TYPE)
1050     {
1051       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1052       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1053         return expr;
1054       else
1055         {
1056           expr = save_expr (expr);
1057           return ffecom_2 (COMPLEX_EXPR,
1058                            type,
1059                            convert (subtype,
1060                                     ffecom_1 (REALPART_EXPR,
1061                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1062                                               expr)),
1063                            convert (subtype,
1064                                     ffecom_1 (IMAGPART_EXPR,
1065                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1066                                               expr)));
1067         }
1068     }
1069
1070   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1071     error ("pointer value used where a complex was expected");
1072   else
1073     error ("aggregate value used where a complex was expected");
1074
1075   return ffecom_2 (COMPLEX_EXPR, type,
1076                    convert (subtype, integer_zero_node),
1077                    convert (subtype, integer_zero_node));
1078 }
1079 #endif
1080
1081 /* Like gcc's convert(), but crashes if widening might happen.  */
1082
1083 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1084 static tree
1085 ffecom_convert_narrow_ (type, expr)
1086      tree type, expr;
1087 {
1088   register tree e = expr;
1089   register enum tree_code code = TREE_CODE (type);
1090
1091   if (type == TREE_TYPE (e)
1092       || TREE_CODE (e) == ERROR_MARK)
1093     return e;
1094   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1095     return fold (build1 (NOP_EXPR, type, e));
1096   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1097       || code == ERROR_MARK)
1098     return error_mark_node;
1099   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1100     {
1101       assert ("void value not ignored as it ought to be" == NULL);
1102       return error_mark_node;
1103     }
1104   assert (code != VOID_TYPE);
1105   if ((code != RECORD_TYPE)
1106       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1107     assert ("converting COMPLEX to REAL" == NULL);
1108   assert (code != ENUMERAL_TYPE);
1109   if (code == INTEGER_TYPE)
1110     {
1111       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1112                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1113               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1114                   && (TYPE_PRECISION (type)
1115                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1116       return fold (convert_to_integer (type, e));
1117     }
1118   if (code == POINTER_TYPE)
1119     {
1120       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1121       return fold (convert_to_pointer (type, e));
1122     }
1123   if (code == REAL_TYPE)
1124     {
1125       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1126       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1127       return fold (convert_to_real (type, e));
1128     }
1129   if (code == COMPLEX_TYPE)
1130     {
1131       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1132       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1133       return fold (convert_to_complex (type, e));
1134     }
1135   if (code == RECORD_TYPE)
1136     {
1137       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1138       /* Check that at least the first field name agrees.  */
1139       assert (DECL_NAME (TYPE_FIELDS (type))
1140               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1141       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1142               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1143       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1144           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1145         return e;
1146       return fold (ffecom_convert_to_complex_ (type, e));
1147     }
1148
1149   assert ("conversion to non-scalar type requested" == NULL);
1150   return error_mark_node;
1151 }
1152 #endif
1153
1154 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1155
1156 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1157 static tree
1158 ffecom_convert_widen_ (type, expr)
1159      tree type, expr;
1160 {
1161   register tree e = expr;
1162   register enum tree_code code = TREE_CODE (type);
1163
1164   if (type == TREE_TYPE (e)
1165       || TREE_CODE (e) == ERROR_MARK)
1166     return e;
1167   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1168     return fold (build1 (NOP_EXPR, type, e));
1169   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1170       || code == ERROR_MARK)
1171     return error_mark_node;
1172   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1173     {
1174       assert ("void value not ignored as it ought to be" == NULL);
1175       return error_mark_node;
1176     }
1177   assert (code != VOID_TYPE);
1178   if ((code != RECORD_TYPE)
1179       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1180     assert ("narrowing COMPLEX to REAL" == NULL);
1181   assert (code != ENUMERAL_TYPE);
1182   if (code == INTEGER_TYPE)
1183     {
1184       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1185                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1186               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1187                   && (TYPE_PRECISION (type)
1188                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1189       return fold (convert_to_integer (type, e));
1190     }
1191   if (code == POINTER_TYPE)
1192     {
1193       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1194       return fold (convert_to_pointer (type, e));
1195     }
1196   if (code == REAL_TYPE)
1197     {
1198       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1199       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1200       return fold (convert_to_real (type, e));
1201     }
1202   if (code == COMPLEX_TYPE)
1203     {
1204       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1205       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1206       return fold (convert_to_complex (type, e));
1207     }
1208   if (code == RECORD_TYPE)
1209     {
1210       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1211       /* Check that at least the first field name agrees.  */
1212       assert (DECL_NAME (TYPE_FIELDS (type))
1213               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1214       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1215               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1216       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1217           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1218         return e;
1219       return fold (ffecom_convert_to_complex_ (type, e));
1220     }
1221
1222   assert ("conversion to non-scalar type requested" == NULL);
1223   return error_mark_node;
1224 }
1225 #endif
1226
1227 /* Handles making a COMPLEX type, either the standard
1228    (but buggy?) gbe way, or the safer (but less elegant?)
1229    f2c way.  */
1230
1231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1232 static tree
1233 ffecom_make_complex_type_ (tree subtype)
1234 {
1235   tree type;
1236   tree realfield;
1237   tree imagfield;
1238
1239   if (ffe_is_emulate_complex ())
1240     {
1241       type = make_node (RECORD_TYPE);
1242       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1243       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1244       TYPE_FIELDS (type) = realfield;
1245       layout_type (type);
1246     }
1247   else
1248     {
1249       type = make_node (COMPLEX_TYPE);
1250       TREE_TYPE (type) = subtype;
1251       layout_type (type);
1252     }
1253
1254   return type;
1255 }
1256 #endif
1257
1258 /* Chooses either the gbe or the f2c way to build a
1259    complex constant.  */
1260
1261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1262 static tree
1263 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1264 {
1265   tree bothparts;
1266
1267   if (ffe_is_emulate_complex ())
1268     {
1269       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1270       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1271       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1272     }
1273   else
1274     {
1275       bothparts = build_complex (type, realpart, imagpart);
1276     }
1277
1278   return bothparts;
1279 }
1280 #endif
1281
1282 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1283 static tree
1284 ffecom_arglist_expr_ (const char *c, ffebld expr)
1285 {
1286   tree list;
1287   tree *plist = &list;
1288   tree trail = NULL_TREE;       /* Append char length args here. */
1289   tree *ptrail = &trail;
1290   tree length;
1291   ffebld exprh;
1292   tree item;
1293   bool ptr = FALSE;
1294   tree wanted = NULL_TREE;
1295   static char zed[] = "0";
1296
1297   if (c == NULL)
1298     c = &zed[0];
1299
1300   while (expr != NULL)
1301     {
1302       if (*c != '\0')
1303         {
1304           ptr = FALSE;
1305           if (*c == '&')
1306             {
1307               ptr = TRUE;
1308               ++c;
1309             }
1310           switch (*(c++))
1311             {
1312             case '\0':
1313               ptr = TRUE;
1314               wanted = NULL_TREE;
1315               break;
1316
1317             case 'a':
1318               assert (ptr);
1319               wanted = NULL_TREE;
1320               break;
1321
1322             case 'c':
1323               wanted = ffecom_f2c_complex_type_node;
1324               break;
1325
1326             case 'd':
1327               wanted = ffecom_f2c_doublereal_type_node;
1328               break;
1329
1330             case 'e':
1331               wanted = ffecom_f2c_doublecomplex_type_node;
1332               break;
1333
1334             case 'f':
1335               wanted = ffecom_f2c_real_type_node;
1336               break;
1337
1338             case 'i':
1339               wanted = ffecom_f2c_integer_type_node;
1340               break;
1341
1342             case 'j':
1343               wanted = ffecom_f2c_longint_type_node;
1344               break;
1345
1346             default:
1347               assert ("bad argstring code" == NULL);
1348               wanted = NULL_TREE;
1349               break;
1350             }
1351         }
1352
1353       exprh = ffebld_head (expr);
1354       if (exprh == NULL)
1355         wanted = NULL_TREE;
1356
1357       if ((wanted == NULL_TREE)
1358           || (ptr
1359               && (TYPE_MODE
1360                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1361                    [ffeinfo_kindtype (ffebld_info (exprh))])
1362                    == TYPE_MODE (wanted))))
1363         *plist
1364           = build_tree_list (NULL_TREE,
1365                              ffecom_arg_ptr_to_expr (exprh,
1366                                                      &length));
1367       else
1368         {
1369           item = ffecom_arg_expr (exprh, &length);
1370           item = ffecom_convert_widen_ (wanted, item);
1371           if (ptr)
1372             {
1373               item = ffecom_1 (ADDR_EXPR,
1374                                build_pointer_type (TREE_TYPE (item)),
1375                                item);
1376             }
1377           *plist
1378             = build_tree_list (NULL_TREE,
1379                                item);
1380         }
1381
1382       plist = &TREE_CHAIN (*plist);
1383       expr = ffebld_trail (expr);
1384       if (length != NULL_TREE)
1385         {
1386           *ptrail = build_tree_list (NULL_TREE, length);
1387           ptrail = &TREE_CHAIN (*ptrail);
1388         }
1389     }
1390
1391   /* We've run out of args in the call; if the implementation expects
1392      more, supply null pointers for them, which the implementation can
1393      check to see if an arg was omitted. */
1394
1395   while (*c != '\0' && *c != '0')
1396     {
1397       if (*c == '&')
1398         ++c;
1399       else
1400         assert ("missing arg to run-time routine!" == NULL);
1401
1402       switch (*(c++))
1403         {
1404         case '\0':
1405         case 'a':
1406         case 'c':
1407         case 'd':
1408         case 'e':
1409         case 'f':
1410         case 'i':
1411         case 'j':
1412           break;
1413
1414         default:
1415           assert ("bad arg string code" == NULL);
1416           break;
1417         }
1418       *plist
1419         = build_tree_list (NULL_TREE,
1420                            null_pointer_node);
1421       plist = &TREE_CHAIN (*plist);
1422     }
1423
1424   *plist = trail;
1425
1426   return list;
1427 }
1428 #endif
1429
1430 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1431 static tree
1432 ffecom_widest_expr_type_ (ffebld list)
1433 {
1434   ffebld item;
1435   ffebld widest = NULL;
1436   ffetype type;
1437   ffetype widest_type = NULL;
1438   tree t;
1439
1440   for (; list != NULL; list = ffebld_trail (list))
1441     {
1442       item = ffebld_head (list);
1443       if (item == NULL)
1444         continue;
1445       if ((widest != NULL)
1446           && (ffeinfo_basictype (ffebld_info (item))
1447               != ffeinfo_basictype (ffebld_info (widest))))
1448         continue;
1449       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1450                            ffeinfo_kindtype (ffebld_info (item)));
1451       if ((widest == FFEINFO_kindtypeNONE)
1452           || (ffetype_size (type)
1453               > ffetype_size (widest_type)))
1454         {
1455           widest = item;
1456           widest_type = type;
1457         }
1458     }
1459
1460   assert (widest != NULL);
1461   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1462     [ffeinfo_kindtype (ffebld_info (widest))];
1463   assert (t != NULL_TREE);
1464   return t;
1465 }
1466 #endif
1467
1468 /* Check whether a partial overlap between two expressions is possible.
1469
1470    Can *starting* to write a portion of expr1 change the value
1471    computed (perhaps already, *partially*) by expr2?
1472
1473    Currently, this is a concern only for a COMPLEX expr1.  But if it
1474    isn't in COMMON or local EQUIVALENCE, since we don't support
1475    aliasing of arguments, it isn't a concern.  */
1476
1477 static bool
1478 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1479 {
1480   ffesymbol sym;
1481   ffestorag st;
1482
1483   switch (ffebld_op (expr1))
1484     {
1485     case FFEBLD_opSYMTER:
1486       sym = ffebld_symter (expr1);
1487       break;
1488
1489     case FFEBLD_opARRAYREF:
1490       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1491         return FALSE;
1492       sym = ffebld_symter (ffebld_left (expr1));
1493       break;
1494
1495     default:
1496       return FALSE;
1497     }
1498
1499   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1500       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1501           || ! (st = ffesymbol_storage (sym))
1502           || ! ffestorag_parent (st)))
1503     return FALSE;
1504
1505   /* It's in COMMON or local EQUIVALENCE.  */
1506
1507   return TRUE;
1508 }
1509
1510 /* Check whether dest and source might overlap.  ffebld versions of these
1511    might or might not be passed, will be NULL if not.
1512
1513    The test is really whether source_tree is modifiable and, if modified,
1514    might overlap destination such that the value(s) in the destination might
1515    change before it is finally modified.  dest_* are the canonized
1516    destination itself.  */
1517
1518 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1519 static bool
1520 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1521                  tree source_tree, ffebld source UNUSED,
1522                  bool scalar_arg)
1523 {
1524   tree source_decl;
1525   tree source_offset;
1526   tree source_size;
1527   tree t;
1528
1529   if (source_tree == NULL_TREE)
1530     return FALSE;
1531
1532   switch (TREE_CODE (source_tree))
1533     {
1534     case ERROR_MARK:
1535     case IDENTIFIER_NODE:
1536     case INTEGER_CST:
1537     case REAL_CST:
1538     case COMPLEX_CST:
1539     case STRING_CST:
1540     case CONST_DECL:
1541     case VAR_DECL:
1542     case RESULT_DECL:
1543     case FIELD_DECL:
1544     case MINUS_EXPR:
1545     case MULT_EXPR:
1546     case TRUNC_DIV_EXPR:
1547     case CEIL_DIV_EXPR:
1548     case FLOOR_DIV_EXPR:
1549     case ROUND_DIV_EXPR:
1550     case TRUNC_MOD_EXPR:
1551     case CEIL_MOD_EXPR:
1552     case FLOOR_MOD_EXPR:
1553     case ROUND_MOD_EXPR:
1554     case RDIV_EXPR:
1555     case EXACT_DIV_EXPR:
1556     case FIX_TRUNC_EXPR:
1557     case FIX_CEIL_EXPR:
1558     case FIX_FLOOR_EXPR:
1559     case FIX_ROUND_EXPR:
1560     case FLOAT_EXPR:
1561     case NEGATE_EXPR:
1562     case MIN_EXPR:
1563     case MAX_EXPR:
1564     case ABS_EXPR:
1565     case FFS_EXPR:
1566     case LSHIFT_EXPR:
1567     case RSHIFT_EXPR:
1568     case LROTATE_EXPR:
1569     case RROTATE_EXPR:
1570     case BIT_IOR_EXPR:
1571     case BIT_XOR_EXPR:
1572     case BIT_AND_EXPR:
1573     case BIT_ANDTC_EXPR:
1574     case BIT_NOT_EXPR:
1575     case TRUTH_ANDIF_EXPR:
1576     case TRUTH_ORIF_EXPR:
1577     case TRUTH_AND_EXPR:
1578     case TRUTH_OR_EXPR:
1579     case TRUTH_XOR_EXPR:
1580     case TRUTH_NOT_EXPR:
1581     case LT_EXPR:
1582     case LE_EXPR:
1583     case GT_EXPR:
1584     case GE_EXPR:
1585     case EQ_EXPR:
1586     case NE_EXPR:
1587     case COMPLEX_EXPR:
1588     case CONJ_EXPR:
1589     case REALPART_EXPR:
1590     case IMAGPART_EXPR:
1591     case LABEL_EXPR:
1592     case COMPONENT_REF:
1593       return FALSE;
1594
1595     case COMPOUND_EXPR:
1596       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1597                               TREE_OPERAND (source_tree, 1), NULL,
1598                               scalar_arg);
1599
1600     case MODIFY_EXPR:
1601       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1602                               TREE_OPERAND (source_tree, 0), NULL,
1603                               scalar_arg);
1604
1605     case CONVERT_EXPR:
1606     case NOP_EXPR:
1607     case NON_LVALUE_EXPR:
1608     case PLUS_EXPR:
1609       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1610         return TRUE;
1611
1612       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1613                                  source_tree);
1614       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1615       break;
1616
1617     case COND_EXPR:
1618       return
1619         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1620                          TREE_OPERAND (source_tree, 1), NULL,
1621                          scalar_arg)
1622           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1623                               TREE_OPERAND (source_tree, 2), NULL,
1624                               scalar_arg);
1625
1626
1627     case ADDR_EXPR:
1628       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1629                                  &source_size,
1630                                  TREE_OPERAND (source_tree, 0));
1631       break;
1632
1633     case PARM_DECL:
1634       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1635         return TRUE;
1636
1637       source_decl = source_tree;
1638       source_offset = bitsize_zero_node;
1639       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1640       break;
1641
1642     case SAVE_EXPR:
1643     case REFERENCE_EXPR:
1644     case PREDECREMENT_EXPR:
1645     case PREINCREMENT_EXPR:
1646     case POSTDECREMENT_EXPR:
1647     case POSTINCREMENT_EXPR:
1648     case INDIRECT_REF:
1649     case ARRAY_REF:
1650     case CALL_EXPR:
1651     default:
1652       return TRUE;
1653     }
1654
1655   /* Come here when source_decl, source_offset, and source_size filled
1656      in appropriately.  */
1657
1658   if (source_decl == NULL_TREE)
1659     return FALSE;               /* No decl involved, so no overlap. */
1660
1661   if (source_decl != dest_decl)
1662     return FALSE;               /* Different decl, no overlap. */
1663
1664   if (TREE_CODE (dest_size) == ERROR_MARK)
1665     return TRUE;                /* Assignment into entire assumed-size
1666                                    array?  Shouldn't happen.... */
1667
1668   t = ffecom_2 (LE_EXPR, integer_type_node,
1669                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1670                           dest_offset,
1671                           convert (TREE_TYPE (dest_offset),
1672                                    dest_size)),
1673                 convert (TREE_TYPE (dest_offset),
1674                          source_offset));
1675
1676   if (integer_onep (t))
1677     return FALSE;               /* Destination precedes source. */
1678
1679   if (!scalar_arg
1680       || (source_size == NULL_TREE)
1681       || (TREE_CODE (source_size) == ERROR_MARK)
1682       || integer_zerop (source_size))
1683     return TRUE;                /* No way to tell if dest follows source. */
1684
1685   t = ffecom_2 (LE_EXPR, integer_type_node,
1686                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1687                           source_offset,
1688                           convert (TREE_TYPE (source_offset),
1689                                    source_size)),
1690                 convert (TREE_TYPE (source_offset),
1691                          dest_offset));
1692
1693   if (integer_onep (t))
1694     return FALSE;               /* Destination follows source. */
1695
1696   return TRUE;          /* Destination and source overlap. */
1697 }
1698 #endif
1699
1700 /* Check whether dest might overlap any of a list of arguments or is
1701    in a COMMON area the callee might know about (and thus modify).  */
1702
1703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1704 static bool
1705 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1706                           tree args, tree callee_commons,
1707                           bool scalar_args)
1708 {
1709   tree arg;
1710   tree dest_decl;
1711   tree dest_offset;
1712   tree dest_size;
1713
1714   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1715                              dest_tree);
1716
1717   if (dest_decl == NULL_TREE)
1718     return FALSE;               /* Seems unlikely! */
1719
1720   /* If the decl cannot be determined reliably, or if its in COMMON
1721      and the callee isn't known to not futz with COMMON via other
1722      means, overlap might happen.  */
1723
1724   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1725       || ((callee_commons != NULL_TREE)
1726           && TREE_PUBLIC (dest_decl)))
1727     return TRUE;
1728
1729   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1730     {
1731       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1732           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1733                               arg, NULL, scalar_args))
1734         return TRUE;
1735     }
1736
1737   return FALSE;
1738 }
1739 #endif
1740
1741 /* Build a string for a variable name as used by NAMELIST.  This means that
1742    if we're using the f2c library, we build an uppercase string, since
1743    f2c does this.  */
1744
1745 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1746 static tree
1747 ffecom_build_f2c_string_ (int i, const char *s)
1748 {
1749   if (!ffe_is_f2c_library ())
1750     return build_string (i, s);
1751
1752   {
1753     char *tmp;
1754     const char *p;
1755     char *q;
1756     char space[34];
1757     tree t;
1758
1759     if (((size_t) i) > ARRAY_SIZE (space))
1760       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1761     else
1762       tmp = &space[0];
1763
1764     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1765       *q = TOUPPER (*p);
1766     *q = '\0';
1767
1768     t = build_string (i, tmp);
1769
1770     if (((size_t) i) > ARRAY_SIZE (space))
1771       malloc_kill_ks (malloc_pool_image (), tmp, i);
1772
1773     return t;
1774   }
1775 }
1776
1777 #endif
1778 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1779    type to just get whatever the function returns), handling the
1780    f2c value-returning convention, if required, by prepending
1781    to the arglist a pointer to a temporary to receive the return value.  */
1782
1783 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1784 static tree
1785 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1786               tree type, tree args, tree dest_tree,
1787               ffebld dest, bool *dest_used, tree callee_commons,
1788               bool scalar_args, tree hook)
1789 {
1790   tree item;
1791   tree tempvar;
1792
1793   if (dest_used != NULL)
1794     *dest_used = FALSE;
1795
1796   if (is_f2c_complex)
1797     {
1798       if ((dest_used == NULL)
1799           || (dest == NULL)
1800           || (ffeinfo_basictype (ffebld_info (dest))
1801               != FFEINFO_basictypeCOMPLEX)
1802           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1803           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1804           || ffecom_args_overlapping_ (dest_tree, dest, args,
1805                                        callee_commons,
1806                                        scalar_args))
1807         {
1808 #ifdef HOHO
1809           tempvar = ffecom_make_tempvar (ffecom_tree_type
1810                                          [FFEINFO_basictypeCOMPLEX][kt],
1811                                          FFETARGET_charactersizeNONE,
1812                                          -1);
1813 #else
1814           tempvar = hook;
1815           assert (tempvar);
1816 #endif
1817         }
1818       else
1819         {
1820           *dest_used = TRUE;
1821           tempvar = dest_tree;
1822           type = NULL_TREE;
1823         }
1824
1825       item
1826         = build_tree_list (NULL_TREE,
1827                            ffecom_1 (ADDR_EXPR,
1828                                      build_pointer_type (TREE_TYPE (tempvar)),
1829                                      tempvar));
1830       TREE_CHAIN (item) = args;
1831
1832       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1833                         item, NULL_TREE);
1834
1835       if (tempvar != dest_tree)
1836         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1837     }
1838   else
1839     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1840                       args, NULL_TREE);
1841
1842   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1843     item = ffecom_convert_narrow_ (type, item);
1844
1845   return item;
1846 }
1847 #endif
1848
1849 /* Given two arguments, transform them and make a call to the given
1850    function via ffecom_call_.  */
1851
1852 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1853 static tree
1854 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1855                     tree type, ffebld left, ffebld right,
1856                     tree dest_tree, ffebld dest, bool *dest_used,
1857                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1858 {
1859   tree left_tree;
1860   tree right_tree;
1861   tree left_length;
1862   tree right_length;
1863
1864   if (ref)
1865     {
1866       /* Pass arguments by reference.  */
1867       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1868       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1869     }
1870   else
1871     {
1872       /* Pass arguments by value.  */
1873       left_tree = ffecom_arg_expr (left, &left_length);
1874       right_tree = ffecom_arg_expr (right, &right_length);
1875     }
1876
1877
1878   left_tree = build_tree_list (NULL_TREE, left_tree);
1879   right_tree = build_tree_list (NULL_TREE, right_tree);
1880   TREE_CHAIN (left_tree) = right_tree;
1881
1882   if (left_length != NULL_TREE)
1883     {
1884       left_length = build_tree_list (NULL_TREE, left_length);
1885       TREE_CHAIN (right_tree) = left_length;
1886     }
1887
1888   if (right_length != NULL_TREE)
1889     {
1890       right_length = build_tree_list (NULL_TREE, right_length);
1891       if (left_length != NULL_TREE)
1892         TREE_CHAIN (left_length) = right_length;
1893       else
1894         TREE_CHAIN (right_tree) = right_length;
1895     }
1896
1897   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1898                        dest_tree, dest, dest_used, callee_commons,
1899                        scalar_args, hook);
1900 }
1901 #endif
1902
1903 /* Return ptr/length args for char subexpression
1904
1905    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1906    subexpressions by constructing the appropriate trees for the ptr-to-
1907    character-text and length-of-character-text arguments in a calling
1908    sequence.
1909
1910    Note that if with_null is TRUE, and the expression is an opCONTER,
1911    a null byte is appended to the string.  */
1912
1913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1914 static void
1915 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1916 {
1917   tree item;
1918   tree high;
1919   ffetargetCharacter1 val;
1920   ffetargetCharacterSize newlen;
1921
1922   switch (ffebld_op (expr))
1923     {
1924     case FFEBLD_opCONTER:
1925       val = ffebld_constant_character1 (ffebld_conter (expr));
1926       newlen = ffetarget_length_character1 (val);
1927       if (with_null)
1928         {
1929           /* Begin FFETARGET-NULL-KLUDGE.  */
1930           if (newlen != 0)
1931             ++newlen;
1932         }
1933       *length = build_int_2 (newlen, 0);
1934       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1935       high = build_int_2 (newlen, 0);
1936       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1937       item = build_string (newlen,
1938                            ffetarget_text_character1 (val));
1939       /* End FFETARGET-NULL-KLUDGE.  */
1940       TREE_TYPE (item)
1941         = build_type_variant
1942           (build_array_type
1943            (char_type_node,
1944             build_range_type
1945             (ffecom_f2c_ftnlen_type_node,
1946              ffecom_f2c_ftnlen_one_node,
1947              high)),
1948            1, 0);
1949       TREE_CONSTANT (item) = 1;
1950       TREE_STATIC (item) = 1;
1951       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1952                        item);
1953       break;
1954
1955     case FFEBLD_opSYMTER:
1956       {
1957         ffesymbol s = ffebld_symter (expr);
1958
1959         item = ffesymbol_hook (s).decl_tree;
1960         if (item == NULL_TREE)
1961           {
1962             s = ffecom_sym_transform_ (s);
1963             item = ffesymbol_hook (s).decl_tree;
1964           }
1965         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1966           {
1967             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1968               *length = ffesymbol_hook (s).length_tree;
1969             else
1970               {
1971                 *length = build_int_2 (ffesymbol_size (s), 0);
1972                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1973               }
1974           }
1975         else if (item == error_mark_node)
1976           *length = error_mark_node;
1977         else
1978           /* FFEINFO_kindFUNCTION.  */
1979           *length = NULL_TREE;
1980         if (!ffesymbol_hook (s).addr
1981             && (item != error_mark_node))
1982           item = ffecom_1 (ADDR_EXPR,
1983                            build_pointer_type (TREE_TYPE (item)),
1984                            item);
1985       }
1986       break;
1987
1988     case FFEBLD_opARRAYREF:
1989       {
1990         ffecom_char_args_ (&item, length, ffebld_left (expr));
1991
1992         if (item == error_mark_node || *length == error_mark_node)
1993           {
1994             item = *length = error_mark_node;
1995             break;
1996           }
1997
1998         item = ffecom_arrayref_ (item, expr, 1);
1999       }
2000       break;
2001
2002     case FFEBLD_opSUBSTR:
2003       {
2004         ffebld start;
2005         ffebld end;
2006         ffebld thing = ffebld_right (expr);
2007         tree start_tree;
2008         tree end_tree;
2009         const char *char_name;
2010         ffebld left_symter;
2011         tree array;
2012
2013         assert (ffebld_op (thing) == FFEBLD_opITEM);
2014         start = ffebld_head (thing);
2015         thing = ffebld_trail (thing);
2016         assert (ffebld_trail (thing) == NULL);
2017         end = ffebld_head (thing);
2018
2019         /* Determine name for pretty-printing range-check errors.  */
2020         for (left_symter = ffebld_left (expr);
2021              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2022              left_symter = ffebld_left (left_symter))
2023           ;
2024         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2025           char_name = ffesymbol_text (ffebld_symter (left_symter));
2026         else
2027           char_name = "[expr?]";
2028
2029         ffecom_char_args_ (&item, length, ffebld_left (expr));
2030
2031         if (item == error_mark_node || *length == error_mark_node)
2032           {
2033             item = *length = error_mark_node;
2034             break;
2035           }
2036
2037         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2038
2039         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2040
2041         if (start == NULL)
2042           {
2043             if (end == NULL)
2044               ;
2045             else
2046               {
2047                 end_tree = ffecom_expr (end);
2048                 if (flag_bounds_check)
2049                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2050                                                       char_name);
2051                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2052                                     end_tree);
2053
2054                 if (end_tree == error_mark_node)
2055                   {
2056                     item = *length = error_mark_node;
2057                     break;
2058                   }
2059
2060                 *length = end_tree;
2061               }
2062           }
2063         else
2064           {
2065             start_tree = ffecom_expr (start);
2066             if (flag_bounds_check)
2067               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2068                                                     char_name);
2069             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2070                                   start_tree);
2071
2072             if (start_tree == error_mark_node)
2073               {
2074                 item = *length = error_mark_node;
2075                 break;
2076               }
2077
2078             start_tree = ffecom_save_tree (start_tree);
2079
2080             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2081                              item,
2082                              ffecom_2 (MINUS_EXPR,
2083                                        TREE_TYPE (start_tree),
2084                                        start_tree,
2085                                        ffecom_f2c_ftnlen_one_node));
2086
2087             if (end == NULL)
2088               {
2089                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090                                     ffecom_f2c_ftnlen_one_node,
2091                                     ffecom_2 (MINUS_EXPR,
2092                                               ffecom_f2c_ftnlen_type_node,
2093                                               *length,
2094                                               start_tree));
2095               }
2096             else
2097               {
2098                 end_tree = ffecom_expr (end);
2099                 if (flag_bounds_check)
2100                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2101                                                       char_name);
2102                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2103                                     end_tree);
2104
2105                 if (end_tree == error_mark_node)
2106                   {
2107                     item = *length = error_mark_node;
2108                     break;
2109                   }
2110
2111                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2112                                     ffecom_f2c_ftnlen_one_node,
2113                                     ffecom_2 (MINUS_EXPR,
2114                                               ffecom_f2c_ftnlen_type_node,
2115                                               end_tree, start_tree));
2116               }
2117           }
2118       }
2119       break;
2120
2121     case FFEBLD_opFUNCREF:
2122       {
2123         ffesymbol s = ffebld_symter (ffebld_left (expr));
2124         tree tempvar;
2125         tree args;
2126         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2127         ffecomGfrt ix;
2128
2129         if (size == FFETARGET_charactersizeNONE)
2130           /* ~~Kludge alert!  This should someday be fixed. */
2131           size = 24;
2132
2133         *length = build_int_2 (size, 0);
2134         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2135
2136         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2137             == FFEINFO_whereINTRINSIC)
2138           {
2139             if (size == 1)
2140               {
2141                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2142                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2143                                                NULL, NULL);
2144                 break;
2145               }
2146             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2147             assert (ix != FFECOM_gfrt);
2148             item = ffecom_gfrt_tree_ (ix);
2149           }
2150         else
2151           {
2152             ix = FFECOM_gfrt;
2153             item = ffesymbol_hook (s).decl_tree;
2154             if (item == NULL_TREE)
2155               {
2156                 s = ffecom_sym_transform_ (s);
2157                 item = ffesymbol_hook (s).decl_tree;
2158               }
2159             if (item == error_mark_node)
2160               {
2161                 item = *length = error_mark_node;
2162                 break;
2163               }
2164
2165             if (!ffesymbol_hook (s).addr)
2166               item = ffecom_1_fn (item);
2167           }
2168
2169 #ifdef HOHO
2170         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2171 #else
2172         tempvar = ffebld_nonter_hook (expr);
2173         assert (tempvar);
2174 #endif
2175         tempvar = ffecom_1 (ADDR_EXPR,
2176                             build_pointer_type (TREE_TYPE (tempvar)),
2177                             tempvar);
2178
2179         args = build_tree_list (NULL_TREE, tempvar);
2180
2181         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2182           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2183         else
2184           {
2185             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2186             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2187               {
2188                 TREE_CHAIN (TREE_CHAIN (args))
2189                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2190                                           ffebld_right (expr));
2191               }
2192             else
2193               {
2194                 TREE_CHAIN (TREE_CHAIN (args))
2195                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2196               }
2197           }
2198
2199         item = ffecom_3s (CALL_EXPR,
2200                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2201                           item, args, NULL_TREE);
2202         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2203                          tempvar);
2204       }
2205       break;
2206
2207     case FFEBLD_opCONVERT:
2208
2209       ffecom_char_args_ (&item, length, ffebld_left (expr));
2210
2211       if (item == error_mark_node || *length == error_mark_node)
2212         {
2213           item = *length = error_mark_node;
2214           break;
2215         }
2216
2217       if ((ffebld_size_known (ffebld_left (expr))
2218            == FFETARGET_charactersizeNONE)
2219           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2220         {                       /* Possible blank-padding needed, copy into
2221                                    temporary. */
2222           tree tempvar;
2223           tree args;
2224           tree newlen;
2225
2226 #ifdef HOHO
2227           tempvar = ffecom_make_tempvar (char_type_node,
2228                                          ffebld_size (expr), -1);
2229 #else
2230           tempvar = ffebld_nonter_hook (expr);
2231           assert (tempvar);
2232 #endif
2233           tempvar = ffecom_1 (ADDR_EXPR,
2234                               build_pointer_type (TREE_TYPE (tempvar)),
2235                               tempvar);
2236
2237           newlen = build_int_2 (ffebld_size (expr), 0);
2238           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2239
2240           args = build_tree_list (NULL_TREE, tempvar);
2241           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2242           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2243           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2244             = build_tree_list (NULL_TREE, *length);
2245
2246           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2247           TREE_SIDE_EFFECTS (item) = 1;
2248           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2249                            tempvar);
2250           *length = newlen;
2251         }
2252       else
2253         {                       /* Just truncate the length. */
2254           *length = build_int_2 (ffebld_size (expr), 0);
2255           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2256         }
2257       break;
2258
2259     default:
2260       assert ("bad op for single char arg expr" == NULL);
2261       item = NULL_TREE;
2262       break;
2263     }
2264
2265   *xitem = item;
2266 }
2267 #endif
2268
2269 /* Check the size of the type to be sure it doesn't overflow the
2270    "portable" capacities of the compiler back end.  `dummy' types
2271    can generally overflow the normal sizes as long as the computations
2272    themselves don't overflow.  A particular target of the back end
2273    must still enforce its size requirements, though, and the back
2274    end takes care of this in stor-layout.c.  */
2275
2276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2277 static tree
2278 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2279 {
2280   if (TREE_CODE (type) == ERROR_MARK)
2281     return type;
2282
2283   if (TYPE_SIZE (type) == NULL_TREE)
2284     return type;
2285
2286   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2287     return type;
2288
2289   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2290       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2291                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2292     {
2293       ffebad_start (FFEBAD_ARRAY_LARGE);
2294       ffebad_string (ffesymbol_text (s));
2295       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2296       ffebad_finish ();
2297
2298       return error_mark_node;
2299     }
2300
2301   return type;
2302 }
2303 #endif
2304
2305 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2306    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2307    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2308
2309 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2310 static tree
2311 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2312 {
2313   ffetargetCharacterSize sz = ffesymbol_size (s);
2314   tree highval;
2315   tree tlen;
2316   tree type = *xtype;
2317
2318   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2319     tlen = NULL_TREE;           /* A statement function, no length passed. */
2320   else
2321     {
2322       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2323         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2324                                                ffesymbol_text (s));
2325       else
2326         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2327       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2328 #if BUILT_FOR_270
2329       DECL_ARTIFICIAL (tlen) = 1;
2330 #endif
2331     }
2332
2333   if (sz == FFETARGET_charactersizeNONE)
2334     {
2335       assert (tlen != NULL_TREE);
2336       highval = variable_size (tlen);
2337     }
2338   else
2339     {
2340       highval = build_int_2 (sz, 0);
2341       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2342     }
2343
2344   type = build_array_type (type,
2345                            build_range_type (ffecom_f2c_ftnlen_type_node,
2346                                              ffecom_f2c_ftnlen_one_node,
2347                                              highval));
2348
2349   *xtype = type;
2350   return tlen;
2351 }
2352
2353 #endif
2354 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2355
2356    ffecomConcatList_ catlist;
2357    ffebld expr;  // expr of CHARACTER basictype.
2358    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2359    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2360
2361    Scans expr for character subexpressions, updates and returns catlist
2362    accordingly.  */
2363
2364 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2365 static ffecomConcatList_
2366 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2367                             ffetargetCharacterSize max)
2368 {
2369   ffetargetCharacterSize sz;
2370
2371 recurse:                        /* :::::::::::::::::::: */
2372
2373   if (expr == NULL)
2374     return catlist;
2375
2376   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2377     return catlist;             /* Don't append any more items. */
2378
2379   switch (ffebld_op (expr))
2380     {
2381     case FFEBLD_opCONTER:
2382     case FFEBLD_opSYMTER:
2383     case FFEBLD_opARRAYREF:
2384     case FFEBLD_opFUNCREF:
2385     case FFEBLD_opSUBSTR:
2386     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2387                                    if they don't need to preserve it. */
2388       if (catlist.count == catlist.max)
2389         {                       /* Make a (larger) list. */
2390           ffebld *newx;
2391           int newmax;
2392
2393           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2394           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2395                                 newmax * sizeof (newx[0]));
2396           if (catlist.max != 0)
2397             {
2398               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2399               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2400                               catlist.max * sizeof (newx[0]));
2401             }
2402           catlist.max = newmax;
2403           catlist.exprs = newx;
2404         }
2405       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2406         catlist.minlen += sz;
2407       else
2408         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2409       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2410         catlist.maxlen = sz;
2411       else
2412         catlist.maxlen += sz;
2413       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2414         {                       /* This item overlaps (or is beyond) the end
2415                                    of the destination. */
2416           switch (ffebld_op (expr))
2417             {
2418             case FFEBLD_opCONTER:
2419             case FFEBLD_opSYMTER:
2420             case FFEBLD_opARRAYREF:
2421             case FFEBLD_opFUNCREF:
2422             case FFEBLD_opSUBSTR:
2423               /* ~~Do useful truncations here. */
2424               break;
2425
2426             default:
2427               assert ("op changed or inconsistent switches!" == NULL);
2428               break;
2429             }
2430         }
2431       catlist.exprs[catlist.count++] = expr;
2432       return catlist;
2433
2434     case FFEBLD_opPAREN:
2435       expr = ffebld_left (expr);
2436       goto recurse;             /* :::::::::::::::::::: */
2437
2438     case FFEBLD_opCONCATENATE:
2439       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2440       expr = ffebld_right (expr);
2441       goto recurse;             /* :::::::::::::::::::: */
2442
2443 #if 0                           /* Breaks passing small actual arg to larger
2444                                    dummy arg of sfunc */
2445     case FFEBLD_opCONVERT:
2446       expr = ffebld_left (expr);
2447       {
2448         ffetargetCharacterSize cmax;
2449
2450         cmax = catlist.len + ffebld_size_known (expr);
2451
2452         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2453           max = cmax;
2454       }
2455       goto recurse;             /* :::::::::::::::::::: */
2456 #endif
2457
2458     case FFEBLD_opANY:
2459       return catlist;
2460
2461     default:
2462       assert ("bad op in _gather_" == NULL);
2463       return catlist;
2464     }
2465 }
2466
2467 #endif
2468 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2469
2470    ffecomConcatList_ catlist;
2471    ffecom_concat_list_kill_(catlist);
2472
2473    Anything allocated within the list info is deallocated.  */
2474
2475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2476 static void
2477 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2478 {
2479   if (catlist.max != 0)
2480     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2481                     catlist.max * sizeof (catlist.exprs[0]));
2482 }
2483
2484 #endif
2485 /* Make list of concatenated string exprs.
2486
2487    Returns a flattened list of concatenated subexpressions given a
2488    tree of such expressions.  */
2489
2490 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2491 static ffecomConcatList_
2492 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2493 {
2494   ffecomConcatList_ catlist;
2495
2496   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2497   return ffecom_concat_list_gather_ (catlist, expr, max);
2498 }
2499
2500 #endif
2501
2502 /* Provide some kind of useful info on member of aggregate area,
2503    since current g77/gcc technology does not provide debug info
2504    on these members.  */
2505
2506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2507 static void
2508 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2509                       tree member_type UNUSED, ffetargetOffset offset)
2510 {
2511   tree value;
2512   tree decl;
2513   int len;
2514   char *buff;
2515   char space[120];
2516 #if 0
2517   tree type_id;
2518
2519   for (type_id = member_type;
2520        TREE_CODE (type_id) != IDENTIFIER_NODE;
2521        )
2522     {
2523       switch (TREE_CODE (type_id))
2524         {
2525         case INTEGER_TYPE:
2526         case REAL_TYPE:
2527           type_id = TYPE_NAME (type_id);
2528           break;
2529
2530         case ARRAY_TYPE:
2531         case COMPLEX_TYPE:
2532           type_id = TREE_TYPE (type_id);
2533           break;
2534
2535         default:
2536           assert ("no IDENTIFIER_NODE for type!" == NULL);
2537           type_id = error_mark_node;
2538           break;
2539         }
2540     }
2541 #endif
2542
2543   if (ffecom_transform_only_dummies_
2544       || !ffe_is_debug_kludge ())
2545     return;     /* Can't do this yet, maybe later. */
2546
2547   len = 60
2548     + strlen (aggr_type)
2549     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2550 #if 0
2551     + IDENTIFIER_LENGTH (type_id);
2552 #endif
2553
2554   if (((size_t) len) >= ARRAY_SIZE (space))
2555     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2556   else
2557     buff = &space[0];
2558
2559   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2560            aggr_type,
2561            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2562            (long int) offset);
2563
2564   value = build_string (len, buff);
2565   TREE_TYPE (value)
2566     = build_type_variant (build_array_type (char_type_node,
2567                                             build_range_type
2568                                             (integer_type_node,
2569                                              integer_one_node,
2570                                              build_int_2 (strlen (buff), 0))),
2571                           1, 0);
2572   decl = build_decl (VAR_DECL,
2573                      ffecom_get_identifier_ (ffesymbol_text (member)),
2574                      TREE_TYPE (value));
2575   TREE_CONSTANT (decl) = 1;
2576   TREE_STATIC (decl) = 1;
2577   DECL_INITIAL (decl) = error_mark_node;
2578   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2579   decl = start_decl (decl, FALSE);
2580   finish_decl (decl, value, FALSE);
2581
2582   if (buff != &space[0])
2583     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2584 }
2585 #endif
2586
2587 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2588
2589    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2590    int i;  // entry# for this entrypoint (used by master fn)
2591    ffecom_do_entrypoint_(s,i);
2592
2593    Makes a public entry point that calls our private master fn (already
2594    compiled).  */
2595
2596 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2597 static void
2598 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2599 {
2600   ffebld item;
2601   tree type;                    /* Type of function. */
2602   tree multi_retval;            /* Var holding return value (union). */
2603   tree result;                  /* Var holding result. */
2604   ffeinfoBasictype bt;
2605   ffeinfoKindtype kt;
2606   ffeglobal g;
2607   ffeglobalType gt;
2608   bool charfunc;                /* All entry points return same type
2609                                    CHARACTER. */
2610   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2611   bool multi;                   /* Master fn has multiple return types. */
2612   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2613   int old_lineno = lineno;
2614   const char *old_input_filename = input_filename;
2615
2616   input_filename = ffesymbol_where_filename (fn);
2617   lineno = ffesymbol_where_filelinenum (fn);
2618
2619   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2620
2621   switch (ffecom_primary_entry_kind_)
2622     {
2623     case FFEINFO_kindFUNCTION:
2624
2625       /* Determine actual return type for function. */
2626
2627       gt = FFEGLOBAL_typeFUNC;
2628       bt = ffesymbol_basictype (fn);
2629       kt = ffesymbol_kindtype (fn);
2630       if (bt == FFEINFO_basictypeNONE)
2631         {
2632           ffeimplic_establish_symbol (fn);
2633           if (ffesymbol_funcresult (fn) != NULL)
2634             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2635           bt = ffesymbol_basictype (fn);
2636           kt = ffesymbol_kindtype (fn);
2637         }
2638
2639       if (bt == FFEINFO_basictypeCHARACTER)
2640         charfunc = TRUE, cmplxfunc = FALSE;
2641       else if ((bt == FFEINFO_basictypeCOMPLEX)
2642                && ffesymbol_is_f2c (fn))
2643         charfunc = FALSE, cmplxfunc = TRUE;
2644       else
2645         charfunc = cmplxfunc = FALSE;
2646
2647       if (charfunc)
2648         type = ffecom_tree_fun_type_void;
2649       else if (ffesymbol_is_f2c (fn))
2650         type = ffecom_tree_fun_type[bt][kt];
2651       else
2652         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2653
2654       if ((type == NULL_TREE)
2655           || (TREE_TYPE (type) == NULL_TREE))
2656         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2657
2658       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2659       break;
2660
2661     case FFEINFO_kindSUBROUTINE:
2662       gt = FFEGLOBAL_typeSUBR;
2663       bt = FFEINFO_basictypeNONE;
2664       kt = FFEINFO_kindtypeNONE;
2665       if (ffecom_is_altreturning_)
2666         {                       /* Am _I_ altreturning? */
2667           for (item = ffesymbol_dummyargs (fn);
2668                item != NULL;
2669                item = ffebld_trail (item))
2670             {
2671               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2672                 {
2673                   altreturning = TRUE;
2674                   break;
2675                 }
2676             }
2677           if (altreturning)
2678             type = ffecom_tree_subr_type;
2679           else
2680             type = ffecom_tree_fun_type_void;
2681         }
2682       else
2683         type = ffecom_tree_fun_type_void;
2684       charfunc = FALSE;
2685       cmplxfunc = FALSE;
2686       multi = FALSE;
2687       break;
2688
2689     default:
2690       assert ("say what??" == NULL);
2691       /* Fall through. */
2692     case FFEINFO_kindANY:
2693       gt = FFEGLOBAL_typeANY;
2694       bt = FFEINFO_basictypeNONE;
2695       kt = FFEINFO_kindtypeNONE;
2696       type = error_mark_node;
2697       charfunc = FALSE;
2698       cmplxfunc = FALSE;
2699       multi = FALSE;
2700       break;
2701     }
2702
2703   /* build_decl uses the current lineno and input_filename to set the decl
2704      source info.  So, I've putzed with ffestd and ffeste code to update that
2705      source info to point to the appropriate statement just before calling
2706      ffecom_do_entrypoint (which calls this fn).  */
2707
2708   start_function (ffecom_get_external_identifier_ (fn),
2709                   type,
2710                   0,            /* nested/inline */
2711                   1);           /* TREE_PUBLIC */
2712
2713   if (((g = ffesymbol_global (fn)) != NULL)
2714       && ((ffeglobal_type (g) == gt)
2715           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2716     {
2717       ffeglobal_set_hook (g, current_function_decl);
2718     }
2719
2720   /* Reset args in master arg list so they get retransitioned. */
2721
2722   for (item = ffecom_master_arglist_;
2723        item != NULL;
2724        item = ffebld_trail (item))
2725     {
2726       ffebld arg;
2727       ffesymbol s;
2728
2729       arg = ffebld_head (item);
2730       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2731         continue;               /* Alternate return or some such thing. */
2732       s = ffebld_symter (arg);
2733       ffesymbol_hook (s).decl_tree = NULL_TREE;
2734       ffesymbol_hook (s).length_tree = NULL_TREE;
2735     }
2736
2737   /* Build dummy arg list for this entry point. */
2738
2739   if (charfunc || cmplxfunc)
2740     {                           /* Prepend arg for where result goes. */
2741       tree type;
2742       tree length;
2743
2744       if (charfunc)
2745         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2746       else
2747         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2748
2749       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2750
2751       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2752
2753       if (charfunc)
2754         length = ffecom_char_enhance_arg_ (&type, fn);
2755       else
2756         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2757
2758       type = build_pointer_type (type);
2759       result = build_decl (PARM_DECL, result, type);
2760
2761       push_parm_decl (result);
2762       ffecom_func_result_ = result;
2763
2764       if (charfunc)
2765         {
2766           push_parm_decl (length);
2767           ffecom_func_length_ = length;
2768         }
2769     }
2770   else
2771     result = DECL_RESULT (current_function_decl);
2772
2773   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2774
2775   store_parm_decls (0);
2776
2777   ffecom_start_compstmt ();
2778   /* Disallow temp vars at this level.  */
2779   current_binding_level->prep_state = 2;
2780
2781   /* Make local var to hold return type for multi-type master fn. */
2782
2783   if (multi)
2784     {
2785       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2786                                                      "multi_retval");
2787       multi_retval = build_decl (VAR_DECL, multi_retval,
2788                                  ffecom_multi_type_node_);
2789       multi_retval = start_decl (multi_retval, FALSE);
2790       finish_decl (multi_retval, NULL_TREE, FALSE);
2791     }
2792   else
2793     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2794
2795   /* Here we emit the actual code for the entry point. */
2796
2797   {
2798     ffebld list;
2799     ffebld arg;
2800     ffesymbol s;
2801     tree arglist = NULL_TREE;
2802     tree *plist = &arglist;
2803     tree prepend;
2804     tree call;
2805     tree actarg;
2806     tree master_fn;
2807
2808     /* Prepare actual arg list based on master arg list. */
2809
2810     for (list = ffecom_master_arglist_;
2811          list != NULL;
2812          list = ffebld_trail (list))
2813       {
2814         arg = ffebld_head (list);
2815         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2816           continue;
2817         s = ffebld_symter (arg);
2818         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2819             || ffesymbol_hook (s).decl_tree == error_mark_node)
2820           actarg = null_pointer_node;   /* We don't have this arg. */
2821         else
2822           actarg = ffesymbol_hook (s).decl_tree;
2823         *plist = build_tree_list (NULL_TREE, actarg);
2824         plist = &TREE_CHAIN (*plist);
2825       }
2826
2827     /* This code appends the length arguments for character
2828        variables/arrays.  */
2829
2830     for (list = ffecom_master_arglist_;
2831          list != NULL;
2832          list = ffebld_trail (list))
2833       {
2834         arg = ffebld_head (list);
2835         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2836           continue;
2837         s = ffebld_symter (arg);
2838         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2839           continue;             /* Only looking for CHARACTER arguments. */
2840         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2841           continue;             /* Only looking for variables and arrays. */
2842         if (ffesymbol_hook (s).length_tree == NULL_TREE
2843             || ffesymbol_hook (s).length_tree == error_mark_node)
2844           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2845         else
2846           actarg = ffesymbol_hook (s).length_tree;
2847         *plist = build_tree_list (NULL_TREE, actarg);
2848         plist = &TREE_CHAIN (*plist);
2849       }
2850
2851     /* Prepend character-value return info to actual arg list. */
2852
2853     if (charfunc)
2854       {
2855         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2856         TREE_CHAIN (prepend)
2857           = build_tree_list (NULL_TREE, ffecom_func_length_);
2858         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2859         arglist = prepend;
2860       }
2861
2862     /* Prepend multi-type return value to actual arg list. */
2863
2864     if (multi)
2865       {
2866         prepend
2867           = build_tree_list (NULL_TREE,
2868                              ffecom_1 (ADDR_EXPR,
2869                               build_pointer_type (TREE_TYPE (multi_retval)),
2870                                        multi_retval));
2871         TREE_CHAIN (prepend) = arglist;
2872         arglist = prepend;
2873       }
2874
2875     /* Prepend my entry-point number to the actual arg list. */
2876
2877     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2878     TREE_CHAIN (prepend) = arglist;
2879     arglist = prepend;
2880
2881     /* Build the call to the master function. */
2882
2883     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2884     call = ffecom_3s (CALL_EXPR,
2885                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2886                       master_fn, arglist, NULL_TREE);
2887
2888     /* Decide whether the master function is a function or subroutine, and
2889        handle the return value for my entry point. */
2890
2891     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2892                      && !altreturning))
2893       {
2894         expand_expr_stmt (call);
2895         expand_null_return ();
2896       }
2897     else if (multi && cmplxfunc)
2898       {
2899         expand_expr_stmt (call);
2900         result
2901           = ffecom_1 (INDIRECT_REF,
2902                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2903                       result);
2904         result = ffecom_modify (NULL_TREE, result,
2905                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2906                                           multi_retval,
2907                                           ffecom_multi_fields_[bt][kt]));
2908         expand_expr_stmt (result);
2909         expand_null_return ();
2910       }
2911     else if (multi)
2912       {
2913         expand_expr_stmt (call);
2914         result
2915           = ffecom_modify (NULL_TREE, result,
2916                            convert (TREE_TYPE (result),
2917                                     ffecom_2 (COMPONENT_REF,
2918                                               ffecom_tree_type[bt][kt],
2919                                               multi_retval,
2920                                               ffecom_multi_fields_[bt][kt])));
2921         expand_return (result);
2922       }
2923     else if (cmplxfunc)
2924       {
2925         result
2926           = ffecom_1 (INDIRECT_REF,
2927                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2928                       result);
2929         result = ffecom_modify (NULL_TREE, result, call);
2930         expand_expr_stmt (result);
2931         expand_null_return ();
2932       }
2933     else
2934       {
2935         result = ffecom_modify (NULL_TREE,
2936                                 result,
2937                                 convert (TREE_TYPE (result),
2938                                          call));
2939         expand_return (result);
2940       }
2941   }
2942
2943   ffecom_end_compstmt ();
2944
2945   finish_function (0);
2946
2947   lineno = old_lineno;
2948   input_filename = old_input_filename;
2949
2950   ffecom_doing_entry_ = FALSE;
2951 }
2952
2953 #endif
2954 /* Transform expr into gcc tree with possible destination
2955
2956    Recursive descent on expr while making corresponding tree nodes and
2957    attaching type info and such.  If destination supplied and compatible
2958    with temporary that would be made in certain cases, temporary isn't
2959    made, destination used instead, and dest_used flag set TRUE.  */
2960
2961 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2962 static tree
2963 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2964               bool *dest_used, bool assignp, bool widenp)
2965 {
2966   tree item;
2967   tree list;
2968   tree args;
2969   ffeinfoBasictype bt;
2970   ffeinfoKindtype kt;
2971   tree t;
2972   tree dt;                      /* decl_tree for an ffesymbol. */
2973   tree tree_type, tree_type_x;
2974   tree left, right;
2975   ffesymbol s;
2976   enum tree_code code;
2977
2978   assert (expr != NULL);
2979
2980   if (dest_used != NULL)
2981     *dest_used = FALSE;
2982
2983   bt = ffeinfo_basictype (ffebld_info (expr));
2984   kt = ffeinfo_kindtype (ffebld_info (expr));
2985   tree_type = ffecom_tree_type[bt][kt];
2986
2987   /* Widen integral arithmetic as desired while preserving signedness.  */
2988   tree_type_x = NULL_TREE;
2989   if (widenp && tree_type
2990       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2991       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2992     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2993
2994   switch (ffebld_op (expr))
2995     {
2996     case FFEBLD_opACCTER:
2997       {
2998         ffebitCount i;
2999         ffebit bits = ffebld_accter_bits (expr);
3000         ffetargetOffset source_offset = 0;
3001         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3002         tree purpose;
3003
3004         assert (dest_offset == 0
3005                 || (bt == FFEINFO_basictypeCHARACTER
3006                     && kt == FFEINFO_kindtypeCHARACTER1));
3007
3008         list = item = NULL;
3009         for (;;)
3010           {
3011             ffebldConstantUnion cu;
3012             ffebitCount length;
3013             bool value;
3014             ffebldConstantArray ca = ffebld_accter (expr);
3015
3016             ffebit_test (bits, source_offset, &value, &length);
3017             if (length == 0)
3018               break;
3019
3020             if (value)
3021               {
3022                 for (i = 0; i < length; ++i)
3023                   {
3024                     cu = ffebld_constantarray_get (ca, bt, kt,
3025                                                    source_offset + i);
3026
3027                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3028
3029                     if (i == 0
3030                         && dest_offset != 0)
3031                       purpose = build_int_2 (dest_offset, 0);
3032                     else
3033                       purpose = NULL_TREE;
3034
3035                     if (list == NULL_TREE)
3036                       list = item = build_tree_list (purpose, t);
3037                     else
3038                       {
3039                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3040                         item = TREE_CHAIN (item);
3041                       }
3042                   }
3043               }
3044             source_offset += length;
3045             dest_offset += length;
3046           }
3047       }
3048
3049       item = build_int_2 ((ffebld_accter_size (expr)
3050                            + ffebld_accter_pad (expr)) - 1, 0);
3051       ffebit_kill (ffebld_accter_bits (expr));
3052       TREE_TYPE (item) = ffecom_integer_type_node;
3053       item
3054         = build_array_type
3055           (tree_type,
3056            build_range_type (ffecom_integer_type_node,
3057                              ffecom_integer_zero_node,
3058                              item));
3059       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3060       TREE_CONSTANT (list) = 1;
3061       TREE_STATIC (list) = 1;
3062       return list;
3063
3064     case FFEBLD_opARRTER:
3065       {
3066         ffetargetOffset i;
3067
3068         list = NULL_TREE;
3069         if (ffebld_arrter_pad (expr) == 0)
3070           item = NULL_TREE;
3071         else
3072           {
3073             assert (bt == FFEINFO_basictypeCHARACTER
3074                     && kt == FFEINFO_kindtypeCHARACTER1);
3075
3076             /* Becomes PURPOSE first time through loop.  */
3077             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3078           }
3079
3080         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3081           {
3082             ffebldConstantUnion cu
3083             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3084
3085             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3086
3087             if (list == NULL_TREE)
3088               /* Assume item is PURPOSE first time through loop.  */
3089               list = item = build_tree_list (item, t);
3090             else
3091               {
3092                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3093                 item = TREE_CHAIN (item);
3094               }
3095           }
3096       }
3097
3098       item = build_int_2 ((ffebld_arrter_size (expr)
3099                           + ffebld_arrter_pad (expr)) - 1, 0);
3100       TREE_TYPE (item) = ffecom_integer_type_node;
3101       item
3102         = build_array_type
3103           (tree_type,
3104            build_range_type (ffecom_integer_type_node,
3105                              ffecom_integer_zero_node,
3106                              item));
3107       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3108       TREE_CONSTANT (list) = 1;
3109       TREE_STATIC (list) = 1;
3110       return list;
3111
3112     case FFEBLD_opCONTER:
3113       assert (ffebld_conter_pad (expr) == 0);
3114       item
3115         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3116                                 bt, kt, tree_type);
3117       return item;
3118
3119     case FFEBLD_opSYMTER:
3120       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3121           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3122         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3123       s = ffebld_symter (expr);
3124       t = ffesymbol_hook (s).decl_tree;
3125
3126       if (assignp)
3127         {                       /* ASSIGN'ed-label expr. */
3128           if (ffe_is_ugly_assign ())
3129             {
3130               /* User explicitly wants ASSIGN'ed variables to be at the same
3131                  memory address as the variables when used in non-ASSIGN
3132                  contexts.  That can make old, arcane, non-standard code
3133                  work, but don't try to do it when a pointer wouldn't fit
3134                  in the normal variable (take other approach, and warn,
3135                  instead).  */
3136
3137               if (t == NULL_TREE)
3138                 {
3139                   s = ffecom_sym_transform_ (s);
3140                   t = ffesymbol_hook (s).decl_tree;
3141                   assert (t != NULL_TREE);
3142                 }
3143
3144               if (t == error_mark_node)
3145                 return t;
3146
3147               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3148                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3149                 {
3150                   if (ffesymbol_hook (s).addr)
3151                     t = ffecom_1 (INDIRECT_REF,
3152                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3153                   return t;
3154                 }
3155
3156               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3157                 {
3158                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3159                                     FFEBAD_severityWARNING);
3160                   ffebad_string (ffesymbol_text (s));
3161                   ffebad_here (0, ffesymbol_where_line (s),
3162                                ffesymbol_where_column (s));
3163                   ffebad_finish ();
3164                 }
3165             }
3166
3167           /* Don't use the normal variable's tree for ASSIGN, though mark
3168              it as in the system header (housekeeping).  Use an explicit,
3169              specially created sibling that is known to be wide enough
3170              to hold pointers to labels.  */
3171
3172           if (t != NULL_TREE
3173               && TREE_CODE (t) == VAR_DECL)
3174             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3175
3176           t = ffesymbol_hook (s).assign_tree;
3177           if (t == NULL_TREE)
3178             {
3179               s = ffecom_sym_transform_assign_ (s);
3180               t = ffesymbol_hook (s).assign_tree;
3181               assert (t != NULL_TREE);
3182             }
3183         }
3184       else
3185         {
3186           if (t == NULL_TREE)
3187             {
3188               s = ffecom_sym_transform_ (s);
3189               t = ffesymbol_hook (s).decl_tree;
3190               assert (t != NULL_TREE);
3191             }
3192           if (ffesymbol_hook (s).addr)
3193             t = ffecom_1 (INDIRECT_REF,
3194                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3195         }
3196       return t;
3197
3198     case FFEBLD_opARRAYREF:
3199       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3200
3201     case FFEBLD_opUPLUS:
3202       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3203       return ffecom_1 (NOP_EXPR, tree_type, left);
3204
3205     case FFEBLD_opPAREN:
3206       /* ~~~Make sure Fortran rules respected here */
3207       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3208       return ffecom_1 (NOP_EXPR, tree_type, left);
3209
3210     case FFEBLD_opUMINUS:
3211       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3212       if (tree_type_x)
3213         {
3214           tree_type = tree_type_x;
3215           left = convert (tree_type, left);
3216         }
3217       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3218
3219     case FFEBLD_opADD:
3220       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3221       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3222       if (tree_type_x)
3223         {
3224           tree_type = tree_type_x;
3225           left = convert (tree_type, left);
3226           right = convert (tree_type, right);
3227         }
3228       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3229
3230     case FFEBLD_opSUBTRACT:
3231       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3232       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3233       if (tree_type_x)
3234         {
3235           tree_type = tree_type_x;
3236           left = convert (tree_type, left);
3237           right = convert (tree_type, right);
3238         }
3239       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3240
3241     case FFEBLD_opMULTIPLY:
3242       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3243       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3244       if (tree_type_x)
3245         {
3246           tree_type = tree_type_x;
3247           left = convert (tree_type, left);
3248           right = convert (tree_type, right);
3249         }
3250       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3251
3252     case FFEBLD_opDIVIDE:
3253       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3254       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3255       if (tree_type_x)
3256         {
3257           tree_type = tree_type_x;
3258           left = convert (tree_type, left);
3259           right = convert (tree_type, right);
3260         }
3261       return ffecom_tree_divide_ (tree_type, left, right,
3262                                   dest_tree, dest, dest_used,
3263                                   ffebld_nonter_hook (expr));
3264
3265     case FFEBLD_opPOWER:
3266       {
3267         ffebld left = ffebld_left (expr);
3268         ffebld right = ffebld_right (expr);
3269         ffecomGfrt code;
3270         ffeinfoKindtype rtkt;
3271         ffeinfoKindtype ltkt;
3272         bool ref = TRUE;
3273
3274         switch (ffeinfo_basictype (ffebld_info (right)))
3275           {
3276
3277           case FFEINFO_basictypeINTEGER:
3278             if (1 || optimize)
3279               {
3280                 item = ffecom_expr_power_integer_ (expr);
3281                 if (item != NULL_TREE)
3282                   return item;
3283               }
3284
3285             rtkt = FFEINFO_kindtypeINTEGER1;
3286             switch (ffeinfo_basictype (ffebld_info (left)))
3287               {
3288               case FFEINFO_basictypeINTEGER:
3289                 if ((ffeinfo_kindtype (ffebld_info (left))
3290                     == FFEINFO_kindtypeINTEGER4)
3291                     || (ffeinfo_kindtype (ffebld_info (right))
3292                         == FFEINFO_kindtypeINTEGER4))
3293                   {
3294                     code = FFECOM_gfrtPOW_QQ;
3295                     ltkt = FFEINFO_kindtypeINTEGER4;
3296                     rtkt = FFEINFO_kindtypeINTEGER4;
3297                   }
3298                 else
3299                   {
3300                     code = FFECOM_gfrtPOW_II;
3301                     ltkt = FFEINFO_kindtypeINTEGER1;
3302                   }
3303                 break;
3304
3305               case FFEINFO_basictypeREAL:
3306                 if (ffeinfo_kindtype (ffebld_info (left))
3307                     == FFEINFO_kindtypeREAL1)
3308                   {
3309                     code = FFECOM_gfrtPOW_RI;
3310                     ltkt = FFEINFO_kindtypeREAL1;
3311                   }
3312                 else
3313                   {
3314                     code = FFECOM_gfrtPOW_DI;
3315                     ltkt = FFEINFO_kindtypeREAL2;
3316                   }
3317                 break;
3318
3319               case FFEINFO_basictypeCOMPLEX:
3320                 if (ffeinfo_kindtype (ffebld_info (left))
3321                     == FFEINFO_kindtypeREAL1)
3322                   {
3323                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3324                     ltkt = FFEINFO_kindtypeREAL1;
3325                   }
3326                 else
3327                   {
3328                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3329                     ltkt = FFEINFO_kindtypeREAL2;
3330                   }
3331                 break;
3332
3333               default:
3334                 assert ("bad pow_*i" == NULL);
3335                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3336                 ltkt = FFEINFO_kindtypeREAL1;
3337                 break;
3338               }
3339             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3340               left = ffeexpr_convert (left, NULL, NULL,
3341                                       ffeinfo_basictype (ffebld_info (left)),
3342                                       ltkt, 0,
3343                                       FFETARGET_charactersizeNONE,
3344                                       FFEEXPR_contextLET);
3345             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3346               right = ffeexpr_convert (right, NULL, NULL,
3347                                        FFEINFO_basictypeINTEGER,
3348                                        rtkt, 0,
3349                                        FFETARGET_charactersizeNONE,
3350                                        FFEEXPR_contextLET);
3351             break;
3352
3353           case FFEINFO_basictypeREAL:
3354             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3355               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3356                                       FFEINFO_kindtypeREALDOUBLE, 0,
3357                                       FFETARGET_charactersizeNONE,
3358                                       FFEEXPR_contextLET);
3359             if (ffeinfo_kindtype (ffebld_info (right))
3360                 == FFEINFO_kindtypeREAL1)
3361               right = ffeexpr_convert (right, NULL, NULL,
3362                                        FFEINFO_basictypeREAL,
3363                                        FFEINFO_kindtypeREALDOUBLE, 0,
3364                                        FFETARGET_charactersizeNONE,
3365                                        FFEEXPR_contextLET);
3366             /* We used to call FFECOM_gfrtPOW_DD here,
3367                which passes arguments by reference.  */
3368             code = FFECOM_gfrtL_POW;
3369             /* Pass arguments by value. */
3370             ref  = FALSE;
3371             break;
3372
3373           case FFEINFO_basictypeCOMPLEX:
3374             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3375               left = ffeexpr_convert (left, NULL, NULL,
3376                                       FFEINFO_basictypeCOMPLEX,
3377                                       FFEINFO_kindtypeREALDOUBLE, 0,
3378                                       FFETARGET_charactersizeNONE,
3379                                       FFEEXPR_contextLET);
3380             if (ffeinfo_kindtype (ffebld_info (right))
3381                 == FFEINFO_kindtypeREAL1)
3382               right = ffeexpr_convert (right, NULL, NULL,
3383                                        FFEINFO_basictypeCOMPLEX,
3384                                        FFEINFO_kindtypeREALDOUBLE, 0,
3385                                        FFETARGET_charactersizeNONE,
3386                                        FFEEXPR_contextLET);
3387             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3388             ref = TRUE;                 /* Pass arguments by reference. */
3389             break;
3390
3391           default:
3392             assert ("bad pow_x*" == NULL);
3393             code = FFECOM_gfrtPOW_II;
3394             break;
3395           }
3396         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3397                                    ffecom_gfrt_kindtype (code),
3398                                    (ffe_is_f2c_library ()
3399                                     && ffecom_gfrt_complex_[code]),
3400                                    tree_type, left, right,
3401                                    dest_tree, dest, dest_used,
3402                                    NULL_TREE, FALSE, ref,
3403                                    ffebld_nonter_hook (expr));
3404       }
3405
3406     case FFEBLD_opNOT:
3407       switch (bt)
3408         {
3409         case FFEINFO_basictypeLOGICAL:
3410           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3411           return convert (tree_type, item);
3412
3413         case FFEINFO_basictypeINTEGER:
3414           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3415                            ffecom_expr (ffebld_left (expr)));
3416
3417         default:
3418           assert ("NOT bad basictype" == NULL);
3419           /* Fall through. */
3420         case FFEINFO_basictypeANY:
3421           return error_mark_node;
3422         }
3423       break;
3424
3425     case FFEBLD_opFUNCREF:
3426       assert (ffeinfo_basictype (ffebld_info (expr))
3427               != FFEINFO_basictypeCHARACTER);
3428       /* Fall through.   */
3429     case FFEBLD_opSUBRREF:
3430       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3431           == FFEINFO_whereINTRINSIC)
3432         {                       /* Invocation of an intrinsic. */
3433           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3434                                          dest_used);
3435           return item;
3436         }
3437       s = ffebld_symter (ffebld_left (expr));
3438       dt = ffesymbol_hook (s).decl_tree;
3439       if (dt == NULL_TREE)
3440         {
3441           s = ffecom_sym_transform_ (s);
3442           dt = ffesymbol_hook (s).decl_tree;
3443         }
3444       if (dt == error_mark_node)
3445         return dt;
3446
3447       if (ffesymbol_hook (s).addr)
3448         item = dt;
3449       else
3450         item = ffecom_1_fn (dt);
3451
3452       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3453         args = ffecom_list_expr (ffebld_right (expr));
3454       else
3455         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3456
3457       if (args == error_mark_node)
3458         return error_mark_node;
3459
3460       item = ffecom_call_ (item, kt,
3461                            ffesymbol_is_f2c (s)
3462                            && (bt == FFEINFO_basictypeCOMPLEX)
3463                            && (ffesymbol_where (s)
3464                                != FFEINFO_whereCONSTANT),
3465                            tree_type,
3466                            args,
3467                            dest_tree, dest, dest_used,
3468                            error_mark_node, FALSE,
3469                            ffebld_nonter_hook (expr));
3470       TREE_SIDE_EFFECTS (item) = 1;
3471       return item;
3472
3473     case FFEBLD_opAND:
3474       switch (bt)
3475         {
3476         case FFEINFO_basictypeLOGICAL:
3477           item
3478             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3479                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3480                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3481           return convert (tree_type, item);
3482
3483         case FFEINFO_basictypeINTEGER:
3484           return ffecom_2 (BIT_AND_EXPR, tree_type,
3485                            ffecom_expr (ffebld_left (expr)),
3486                            ffecom_expr (ffebld_right (expr)));
3487
3488         default:
3489           assert ("AND bad basictype" == NULL);
3490           /* Fall through. */
3491         case FFEINFO_basictypeANY:
3492           return error_mark_node;
3493         }
3494       break;
3495
3496     case FFEBLD_opOR:
3497       switch (bt)
3498         {
3499         case FFEINFO_basictypeLOGICAL:
3500           item
3501             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3502                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3503                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3504           return convert (tree_type, item);
3505
3506         case FFEINFO_basictypeINTEGER:
3507           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3508                            ffecom_expr (ffebld_left (expr)),
3509                            ffecom_expr (ffebld_right (expr)));
3510
3511         default:
3512           assert ("OR bad basictype" == NULL);
3513           /* Fall through. */
3514         case FFEINFO_basictypeANY:
3515           return error_mark_node;
3516         }
3517       break;
3518
3519     case FFEBLD_opXOR:
3520     case FFEBLD_opNEQV:
3521       switch (bt)
3522         {
3523         case FFEINFO_basictypeLOGICAL:
3524           item
3525             = ffecom_2 (NE_EXPR, integer_type_node,
3526                         ffecom_expr (ffebld_left (expr)),
3527                         ffecom_expr (ffebld_right (expr)));
3528           return convert (tree_type, ffecom_truth_value (item));
3529
3530         case FFEINFO_basictypeINTEGER:
3531           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3532                            ffecom_expr (ffebld_left (expr)),
3533                            ffecom_expr (ffebld_right (expr)));
3534
3535         default:
3536           assert ("XOR/NEQV bad basictype" == NULL);
3537           /* Fall through. */
3538         case FFEINFO_basictypeANY:
3539           return error_mark_node;
3540         }
3541       break;
3542
3543     case FFEBLD_opEQV:
3544       switch (bt)
3545         {
3546         case FFEINFO_basictypeLOGICAL:
3547           item
3548             = ffecom_2 (EQ_EXPR, integer_type_node,
3549                         ffecom_expr (ffebld_left (expr)),
3550                         ffecom_expr (ffebld_right (expr)));
3551           return convert (tree_type, ffecom_truth_value (item));
3552
3553         case FFEINFO_basictypeINTEGER:
3554           return
3555             ffecom_1 (BIT_NOT_EXPR, tree_type,
3556                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3557                                 ffecom_expr (ffebld_left (expr)),
3558                                 ffecom_expr (ffebld_right (expr))));
3559
3560         default:
3561           assert ("EQV bad basictype" == NULL);
3562           /* Fall through. */
3563         case FFEINFO_basictypeANY:
3564           return error_mark_node;
3565         }
3566       break;
3567
3568     case FFEBLD_opCONVERT:
3569       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3570         return error_mark_node;
3571
3572       switch (bt)
3573         {
3574         case FFEINFO_basictypeLOGICAL:
3575         case FFEINFO_basictypeINTEGER:
3576         case FFEINFO_basictypeREAL:
3577           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3578
3579         case FFEINFO_basictypeCOMPLEX:
3580           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3581             {
3582             case FFEINFO_basictypeINTEGER:
3583             case FFEINFO_basictypeLOGICAL:
3584             case FFEINFO_basictypeREAL:
3585               item = ffecom_expr (ffebld_left (expr));
3586               if (item == error_mark_node)
3587                 return error_mark_node;
3588               /* convert() takes care of converting to the subtype first,
3589                  at least in gcc-2.7.2. */
3590               item = convert (tree_type, item);
3591               return item;
3592
3593             case FFEINFO_basictypeCOMPLEX:
3594               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3595
3596             default:
3597               assert ("CONVERT COMPLEX bad basictype" == NULL);
3598               /* Fall through. */
3599             case FFEINFO_basictypeANY:
3600               return error_mark_node;
3601             }
3602           break;
3603
3604         default:
3605           assert ("CONVERT bad basictype" == NULL);
3606           /* Fall through. */
3607         case FFEINFO_basictypeANY:
3608           return error_mark_node;
3609         }
3610       break;
3611
3612     case FFEBLD_opLT:
3613       code = LT_EXPR;
3614       goto relational;          /* :::::::::::::::::::: */
3615
3616     case FFEBLD_opLE:
3617       code = LE_EXPR;
3618       goto relational;          /* :::::::::::::::::::: */
3619
3620     case FFEBLD_opEQ:
3621       code = EQ_EXPR;
3622       goto relational;          /* :::::::::::::::::::: */
3623
3624     case FFEBLD_opNE:
3625       code = NE_EXPR;
3626       goto relational;          /* :::::::::::::::::::: */
3627
3628     case FFEBLD_opGT:
3629       code = GT_EXPR;
3630       goto relational;          /* :::::::::::::::::::: */
3631
3632     case FFEBLD_opGE:
3633       code = GE_EXPR;
3634
3635     relational:         /* :::::::::::::::::::: */
3636       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3637         {
3638         case FFEINFO_basictypeLOGICAL:
3639         case FFEINFO_basictypeINTEGER:
3640         case FFEINFO_basictypeREAL:
3641           item = ffecom_2 (code, integer_type_node,
3642                            ffecom_expr (ffebld_left (expr)),
3643                            ffecom_expr (ffebld_right (expr)));
3644           return convert (tree_type, item);
3645
3646         case FFEINFO_basictypeCOMPLEX:
3647           assert (code == EQ_EXPR || code == NE_EXPR);
3648           {
3649             tree real_type;
3650             tree arg1 = ffecom_expr (ffebld_left (expr));
3651             tree arg2 = ffecom_expr (ffebld_right (expr));
3652
3653             if (arg1 == error_mark_node || arg2 == error_mark_node)
3654               return error_mark_node;
3655
3656             arg1 = ffecom_save_tree (arg1);
3657             arg2 = ffecom_save_tree (arg2);
3658
3659             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3660               {
3661                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3662                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3663               }
3664             else
3665               {
3666                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3667                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3668               }
3669
3670             item
3671               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3672                           ffecom_2 (EQ_EXPR, integer_type_node,
3673                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3674                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3675                           ffecom_2 (EQ_EXPR, integer_type_node,
3676                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3677                                     ffecom_1 (IMAGPART_EXPR, real_type,
3678                                               arg2)));
3679             if (code == EQ_EXPR)
3680               item = ffecom_truth_value (item);
3681             else
3682               item = ffecom_truth_value_invert (item);
3683             return convert (tree_type, item);
3684           }
3685
3686         case FFEINFO_basictypeCHARACTER:
3687           {
3688             ffebld left = ffebld_left (expr);
3689             ffebld right = ffebld_right (expr);
3690             tree left_tree;
3691             tree right_tree;
3692             tree left_length;
3693             tree right_length;
3694
3695             /* f2c run-time functions do the implicit blank-padding for us,
3696                so we don't usually have to implement blank-padding ourselves.
3697                (The exception is when we pass an argument to a separately
3698                compiled statement function -- if we know the arg is not the
3699                same length as the dummy, we must truncate or extend it.  If
3700                we "inline" statement functions, that necessity goes away as
3701                well.)
3702
3703                Strip off the CONVERT operators that blank-pad.  (Truncation by
3704                CONVERT shouldn't happen here, but it can happen in
3705                assignments.) */
3706
3707             while (ffebld_op (left) == FFEBLD_opCONVERT)
3708               left = ffebld_left (left);
3709             while (ffebld_op (right) == FFEBLD_opCONVERT)
3710               right = ffebld_left (right);
3711
3712             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3713             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3714
3715             if (left_tree == error_mark_node || left_length == error_mark_node
3716                 || right_tree == error_mark_node
3717                 || right_length == error_mark_node)
3718               return error_mark_node;
3719
3720             if ((ffebld_size_known (left) == 1)
3721                 && (ffebld_size_known (right) == 1))
3722               {
3723                 left_tree
3724                   = ffecom_1 (INDIRECT_REF,
3725                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3726                               left_tree);
3727                 right_tree
3728                   = ffecom_1 (INDIRECT_REF,
3729                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3730                               right_tree);
3731
3732                 item
3733                   = ffecom_2 (code, integer_type_node,
3734                               ffecom_2 (ARRAY_REF,
3735                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3736                                         left_tree,
3737                                         integer_one_node),
3738                               ffecom_2 (ARRAY_REF,
3739                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3740                                         right_tree,
3741                                         integer_one_node));
3742               }
3743             else
3744               {
3745                 item = build_tree_list (NULL_TREE, left_tree);
3746                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3747                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3748                                                                left_length);
3749                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3750                   = build_tree_list (NULL_TREE, right_length);
3751                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3752                 item = ffecom_2 (code, integer_type_node,
3753                                  item,
3754                                  convert (TREE_TYPE (item),
3755                                           integer_zero_node));
3756               }
3757             item = convert (tree_type, item);
3758           }
3759
3760           return item;
3761
3762         default:
3763           assert ("relational bad basictype" == NULL);
3764           /* Fall through. */
3765         case FFEINFO_basictypeANY:
3766           return error_mark_node;
3767         }
3768       break;
3769
3770     case FFEBLD_opPERCENT_LOC:
3771       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3772       return convert (tree_type, item);
3773
3774     case FFEBLD_opITEM:
3775     case FFEBLD_opSTAR:
3776     case FFEBLD_opBOUNDS:
3777     case FFEBLD_opREPEAT:
3778     case FFEBLD_opLABTER:
3779     case FFEBLD_opLABTOK:
3780     case FFEBLD_opIMPDO:
3781     case FFEBLD_opCONCATENATE:
3782     case FFEBLD_opSUBSTR:
3783     default:
3784       assert ("bad op" == NULL);
3785       /* Fall through. */
3786     case FFEBLD_opANY:
3787       return error_mark_node;
3788     }
3789
3790 #if 1
3791   assert ("didn't think anything got here anymore!!" == NULL);
3792 #else
3793   switch (ffebld_arity (expr))
3794     {
3795     case 2:
3796       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3797       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3798       if (TREE_OPERAND (item, 0) == error_mark_node
3799           || TREE_OPERAND (item, 1) == error_mark_node)
3800         return error_mark_node;
3801       break;
3802
3803     case 1:
3804       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3805       if (TREE_OPERAND (item, 0) == error_mark_node)
3806         return error_mark_node;
3807       break;
3808
3809     default:
3810       break;
3811     }
3812
3813   return fold (item);
3814 #endif
3815 }
3816
3817 #endif
3818 /* Returns the tree that does the intrinsic invocation.
3819
3820    Note: this function applies only to intrinsics returning
3821    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3822    subroutines.  */
3823
3824 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3825 static tree
3826 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3827                         ffebld dest, bool *dest_used)
3828 {
3829   tree expr_tree;
3830   tree saved_expr1;             /* For those who need it. */
3831   tree saved_expr2;             /* For those who need it. */
3832   ffeinfoBasictype bt;
3833   ffeinfoKindtype kt;
3834   tree tree_type;
3835   tree arg1_type;
3836   tree real_type;               /* REAL type corresponding to COMPLEX. */
3837   tree tempvar;
3838   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3839   ffebld arg1;                  /* For handy reference. */
3840   ffebld arg2;
3841   ffebld arg3;
3842   ffeintrinImp codegen_imp;
3843   ffecomGfrt gfrt;
3844
3845   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3846
3847   if (dest_used != NULL)
3848     *dest_used = FALSE;
3849
3850   bt = ffeinfo_basictype (ffebld_info (expr));
3851   kt = ffeinfo_kindtype (ffebld_info (expr));
3852   tree_type = ffecom_tree_type[bt][kt];
3853
3854   if (list != NULL)
3855     {
3856       arg1 = ffebld_head (list);
3857       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3858         return error_mark_node;
3859       if ((list = ffebld_trail (list)) != NULL)
3860         {
3861           arg2 = ffebld_head (list);
3862           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3863             return error_mark_node;
3864           if ((list = ffebld_trail (list)) != NULL)
3865             {
3866               arg3 = ffebld_head (list);
3867               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3868                 return error_mark_node;
3869             }
3870           else
3871             arg3 = NULL;
3872         }
3873       else
3874         arg2 = arg3 = NULL;
3875     }
3876   else
3877     arg1 = arg2 = arg3 = NULL;
3878
3879   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3880      args.  This is used by the MAX/MIN expansions. */
3881
3882   if (arg1 != NULL)
3883     arg1_type = ffecom_tree_type
3884       [ffeinfo_basictype (ffebld_info (arg1))]
3885       [ffeinfo_kindtype (ffebld_info (arg1))];
3886   else
3887     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3888                                    here. */
3889
3890   /* There are several ways for each of the cases in the following switch
3891      statements to exit (from simplest to use to most complicated):
3892
3893      break;  (when expr_tree == NULL)
3894
3895      A standard call is made to the specific intrinsic just as if it had been
3896      passed in as a dummy procedure and called as any old procedure.  This
3897      method can produce slower code but in some cases it's the easiest way for
3898      now.  However, if a (presumably faster) direct call is available,
3899      that is used, so this is the easiest way in many more cases now.
3900
3901      gfrt = FFECOM_gfrtWHATEVER;
3902      break;
3903
3904      gfrt contains the gfrt index of a library function to call, passing the
3905      argument(s) by value rather than by reference.  Used when a more
3906      careful choice of library function is needed than that provided
3907      by the vanilla `break;'.
3908
3909      return expr_tree;
3910
3911      The expr_tree has been completely set up and is ready to be returned
3912      as is.  No further actions are taken.  Use this when the tree is not
3913      in the simple form for one of the arity_n labels.   */
3914
3915   /* For info on how the switch statement cases were written, see the files
3916      enclosed in comments below the switch statement. */
3917
3918   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3919   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3920   if (gfrt == FFECOM_gfrt)
3921     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3922
3923   switch (codegen_imp)
3924     {
3925     case FFEINTRIN_impABS:
3926     case FFEINTRIN_impCABS:
3927     case FFEINTRIN_impCDABS:
3928     case FFEINTRIN_impDABS:
3929     case FFEINTRIN_impIABS:
3930       if (ffeinfo_basictype (ffebld_info (arg1))
3931           == FFEINFO_basictypeCOMPLEX)
3932         {
3933           if (kt == FFEINFO_kindtypeREAL1)
3934             gfrt = FFECOM_gfrtCABS;
3935           else if (kt == FFEINFO_kindtypeREAL2)
3936             gfrt = FFECOM_gfrtCDABS;
3937           break;
3938         }
3939       return ffecom_1 (ABS_EXPR, tree_type,
3940                        convert (tree_type, ffecom_expr (arg1)));
3941
3942     case FFEINTRIN_impACOS:
3943     case FFEINTRIN_impDACOS:
3944       break;
3945
3946     case FFEINTRIN_impAIMAG:
3947     case FFEINTRIN_impDIMAG:
3948     case FFEINTRIN_impIMAGPART:
3949       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3950         arg1_type = TREE_TYPE (arg1_type);
3951       else
3952         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3953
3954       return
3955         convert (tree_type,
3956                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3957                            ffecom_expr (arg1)));
3958
3959     case FFEINTRIN_impAINT:
3960     case FFEINTRIN_impDINT:
3961 #if 0
3962       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3963       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3964 #else /* in the meantime, must use floor to avoid range problems with ints */
3965       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3966       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3967       return
3968         convert (tree_type,
3969                  ffecom_3 (COND_EXPR, double_type_node,
3970                            ffecom_truth_value
3971                            (ffecom_2 (GE_EXPR, integer_type_node,
3972                                       saved_expr1,
3973                                       convert (arg1_type,
3974                                                ffecom_float_zero_))),
3975                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3976                                              build_tree_list (NULL_TREE,
3977                                                   convert (double_type_node,
3978                                                            saved_expr1)),
3979                                              NULL_TREE),
3980                            ffecom_1 (NEGATE_EXPR, double_type_node,
3981                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3982                                                  build_tree_list (NULL_TREE,
3983                                                   convert (double_type_node,
3984                                                       ffecom_1 (NEGATE_EXPR,
3985                                                                 arg1_type,
3986                                                                saved_expr1))),
3987                                                        NULL_TREE)
3988                                      ))
3989                  );
3990 #endif
3991
3992     case FFEINTRIN_impANINT:
3993     case FFEINTRIN_impDNINT:
3994 #if 0                           /* This way of doing it won't handle real
3995                                    numbers of large magnitudes. */
3996       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3997       expr_tree = convert (tree_type,
3998                            convert (integer_type_node,
3999                                     ffecom_3 (COND_EXPR, tree_type,
4000                                               ffecom_truth_value
4001                                               (ffecom_2 (GE_EXPR,
4002                                                          integer_type_node,
4003                                                          saved_expr1,
4004                                                        ffecom_float_zero_)),
4005                                               ffecom_2 (PLUS_EXPR,
4006                                                         tree_type,
4007                                                         saved_expr1,
4008                                                         ffecom_float_half_),
4009                                               ffecom_2 (MINUS_EXPR,
4010                                                         tree_type,
4011                                                         saved_expr1,
4012                                                      ffecom_float_half_))));
4013       return expr_tree;
4014 #else /* So we instead call floor. */
4015       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4016       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4017       return
4018         convert (tree_type,
4019                  ffecom_3 (COND_EXPR, double_type_node,
4020                            ffecom_truth_value
4021                            (ffecom_2 (GE_EXPR, integer_type_node,
4022                                       saved_expr1,
4023                                       convert (arg1_type,
4024                                                ffecom_float_zero_))),
4025                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4026                                              build_tree_list (NULL_TREE,
4027                                                   convert (double_type_node,
4028                                                            ffecom_2 (PLUS_EXPR,
4029                                                                      arg1_type,
4030                                                                      saved_expr1,
4031                                                                      convert (arg1_type,
4032                                                                               ffecom_float_half_)))),
4033                                              NULL_TREE),
4034                            ffecom_1 (NEGATE_EXPR, double_type_node,
4035                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4036                                                        build_tree_list (NULL_TREE,
4037                                                                         convert (double_type_node,
4038                                                                                  ffecom_2 (MINUS_EXPR,
4039                                                                                            arg1_type,
4040                                                                                            convert (arg1_type,
4041                                                                                                     ffecom_float_half_),
4042                                                                                            saved_expr1))),
4043                                                        NULL_TREE))
4044                            )
4045                  );
4046 #endif
4047
4048     case FFEINTRIN_impASIN:
4049     case FFEINTRIN_impDASIN:
4050     case FFEINTRIN_impATAN:
4051     case FFEINTRIN_impDATAN:
4052     case FFEINTRIN_impATAN2:
4053     case FFEINTRIN_impDATAN2:
4054       break;
4055
4056     case FFEINTRIN_impCHAR:
4057     case FFEINTRIN_impACHAR:
4058 #ifdef HOHO
4059       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4060 #else
4061       tempvar = ffebld_nonter_hook (expr);
4062       assert (tempvar);
4063 #endif
4064       {
4065         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4066
4067         expr_tree = ffecom_modify (tmv,
4068                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4069                                              integer_one_node),
4070                                    convert (tmv, ffecom_expr (arg1)));
4071       }
4072       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4073                             expr_tree,
4074                             tempvar);
4075       expr_tree = ffecom_1 (ADDR_EXPR,
4076                             build_pointer_type (TREE_TYPE (expr_tree)),
4077                             expr_tree);
4078       return expr_tree;
4079
4080     case FFEINTRIN_impCMPLX:
4081     case FFEINTRIN_impDCMPLX:
4082       if (arg2 == NULL)
4083         return
4084           convert (tree_type, ffecom_expr (arg1));
4085
4086       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4087       return
4088         ffecom_2 (COMPLEX_EXPR, tree_type,
4089                   convert (real_type, ffecom_expr (arg1)),
4090                   convert (real_type,
4091                            ffecom_expr (arg2)));
4092
4093     case FFEINTRIN_impCOMPLEX:
4094       return
4095         ffecom_2 (COMPLEX_EXPR, tree_type,
4096                   ffecom_expr (arg1),
4097                   ffecom_expr (arg2));
4098
4099     case FFEINTRIN_impCONJG:
4100     case FFEINTRIN_impDCONJG:
4101       {
4102         tree arg1_tree;
4103
4104         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4105         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4106         return
4107           ffecom_2 (COMPLEX_EXPR, tree_type,
4108                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4109                     ffecom_1 (NEGATE_EXPR, real_type,
4110                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4111       }
4112
4113     case FFEINTRIN_impCOS:
4114     case FFEINTRIN_impCCOS:
4115     case FFEINTRIN_impCDCOS:
4116     case FFEINTRIN_impDCOS:
4117       if (bt == FFEINFO_basictypeCOMPLEX)
4118         {
4119           if (kt == FFEINFO_kindtypeREAL1)
4120             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4121           else if (kt == FFEINFO_kindtypeREAL2)
4122             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4123         }
4124       break;
4125
4126     case FFEINTRIN_impCOSH:
4127     case FFEINTRIN_impDCOSH:
4128       break;
4129
4130     case FFEINTRIN_impDBLE:
4131     case FFEINTRIN_impDFLOAT:
4132     case FFEINTRIN_impDREAL:
4133     case FFEINTRIN_impFLOAT:
4134     case FFEINTRIN_impIDINT:
4135     case FFEINTRIN_impIFIX:
4136     case FFEINTRIN_impINT2:
4137     case FFEINTRIN_impINT8:
4138     case FFEINTRIN_impINT:
4139     case FFEINTRIN_impLONG:
4140     case FFEINTRIN_impREAL:
4141     case FFEINTRIN_impSHORT:
4142     case FFEINTRIN_impSNGL:
4143       return convert (tree_type, ffecom_expr (arg1));
4144
4145     case FFEINTRIN_impDIM:
4146     case FFEINTRIN_impDDIM:
4147     case FFEINTRIN_impIDIM:
4148       saved_expr1 = ffecom_save_tree (convert (tree_type,
4149                                                ffecom_expr (arg1)));
4150       saved_expr2 = ffecom_save_tree (convert (tree_type,
4151                                                ffecom_expr (arg2)));
4152       return
4153         ffecom_3 (COND_EXPR, tree_type,
4154                   ffecom_truth_value
4155                   (ffecom_2 (GT_EXPR, integer_type_node,
4156                              saved_expr1,
4157                              saved_expr2)),
4158                   ffecom_2 (MINUS_EXPR, tree_type,
4159                             saved_expr1,
4160                             saved_expr2),
4161                   convert (tree_type, ffecom_float_zero_));
4162
4163     case FFEINTRIN_impDPROD:
4164       return
4165         ffecom_2 (MULT_EXPR, tree_type,
4166                   convert (tree_type, ffecom_expr (arg1)),
4167                   convert (tree_type, ffecom_expr (arg2)));
4168
4169     case FFEINTRIN_impEXP:
4170     case FFEINTRIN_impCDEXP:
4171     case FFEINTRIN_impCEXP:
4172     case FFEINTRIN_impDEXP:
4173       if (bt == FFEINFO_basictypeCOMPLEX)
4174         {
4175           if (kt == FFEINFO_kindtypeREAL1)
4176             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4177           else if (kt == FFEINFO_kindtypeREAL2)
4178             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4179         }
4180       break;
4181
4182     case FFEINTRIN_impICHAR:
4183     case FFEINTRIN_impIACHAR:
4184 #if 0                           /* The simple approach. */
4185       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4186       expr_tree
4187         = ffecom_1 (INDIRECT_REF,
4188                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4189                     expr_tree);
4190       expr_tree
4191         = ffecom_2 (ARRAY_REF,
4192                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4193                     expr_tree,
4194                     integer_one_node);
4195       return convert (tree_type, expr_tree);
4196 #else /* The more interesting (and more optimal) approach. */
4197       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4198       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4199                             saved_expr1,
4200                             expr_tree,
4201                             convert (tree_type, integer_zero_node));
4202       return expr_tree;
4203 #endif
4204
4205     case FFEINTRIN_impINDEX:
4206       break;
4207
4208     case FFEINTRIN_impLEN:
4209 #if 0
4210       break;                                    /* The simple approach. */
4211 #else
4212       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4213 #endif
4214
4215     case FFEINTRIN_impLGE:
4216     case FFEINTRIN_impLGT:
4217     case FFEINTRIN_impLLE:
4218     case FFEINTRIN_impLLT:
4219       break;
4220
4221     case FFEINTRIN_impLOG:
4222     case FFEINTRIN_impALOG:
4223     case FFEINTRIN_impCDLOG:
4224     case FFEINTRIN_impCLOG:
4225     case FFEINTRIN_impDLOG:
4226       if (bt == FFEINFO_basictypeCOMPLEX)
4227         {
4228           if (kt == FFEINFO_kindtypeREAL1)
4229             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4230           else if (kt == FFEINFO_kindtypeREAL2)
4231             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4232         }
4233       break;
4234
4235     case FFEINTRIN_impLOG10:
4236     case FFEINTRIN_impALOG10:
4237     case FFEINTRIN_impDLOG10:
4238       if (gfrt != FFECOM_gfrt)
4239         break;  /* Already picked one, stick with it. */
4240
4241       if (kt == FFEINFO_kindtypeREAL1)
4242         /* We used to call FFECOM_gfrtALOG10 here.  */
4243         gfrt = FFECOM_gfrtL_LOG10;
4244       else if (kt == FFEINFO_kindtypeREAL2)
4245         /* We used to call FFECOM_gfrtDLOG10 here.  */
4246         gfrt = FFECOM_gfrtL_LOG10;
4247       break;
4248
4249     case FFEINTRIN_impMAX:
4250     case FFEINTRIN_impAMAX0:
4251     case FFEINTRIN_impAMAX1:
4252     case FFEINTRIN_impDMAX1:
4253     case FFEINTRIN_impMAX0:
4254     case FFEINTRIN_impMAX1:
4255       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4256         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4257       else
4258         arg1_type = tree_type;
4259       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4260                             convert (arg1_type, ffecom_expr (arg1)),
4261                             convert (arg1_type, ffecom_expr (arg2)));
4262       for (; list != NULL; list = ffebld_trail (list))
4263         {
4264           if ((ffebld_head (list) == NULL)
4265               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4266             continue;
4267           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4268                                 expr_tree,
4269                                 convert (arg1_type,
4270                                          ffecom_expr (ffebld_head (list))));
4271         }
4272       return convert (tree_type, expr_tree);
4273
4274     case FFEINTRIN_impMIN:
4275     case FFEINTRIN_impAMIN0:
4276     case FFEINTRIN_impAMIN1:
4277     case FFEINTRIN_impDMIN1:
4278     case FFEINTRIN_impMIN0:
4279     case FFEINTRIN_impMIN1:
4280       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4281         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4282       else
4283         arg1_type = tree_type;
4284       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4285                             convert (arg1_type, ffecom_expr (arg1)),
4286                             convert (arg1_type, ffecom_expr (arg2)));
4287       for (; list != NULL; list = ffebld_trail (list))
4288         {
4289           if ((ffebld_head (list) == NULL)
4290               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4291             continue;
4292           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4293                                 expr_tree,
4294                                 convert (arg1_type,
4295                                          ffecom_expr (ffebld_head (list))));
4296         }
4297       return convert (tree_type, expr_tree);
4298
4299     case FFEINTRIN_impMOD:
4300     case FFEINTRIN_impAMOD:
4301     case FFEINTRIN_impDMOD:
4302       if (bt != FFEINFO_basictypeREAL)
4303         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4304                          convert (tree_type, ffecom_expr (arg1)),
4305                          convert (tree_type, ffecom_expr (arg2)));
4306
4307       if (kt == FFEINFO_kindtypeREAL1)
4308         /* We used to call FFECOM_gfrtAMOD here.  */
4309         gfrt = FFECOM_gfrtL_FMOD;
4310       else if (kt == FFEINFO_kindtypeREAL2)
4311         /* We used to call FFECOM_gfrtDMOD here.  */
4312         gfrt = FFECOM_gfrtL_FMOD;
4313       break;
4314
4315     case FFEINTRIN_impNINT:
4316     case FFEINTRIN_impIDNINT:
4317 #if 0
4318       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4319       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4320 #else
4321       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4322       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4323       return
4324         convert (ffecom_integer_type_node,
4325                  ffecom_3 (COND_EXPR, arg1_type,
4326                            ffecom_truth_value
4327                            (ffecom_2 (GE_EXPR, integer_type_node,
4328                                       saved_expr1,
4329                                       convert (arg1_type,
4330                                                ffecom_float_zero_))),
4331                            ffecom_2 (PLUS_EXPR, arg1_type,
4332                                      saved_expr1,
4333                                      convert (arg1_type,
4334                                               ffecom_float_half_)),
4335                            ffecom_2 (MINUS_EXPR, arg1_type,
4336                                      saved_expr1,
4337                                      convert (arg1_type,
4338                                               ffecom_float_half_))));
4339 #endif
4340
4341     case FFEINTRIN_impSIGN:
4342     case FFEINTRIN_impDSIGN:
4343     case FFEINTRIN_impISIGN:
4344       {
4345         tree arg2_tree = ffecom_expr (arg2);
4346
4347         saved_expr1
4348           = ffecom_save_tree
4349           (ffecom_1 (ABS_EXPR, tree_type,
4350                      convert (tree_type,
4351                               ffecom_expr (arg1))));
4352         expr_tree
4353           = ffecom_3 (COND_EXPR, tree_type,
4354                       ffecom_truth_value
4355                       (ffecom_2 (GE_EXPR, integer_type_node,
4356                                  arg2_tree,
4357                                  convert (TREE_TYPE (arg2_tree),
4358                                           integer_zero_node))),
4359                       saved_expr1,
4360                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4361         /* Make sure SAVE_EXPRs get referenced early enough. */
4362         expr_tree
4363           = ffecom_2 (COMPOUND_EXPR, tree_type,
4364                       convert (void_type_node, saved_expr1),
4365                       expr_tree);
4366       }
4367       return expr_tree;
4368
4369     case FFEINTRIN_impSIN:
4370     case FFEINTRIN_impCDSIN:
4371     case FFEINTRIN_impCSIN:
4372     case FFEINTRIN_impDSIN:
4373       if (bt == FFEINFO_basictypeCOMPLEX)
4374         {
4375           if (kt == FFEINFO_kindtypeREAL1)
4376             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4377           else if (kt == FFEINFO_kindtypeREAL2)
4378             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4379         }
4380       break;
4381
4382     case FFEINTRIN_impSINH:
4383     case FFEINTRIN_impDSINH:
4384       break;
4385
4386     case FFEINTRIN_impSQRT:
4387     case FFEINTRIN_impCDSQRT:
4388     case FFEINTRIN_impCSQRT:
4389     case FFEINTRIN_impDSQRT:
4390       if (bt == FFEINFO_basictypeCOMPLEX)
4391         {
4392           if (kt == FFEINFO_kindtypeREAL1)
4393             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4394           else if (kt == FFEINFO_kindtypeREAL2)
4395             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4396         }
4397       break;
4398
4399     case FFEINTRIN_impTAN:
4400     case FFEINTRIN_impDTAN:
4401     case FFEINTRIN_impTANH:
4402     case FFEINTRIN_impDTANH:
4403       break;
4404
4405     case FFEINTRIN_impREALPART:
4406       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4407         arg1_type = TREE_TYPE (arg1_type);
4408       else
4409         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4410
4411       return
4412         convert (tree_type,
4413                  ffecom_1 (REALPART_EXPR, arg1_type,
4414                            ffecom_expr (arg1)));
4415
4416     case FFEINTRIN_impIAND:
4417     case FFEINTRIN_impAND:
4418       return ffecom_2 (BIT_AND_EXPR, tree_type,
4419                        convert (tree_type,
4420                                 ffecom_expr (arg1)),
4421                        convert (tree_type,
4422                                 ffecom_expr (arg2)));
4423
4424     case FFEINTRIN_impIOR:
4425     case FFEINTRIN_impOR:
4426       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4427                        convert (tree_type,
4428                                 ffecom_expr (arg1)),
4429                        convert (tree_type,
4430                                 ffecom_expr (arg2)));
4431
4432     case FFEINTRIN_impIEOR:
4433     case FFEINTRIN_impXOR:
4434       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4435                        convert (tree_type,
4436                                 ffecom_expr (arg1)),
4437                        convert (tree_type,
4438                                 ffecom_expr (arg2)));
4439
4440     case FFEINTRIN_impLSHIFT:
4441       return ffecom_2 (LSHIFT_EXPR, tree_type,
4442                        ffecom_expr (arg1),
4443                        convert (integer_type_node,
4444                                 ffecom_expr (arg2)));
4445
4446     case FFEINTRIN_impRSHIFT:
4447       return ffecom_2 (RSHIFT_EXPR, tree_type,
4448                        ffecom_expr (arg1),
4449                        convert (integer_type_node,
4450                                 ffecom_expr (arg2)));
4451
4452     case FFEINTRIN_impNOT:
4453       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4454
4455     case FFEINTRIN_impBIT_SIZE:
4456       return convert (tree_type, TYPE_SIZE (arg1_type));
4457
4458     case FFEINTRIN_impBTEST:
4459       {
4460         ffetargetLogical1 target_true;
4461         ffetargetLogical1 target_false;
4462         tree true_tree;
4463         tree false_tree;
4464
4465         ffetarget_logical1 (&target_true, TRUE);
4466         ffetarget_logical1 (&target_false, FALSE);
4467         if (target_true == 1)
4468           true_tree = convert (tree_type, integer_one_node);
4469         else
4470           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4471         if (target_false == 0)
4472           false_tree = convert (tree_type, integer_zero_node);
4473         else
4474           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4475
4476         return
4477           ffecom_3 (COND_EXPR, tree_type,
4478                     ffecom_truth_value
4479                     (ffecom_2 (EQ_EXPR, integer_type_node,
4480                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4481                                          ffecom_expr (arg1),
4482                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4483                                                    convert (arg1_type,
4484                                                           integer_one_node),
4485                                                    convert (integer_type_node,
4486                                                             ffecom_expr (arg2)))),
4487                                convert (arg1_type,
4488                                         integer_zero_node))),
4489                     false_tree,
4490                     true_tree);
4491       }
4492
4493     case FFEINTRIN_impIBCLR:
4494       return
4495         ffecom_2 (BIT_AND_EXPR, tree_type,
4496                   ffecom_expr (arg1),
4497                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4498                             ffecom_2 (LSHIFT_EXPR, tree_type,
4499                                       convert (tree_type,
4500                                                integer_one_node),
4501                                       convert (integer_type_node,
4502                                                ffecom_expr (arg2)))));
4503
4504     case FFEINTRIN_impIBITS:
4505       {
4506         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4507                                                     ffecom_expr (arg3)));
4508         tree uns_type
4509         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4510
4511         expr_tree
4512           = ffecom_2 (BIT_AND_EXPR, tree_type,
4513                       ffecom_2 (RSHIFT_EXPR, tree_type,
4514                                 ffecom_expr (arg1),
4515                                 convert (integer_type_node,
4516                                          ffecom_expr (arg2))),
4517                       convert (tree_type,
4518                                ffecom_2 (RSHIFT_EXPR, uns_type,
4519                                          ffecom_1 (BIT_NOT_EXPR,
4520                                                    uns_type,
4521                                                    convert (uns_type,
4522                                                         integer_zero_node)),
4523                                          ffecom_2 (MINUS_EXPR,
4524                                                    integer_type_node,
4525                                                    TYPE_SIZE (uns_type),
4526                                                    arg3_tree))));
4527 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4528         expr_tree
4529           = ffecom_3 (COND_EXPR, tree_type,
4530                       ffecom_truth_value
4531                       (ffecom_2 (NE_EXPR, integer_type_node,
4532                                  arg3_tree,
4533                                  integer_zero_node)),
4534                       expr_tree,
4535                       convert (tree_type, integer_zero_node));
4536 #endif
4537       }
4538       return expr_tree;
4539
4540     case FFEINTRIN_impIBSET:
4541       return
4542         ffecom_2 (BIT_IOR_EXPR, tree_type,
4543                   ffecom_expr (arg1),
4544                   ffecom_2 (LSHIFT_EXPR, tree_type,
4545                             convert (tree_type, integer_one_node),
4546                             convert (integer_type_node,
4547                                      ffecom_expr (arg2))));
4548
4549     case FFEINTRIN_impISHFT:
4550       {
4551         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4552         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4553                                                     ffecom_expr (arg2)));
4554         tree uns_type
4555         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4556
4557         expr_tree
4558           = ffecom_3 (COND_EXPR, tree_type,
4559                       ffecom_truth_value
4560                       (ffecom_2 (GE_EXPR, integer_type_node,
4561                                  arg2_tree,
4562                                  integer_zero_node)),
4563                       ffecom_2 (LSHIFT_EXPR, tree_type,
4564                                 arg1_tree,
4565                                 arg2_tree),
4566                       convert (tree_type,
4567                                ffecom_2 (RSHIFT_EXPR, uns_type,
4568                                          convert (uns_type, arg1_tree),
4569                                          ffecom_1 (NEGATE_EXPR,
4570                                                    integer_type_node,
4571                                                    arg2_tree))));
4572 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4573         expr_tree
4574           = ffecom_3 (COND_EXPR, tree_type,
4575                       ffecom_truth_value
4576                       (ffecom_2 (LT_EXPR, integer_type_node,
4577                                  ffecom_1 (ABS_EXPR,
4578                                            integer_type_node,
4579                                            arg2_tree),
4580                                  TYPE_SIZE (uns_type))),
4581                       expr_tree,
4582                       convert (tree_type, integer_zero_node));
4583 #endif
4584         /* Make sure SAVE_EXPRs get referenced early enough. */
4585         expr_tree
4586           = ffecom_2 (COMPOUND_EXPR, tree_type,
4587                       convert (void_type_node, arg1_tree),
4588                       ffecom_2 (COMPOUND_EXPR, tree_type,
4589                                 convert (void_type_node, arg2_tree),
4590                                 expr_tree));
4591       }
4592       return expr_tree;
4593
4594     case FFEINTRIN_impISHFTC:
4595       {
4596         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4597         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4598                                                     ffecom_expr (arg2)));
4599         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4600         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4601         tree shift_neg;
4602         tree shift_pos;
4603         tree mask_arg1;
4604         tree masked_arg1;
4605         tree uns_type
4606         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4607
4608         mask_arg1
4609           = ffecom_2 (LSHIFT_EXPR, tree_type,
4610                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4611                                 convert (tree_type, integer_zero_node)),
4612                       arg3_tree);
4613 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4614         mask_arg1
4615           = ffecom_3 (COND_EXPR, tree_type,
4616                       ffecom_truth_value
4617                       (ffecom_2 (NE_EXPR, integer_type_node,
4618                                  arg3_tree,
4619                                  TYPE_SIZE (uns_type))),
4620                       mask_arg1,
4621                       convert (tree_type, integer_zero_node));
4622 #endif
4623         mask_arg1 = ffecom_save_tree (mask_arg1);
4624         masked_arg1
4625           = ffecom_2 (BIT_AND_EXPR, tree_type,
4626                       arg1_tree,
4627                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4628                                 mask_arg1));
4629         masked_arg1 = ffecom_save_tree (masked_arg1);
4630         shift_neg
4631           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4632                       convert (tree_type,
4633                                ffecom_2 (RSHIFT_EXPR, uns_type,
4634                                          convert (uns_type, masked_arg1),
4635                                          ffecom_1 (NEGATE_EXPR,
4636                                                    integer_type_node,
4637                                                    arg2_tree))),
4638                       ffecom_2 (LSHIFT_EXPR, tree_type,
4639                                 arg1_tree,
4640                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4641                                           arg2_tree,
4642                                           arg3_tree)));
4643         shift_pos
4644           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4645                       ffecom_2 (LSHIFT_EXPR, tree_type,
4646                                 arg1_tree,
4647                                 arg2_tree),
4648                       convert (tree_type,
4649                                ffecom_2 (RSHIFT_EXPR, uns_type,
4650                                          convert (uns_type, masked_arg1),
4651                                          ffecom_2 (MINUS_EXPR,
4652                                                    integer_type_node,
4653                                                    arg3_tree,
4654                                                    arg2_tree))));
4655         expr_tree
4656           = ffecom_3 (COND_EXPR, tree_type,
4657                       ffecom_truth_value
4658                       (ffecom_2 (LT_EXPR, integer_type_node,
4659                                  arg2_tree,
4660                                  integer_zero_node)),
4661                       shift_neg,
4662                       shift_pos);
4663         expr_tree
4664           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4665                       ffecom_2 (BIT_AND_EXPR, tree_type,
4666                                 mask_arg1,
4667                                 arg1_tree),
4668                       ffecom_2 (BIT_AND_EXPR, tree_type,
4669                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4670                                           mask_arg1),
4671                                 expr_tree));
4672         expr_tree
4673           = ffecom_3 (COND_EXPR, tree_type,
4674                       ffecom_truth_value
4675                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4676                                  ffecom_2 (EQ_EXPR, integer_type_node,
4677                                            ffecom_1 (ABS_EXPR,
4678                                                      integer_type_node,
4679                                                      arg2_tree),
4680                                            arg3_tree),
4681                                  ffecom_2 (EQ_EXPR, integer_type_node,
4682                                            arg2_tree,
4683                                            integer_zero_node))),
4684                       arg1_tree,
4685                       expr_tree);
4686         /* Make sure SAVE_EXPRs get referenced early enough. */
4687         expr_tree
4688           = ffecom_2 (COMPOUND_EXPR, tree_type,
4689                       convert (void_type_node, arg1_tree),
4690                       ffecom_2 (COMPOUND_EXPR, tree_type,
4691                                 convert (void_type_node, arg2_tree),
4692                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4693                                           convert (void_type_node,
4694                                                    mask_arg1),
4695                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4696                                                     convert (void_type_node,
4697                                                              masked_arg1),
4698                                                     expr_tree))));
4699         expr_tree
4700           = ffecom_2 (COMPOUND_EXPR, tree_type,
4701                       convert (void_type_node,
4702                                arg3_tree),
4703                       expr_tree);
4704       }
4705       return expr_tree;
4706
4707     case FFEINTRIN_impLOC:
4708       {
4709         tree arg1_tree = ffecom_expr (arg1);
4710
4711         expr_tree
4712           = convert (tree_type,
4713                      ffecom_1 (ADDR_EXPR,
4714                                build_pointer_type (TREE_TYPE (arg1_tree)),
4715                                arg1_tree));
4716       }
4717       return expr_tree;
4718
4719     case FFEINTRIN_impMVBITS:
4720       {
4721         tree arg1_tree;
4722         tree arg2_tree;
4723         tree arg3_tree;
4724         ffebld arg4 = ffebld_head (ffebld_trail (list));
4725         tree arg4_tree;
4726         tree arg4_type;
4727         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4728         tree arg5_tree;
4729         tree prep_arg1;
4730         tree prep_arg4;
4731         tree arg5_plus_arg3;
4732
4733         arg2_tree = convert (integer_type_node,
4734                              ffecom_expr (arg2));
4735         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4736                                                ffecom_expr (arg3)));
4737         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4738         arg4_type = TREE_TYPE (arg4_tree);
4739
4740         arg1_tree = ffecom_save_tree (convert (arg4_type,
4741                                                ffecom_expr (arg1)));
4742
4743         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4744                                                ffecom_expr (arg5)));
4745
4746         prep_arg1
4747           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4748                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4749                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4750                                           arg1_tree,
4751                                           arg2_tree),
4752                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4753                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4754                                                     ffecom_1 (BIT_NOT_EXPR,
4755                                                               arg4_type,
4756                                                               convert
4757                                                               (arg4_type,
4758                                                         integer_zero_node)),
4759                                                     arg3_tree))),
4760                       arg5_tree);
4761         arg5_plus_arg3
4762           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4763                                         arg5_tree,
4764                                         arg3_tree));
4765         prep_arg4
4766           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4767                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4768                                 convert (arg4_type,
4769                                          integer_zero_node)),
4770                       arg5_plus_arg3);
4771 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4772         prep_arg4
4773           = ffecom_3 (COND_EXPR, arg4_type,
4774                       ffecom_truth_value
4775                       (ffecom_2 (NE_EXPR, integer_type_node,
4776                                  arg5_plus_arg3,
4777                                  convert (TREE_TYPE (arg5_plus_arg3),
4778                                           TYPE_SIZE (arg4_type)))),
4779                       prep_arg4,
4780                       convert (arg4_type, integer_zero_node));
4781 #endif
4782         prep_arg4
4783           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4784                       arg4_tree,
4785                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4786                                 prep_arg4,
4787                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4788                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4789                                                     ffecom_1 (BIT_NOT_EXPR,
4790                                                               arg4_type,
4791                                                               convert
4792                                                               (arg4_type,
4793                                                         integer_zero_node)),
4794                                                     arg5_tree))));
4795         prep_arg1
4796           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4797                       prep_arg1,
4798                       prep_arg4);
4799 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4800         prep_arg1
4801           = ffecom_3 (COND_EXPR, arg4_type,
4802                       ffecom_truth_value
4803                       (ffecom_2 (NE_EXPR, integer_type_node,
4804                                  arg3_tree,
4805                                  convert (TREE_TYPE (arg3_tree),
4806                                           integer_zero_node))),
4807                       prep_arg1,
4808                       arg4_tree);
4809         prep_arg1
4810           = ffecom_3 (COND_EXPR, arg4_type,
4811                       ffecom_truth_value
4812                       (ffecom_2 (NE_EXPR, integer_type_node,
4813                                  arg3_tree,
4814                                  convert (TREE_TYPE (arg3_tree),
4815                                           TYPE_SIZE (arg4_type)))),
4816                       prep_arg1,
4817                       arg1_tree);
4818 #endif
4819         expr_tree
4820           = ffecom_2s (MODIFY_EXPR, void_type_node,
4821                        arg4_tree,
4822                        prep_arg1);
4823         /* Make sure SAVE_EXPRs get referenced early enough. */
4824         expr_tree
4825           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4826                       arg1_tree,
4827                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4828                                 arg3_tree,
4829                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4830                                           arg5_tree,
4831                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4832                                                     arg5_plus_arg3,
4833                                                     expr_tree))));
4834         expr_tree
4835           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4836                       arg4_tree,
4837                       expr_tree);
4838
4839       }
4840       return expr_tree;
4841
4842     case FFEINTRIN_impDERF:
4843     case FFEINTRIN_impERF:
4844     case FFEINTRIN_impDERFC:
4845     case FFEINTRIN_impERFC:
4846       break;
4847
4848     case FFEINTRIN_impIARGC:
4849       /* extern int xargc; i__1 = xargc - 1; */
4850       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4851                             ffecom_tree_xargc_,
4852                             convert (TREE_TYPE (ffecom_tree_xargc_),
4853                                      integer_one_node));
4854       return expr_tree;
4855
4856     case FFEINTRIN_impSIGNAL_func:
4857     case FFEINTRIN_impSIGNAL_subr:
4858       {
4859         tree arg1_tree;
4860         tree arg2_tree;
4861         tree arg3_tree;
4862
4863         arg1_tree = convert (ffecom_f2c_integer_type_node,
4864                              ffecom_expr (arg1));
4865         arg1_tree = ffecom_1 (ADDR_EXPR,
4866                               build_pointer_type (TREE_TYPE (arg1_tree)),
4867                               arg1_tree);
4868
4869         /* Pass procedure as a pointer to it, anything else by value.  */
4870         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4871           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4872         else
4873           arg2_tree = ffecom_ptr_to_expr (arg2);
4874         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4875                              arg2_tree);
4876
4877         if (arg3 != NULL)
4878           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4879         else
4880           arg3_tree = NULL_TREE;
4881
4882         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4883         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4884         TREE_CHAIN (arg1_tree) = arg2_tree;
4885
4886         expr_tree
4887           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4888                           ffecom_gfrt_kindtype (gfrt),
4889                           FALSE,
4890                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4891                            NULL_TREE :
4892                            tree_type),
4893                           arg1_tree,
4894                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4895                           ffebld_nonter_hook (expr));
4896
4897         if (arg3_tree != NULL_TREE)
4898           expr_tree
4899             = ffecom_modify (NULL_TREE, arg3_tree,
4900                              convert (TREE_TYPE (arg3_tree),
4901                                       expr_tree));
4902       }
4903       return expr_tree;
4904
4905     case FFEINTRIN_impALARM:
4906       {
4907         tree arg1_tree;
4908         tree arg2_tree;
4909         tree arg3_tree;
4910
4911         arg1_tree = convert (ffecom_f2c_integer_type_node,
4912                              ffecom_expr (arg1));
4913         arg1_tree = ffecom_1 (ADDR_EXPR,
4914                               build_pointer_type (TREE_TYPE (arg1_tree)),
4915                               arg1_tree);
4916
4917         /* Pass procedure as a pointer to it, anything else by value.  */
4918         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4919           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4920         else
4921           arg2_tree = ffecom_ptr_to_expr (arg2);
4922         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4923                              arg2_tree);
4924
4925         if (arg3 != NULL)
4926           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4927         else
4928           arg3_tree = NULL_TREE;
4929
4930         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4931         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4932         TREE_CHAIN (arg1_tree) = arg2_tree;
4933
4934         expr_tree
4935           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4936                           ffecom_gfrt_kindtype (gfrt),
4937                           FALSE,
4938                           NULL_TREE,
4939                           arg1_tree,
4940                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4941                           ffebld_nonter_hook (expr));
4942
4943         if (arg3_tree != NULL_TREE)
4944           expr_tree
4945             = ffecom_modify (NULL_TREE, arg3_tree,
4946                              convert (TREE_TYPE (arg3_tree),
4947                                       expr_tree));
4948       }
4949       return expr_tree;
4950
4951     case FFEINTRIN_impCHDIR_subr:
4952     case FFEINTRIN_impFDATE_subr:
4953     case FFEINTRIN_impFGET_subr:
4954     case FFEINTRIN_impFPUT_subr:
4955     case FFEINTRIN_impGETCWD_subr:
4956     case FFEINTRIN_impHOSTNM_subr:
4957     case FFEINTRIN_impSYSTEM_subr:
4958     case FFEINTRIN_impUNLINK_subr:
4959       {
4960         tree arg1_len = integer_zero_node;
4961         tree arg1_tree;
4962         tree arg2_tree;
4963
4964         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4965
4966         if (arg2 != NULL)
4967           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4968         else
4969           arg2_tree = NULL_TREE;
4970
4971         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4972         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4973         TREE_CHAIN (arg1_tree) = arg1_len;
4974
4975         expr_tree
4976           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4977                           ffecom_gfrt_kindtype (gfrt),
4978                           FALSE,
4979                           NULL_TREE,
4980                           arg1_tree,
4981                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4982                           ffebld_nonter_hook (expr));
4983
4984         if (arg2_tree != NULL_TREE)
4985           expr_tree
4986             = ffecom_modify (NULL_TREE, arg2_tree,
4987                              convert (TREE_TYPE (arg2_tree),
4988                                       expr_tree));
4989       }
4990       return expr_tree;
4991
4992     case FFEINTRIN_impEXIT:
4993       if (arg1 != NULL)
4994         break;
4995
4996       expr_tree = build_tree_list (NULL_TREE,
4997                                    ffecom_1 (ADDR_EXPR,
4998                                              build_pointer_type
4999                                              (ffecom_integer_type_node),
5000                                              integer_zero_node));
5001
5002       return
5003         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5004                       ffecom_gfrt_kindtype (gfrt),
5005                       FALSE,
5006                       void_type_node,
5007                       expr_tree,
5008                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5009                       ffebld_nonter_hook (expr));
5010
5011     case FFEINTRIN_impFLUSH:
5012       if (arg1 == NULL)
5013         gfrt = FFECOM_gfrtFLUSH;
5014       else
5015         gfrt = FFECOM_gfrtFLUSH1;
5016       break;
5017
5018     case FFEINTRIN_impCHMOD_subr:
5019     case FFEINTRIN_impLINK_subr:
5020     case FFEINTRIN_impRENAME_subr:
5021     case FFEINTRIN_impSYMLNK_subr:
5022       {
5023         tree arg1_len = integer_zero_node;
5024         tree arg1_tree;
5025         tree arg2_len = integer_zero_node;
5026         tree arg2_tree;
5027         tree arg3_tree;
5028
5029         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5030         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5031         if (arg3 != NULL)
5032           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5033         else
5034           arg3_tree = NULL_TREE;
5035
5036         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5037         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5038         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5039         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5040         TREE_CHAIN (arg1_tree) = arg2_tree;
5041         TREE_CHAIN (arg2_tree) = arg1_len;
5042         TREE_CHAIN (arg1_len) = arg2_len;
5043         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5044                                   ffecom_gfrt_kindtype (gfrt),
5045                                   FALSE,
5046                                   NULL_TREE,
5047                                   arg1_tree,
5048                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5049                                   ffebld_nonter_hook (expr));
5050         if (arg3_tree != NULL_TREE)
5051           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5052                                      convert (TREE_TYPE (arg3_tree),
5053                                               expr_tree));
5054       }
5055       return expr_tree;
5056
5057     case FFEINTRIN_impLSTAT_subr:
5058     case FFEINTRIN_impSTAT_subr:
5059       {
5060         tree arg1_len = integer_zero_node;
5061         tree arg1_tree;
5062         tree arg2_tree;
5063         tree arg3_tree;
5064
5065         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5066
5067         arg2_tree = ffecom_ptr_to_expr (arg2);
5068
5069         if (arg3 != NULL)
5070           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5071         else
5072           arg3_tree = NULL_TREE;
5073
5074         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5075         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5076         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5077         TREE_CHAIN (arg1_tree) = arg2_tree;
5078         TREE_CHAIN (arg2_tree) = arg1_len;
5079         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5080                                   ffecom_gfrt_kindtype (gfrt),
5081                                   FALSE,
5082                                   NULL_TREE,
5083                                   arg1_tree,
5084                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5085                                   ffebld_nonter_hook (expr));
5086         if (arg3_tree != NULL_TREE)
5087           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5088                                      convert (TREE_TYPE (arg3_tree),
5089                                               expr_tree));
5090       }
5091       return expr_tree;
5092
5093     case FFEINTRIN_impFGETC_subr:
5094     case FFEINTRIN_impFPUTC_subr:
5095       {
5096         tree arg1_tree;
5097         tree arg2_tree;
5098         tree arg2_len = integer_zero_node;
5099         tree arg3_tree;
5100
5101         arg1_tree = convert (ffecom_f2c_integer_type_node,
5102                              ffecom_expr (arg1));
5103         arg1_tree = ffecom_1 (ADDR_EXPR,
5104                               build_pointer_type (TREE_TYPE (arg1_tree)),
5105                               arg1_tree);
5106
5107         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5108         if (arg3 != NULL)
5109           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5110         else
5111           arg3_tree = NULL_TREE;
5112
5113         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5114         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5115         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5116         TREE_CHAIN (arg1_tree) = arg2_tree;
5117         TREE_CHAIN (arg2_tree) = arg2_len;
5118
5119         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5120                                   ffecom_gfrt_kindtype (gfrt),
5121                                   FALSE,
5122                                   NULL_TREE,
5123                                   arg1_tree,
5124                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5125                                   ffebld_nonter_hook (expr));
5126         if (arg3_tree != NULL_TREE)
5127           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5128                                      convert (TREE_TYPE (arg3_tree),
5129                                               expr_tree));
5130       }
5131       return expr_tree;
5132
5133     case FFEINTRIN_impFSTAT_subr:
5134       {
5135         tree arg1_tree;
5136         tree arg2_tree;
5137         tree arg3_tree;
5138
5139         arg1_tree = convert (ffecom_f2c_integer_type_node,
5140                              ffecom_expr (arg1));
5141         arg1_tree = ffecom_1 (ADDR_EXPR,
5142                               build_pointer_type (TREE_TYPE (arg1_tree)),
5143                               arg1_tree);
5144
5145         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5146                              ffecom_ptr_to_expr (arg2));
5147
5148         if (arg3 == NULL)
5149           arg3_tree = NULL_TREE;
5150         else
5151           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5152
5153         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5154         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5155         TREE_CHAIN (arg1_tree) = arg2_tree;
5156         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5157                                   ffecom_gfrt_kindtype (gfrt),
5158                                   FALSE,
5159                                   NULL_TREE,
5160                                   arg1_tree,
5161                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5162                                   ffebld_nonter_hook (expr));
5163         if (arg3_tree != NULL_TREE) {
5164           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5165                                      convert (TREE_TYPE (arg3_tree),
5166                                               expr_tree));
5167         }
5168       }
5169       return expr_tree;
5170
5171     case FFEINTRIN_impKILL_subr:
5172       {
5173         tree arg1_tree;
5174         tree arg2_tree;
5175         tree arg3_tree;
5176
5177         arg1_tree = convert (ffecom_f2c_integer_type_node,
5178                              ffecom_expr (arg1));
5179         arg1_tree = ffecom_1 (ADDR_EXPR,
5180                               build_pointer_type (TREE_TYPE (arg1_tree)),
5181                               arg1_tree);
5182
5183         arg2_tree = convert (ffecom_f2c_integer_type_node,
5184                              ffecom_expr (arg2));
5185         arg2_tree = ffecom_1 (ADDR_EXPR,
5186                               build_pointer_type (TREE_TYPE (arg2_tree)),
5187                               arg2_tree);
5188
5189         if (arg3 == NULL)
5190           arg3_tree = NULL_TREE;
5191         else
5192           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5193
5194         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5195         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5196         TREE_CHAIN (arg1_tree) = arg2_tree;
5197         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5198                                   ffecom_gfrt_kindtype (gfrt),
5199                                   FALSE,
5200                                   NULL_TREE,
5201                                   arg1_tree,
5202                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5203                                   ffebld_nonter_hook (expr));
5204         if (arg3_tree != NULL_TREE) {
5205           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5206                                      convert (TREE_TYPE (arg3_tree),
5207                                               expr_tree));
5208         }
5209       }
5210       return expr_tree;
5211
5212     case FFEINTRIN_impCTIME_subr:
5213     case FFEINTRIN_impTTYNAM_subr:
5214       {
5215         tree arg1_len = integer_zero_node;
5216         tree arg1_tree;
5217         tree arg2_tree;
5218
5219         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5220
5221         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5222                               ffecom_f2c_longint_type_node :
5223                               ffecom_f2c_integer_type_node),
5224                              ffecom_expr (arg1));
5225         arg2_tree = ffecom_1 (ADDR_EXPR,
5226                               build_pointer_type (TREE_TYPE (arg2_tree)),
5227                               arg2_tree);
5228
5229         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5230         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5231         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5232         TREE_CHAIN (arg1_len) = arg2_tree;
5233         TREE_CHAIN (arg1_tree) = arg1_len;
5234
5235         expr_tree
5236           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5237                           ffecom_gfrt_kindtype (gfrt),
5238                           FALSE,
5239                           NULL_TREE,
5240                           arg1_tree,
5241                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5242                           ffebld_nonter_hook (expr));
5243         TREE_SIDE_EFFECTS (expr_tree) = 1;
5244       }
5245       return expr_tree;
5246
5247     case FFEINTRIN_impIRAND:
5248     case FFEINTRIN_impRAND:
5249       /* Arg defaults to 0 (normal random case) */
5250       {
5251         tree arg1_tree;
5252
5253         if (arg1 == NULL)
5254           arg1_tree = ffecom_integer_zero_node;
5255         else
5256           arg1_tree = ffecom_expr (arg1);
5257         arg1_tree = convert (ffecom_f2c_integer_type_node,
5258                              arg1_tree);
5259         arg1_tree = ffecom_1 (ADDR_EXPR,
5260                               build_pointer_type (TREE_TYPE (arg1_tree)),
5261                               arg1_tree);
5262         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5263
5264         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5265                                   ffecom_gfrt_kindtype (gfrt),
5266                                   FALSE,
5267                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5268                                    ffecom_f2c_integer_type_node :
5269                                    ffecom_f2c_real_type_node),
5270                                   arg1_tree,
5271                                   dest_tree, dest, dest_used,
5272                                   NULL_TREE, TRUE,
5273                                   ffebld_nonter_hook (expr));
5274       }
5275       return expr_tree;
5276
5277     case FFEINTRIN_impFTELL_subr:
5278     case FFEINTRIN_impUMASK_subr:
5279       {
5280         tree arg1_tree;
5281         tree arg2_tree;
5282
5283         arg1_tree = convert (ffecom_f2c_integer_type_node,
5284                              ffecom_expr (arg1));
5285         arg1_tree = ffecom_1 (ADDR_EXPR,
5286                               build_pointer_type (TREE_TYPE (arg1_tree)),
5287                               arg1_tree);
5288
5289         if (arg2 == NULL)
5290           arg2_tree = NULL_TREE;
5291         else
5292           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5293
5294         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5295                                   ffecom_gfrt_kindtype (gfrt),
5296                                   FALSE,
5297                                   NULL_TREE,
5298                                   build_tree_list (NULL_TREE, arg1_tree),
5299                                   NULL_TREE, NULL, NULL, NULL_TREE,
5300                                   TRUE,
5301                                   ffebld_nonter_hook (expr));
5302         if (arg2_tree != NULL_TREE) {
5303           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5304                                      convert (TREE_TYPE (arg2_tree),
5305                                               expr_tree));
5306         }
5307       }
5308       return expr_tree;
5309
5310     case FFEINTRIN_impCPU_TIME:
5311     case FFEINTRIN_impSECOND_subr:
5312       {
5313         tree arg1_tree;
5314
5315         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5316
5317         expr_tree
5318           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5319                           ffecom_gfrt_kindtype (gfrt),
5320                           FALSE,
5321                           NULL_TREE,
5322                           NULL_TREE,
5323                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5324                           ffebld_nonter_hook (expr));
5325
5326         expr_tree
5327           = ffecom_modify (NULL_TREE, arg1_tree,
5328                            convert (TREE_TYPE (arg1_tree),
5329                                     expr_tree));
5330       }
5331       return expr_tree;
5332
5333     case FFEINTRIN_impDTIME_subr:
5334     case FFEINTRIN_impETIME_subr:
5335       {
5336         tree arg1_tree;
5337         tree result_tree;
5338
5339         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5340
5341         arg1_tree = ffecom_ptr_to_expr (arg1);
5342
5343         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5344                                   ffecom_gfrt_kindtype (gfrt),
5345                                   FALSE,
5346                                   NULL_TREE,
5347                                   build_tree_list (NULL_TREE, arg1_tree),
5348                                   NULL_TREE, NULL, NULL, NULL_TREE,
5349                                   TRUE,
5350                                   ffebld_nonter_hook (expr));
5351         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5352                                    convert (TREE_TYPE (result_tree),
5353                                             expr_tree));
5354       }
5355       return expr_tree;
5356
5357       /* Straightforward calls of libf2c routines: */
5358     case FFEINTRIN_impABORT:
5359     case FFEINTRIN_impACCESS:
5360     case FFEINTRIN_impBESJ0:
5361     case FFEINTRIN_impBESJ1:
5362     case FFEINTRIN_impBESJN:
5363     case FFEINTRIN_impBESY0:
5364     case FFEINTRIN_impBESY1:
5365     case FFEINTRIN_impBESYN:
5366     case FFEINTRIN_impCHDIR_func:
5367     case FFEINTRIN_impCHMOD_func:
5368     case FFEINTRIN_impDATE:
5369     case FFEINTRIN_impDATE_AND_TIME:
5370     case FFEINTRIN_impDBESJ0:
5371     case FFEINTRIN_impDBESJ1:
5372     case FFEINTRIN_impDBESJN:
5373     case FFEINTRIN_impDBESY0:
5374     case FFEINTRIN_impDBESY1:
5375     case FFEINTRIN_impDBESYN:
5376     case FFEINTRIN_impDTIME_func:
5377     case FFEINTRIN_impETIME_func:
5378     case FFEINTRIN_impFGETC_func:
5379     case FFEINTRIN_impFGET_func:
5380     case FFEINTRIN_impFNUM:
5381     case FFEINTRIN_impFPUTC_func:
5382     case FFEINTRIN_impFPUT_func:
5383     case FFEINTRIN_impFSEEK:
5384     case FFEINTRIN_impFSTAT_func:
5385     case FFEINTRIN_impFTELL_func:
5386     case FFEINTRIN_impGERROR:
5387     case FFEINTRIN_impGETARG:
5388     case FFEINTRIN_impGETCWD_func:
5389     case FFEINTRIN_impGETENV:
5390     case FFEINTRIN_impGETGID:
5391     case FFEINTRIN_impGETLOG:
5392     case FFEINTRIN_impGETPID:
5393     case FFEINTRIN_impGETUID:
5394     case FFEINTRIN_impGMTIME:
5395     case FFEINTRIN_impHOSTNM_func:
5396     case FFEINTRIN_impIDATE_unix:
5397     case FFEINTRIN_impIDATE_vxt:
5398     case FFEINTRIN_impIERRNO:
5399     case FFEINTRIN_impISATTY:
5400     case FFEINTRIN_impITIME:
5401     case FFEINTRIN_impKILL_func:
5402     case FFEINTRIN_impLINK_func:
5403     case FFEINTRIN_impLNBLNK:
5404     case FFEINTRIN_impLSTAT_func:
5405     case FFEINTRIN_impLTIME:
5406     case FFEINTRIN_impMCLOCK8:
5407     case FFEINTRIN_impMCLOCK:
5408     case FFEINTRIN_impPERROR:
5409     case FFEINTRIN_impRENAME_func:
5410     case FFEINTRIN_impSECNDS:
5411     case FFEINTRIN_impSECOND_func:
5412     case FFEINTRIN_impSLEEP:
5413     case FFEINTRIN_impSRAND:
5414     case FFEINTRIN_impSTAT_func:
5415     case FFEINTRIN_impSYMLNK_func:
5416     case FFEINTRIN_impSYSTEM_CLOCK:
5417     case FFEINTRIN_impSYSTEM_func:
5418     case FFEINTRIN_impTIME8:
5419     case FFEINTRIN_impTIME_unix:
5420     case FFEINTRIN_impTIME_vxt:
5421     case FFEINTRIN_impUMASK_func:
5422     case FFEINTRIN_impUNLINK_func:
5423       break;
5424
5425     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5426     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5427     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5428     case FFEINTRIN_impNONE:
5429     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5430       fprintf (stderr, "No %s implementation.\n",
5431                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5432       assert ("unimplemented intrinsic" == NULL);
5433       return error_mark_node;
5434     }
5435
5436   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5437
5438   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5439                                     ffebld_right (expr));
5440
5441   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5442                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5443                        tree_type,
5444                        expr_tree, dest_tree, dest, dest_used,
5445                        NULL_TREE, TRUE,
5446                        ffebld_nonter_hook (expr));
5447
5448   /* See bottom of this file for f2c transforms used to determine
5449      many of the above implementations.  The info seems to confuse
5450      Emacs's C mode indentation, which is why it's been moved to
5451      the bottom of this source file.  */
5452 }
5453
5454 #endif
5455 /* For power (exponentiation) where right-hand operand is type INTEGER,
5456    generate in-line code to do it the fast way (which, if the operand
5457    is a constant, might just mean a series of multiplies).  */
5458
5459 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5460 static tree
5461 ffecom_expr_power_integer_ (ffebld expr)
5462 {
5463   tree l = ffecom_expr (ffebld_left (expr));
5464   tree r = ffecom_expr (ffebld_right (expr));
5465   tree ltype = TREE_TYPE (l);
5466   tree rtype = TREE_TYPE (r);
5467   tree result = NULL_TREE;
5468
5469   if (l == error_mark_node
5470       || r == error_mark_node)
5471     return error_mark_node;
5472
5473   if (TREE_CODE (r) == INTEGER_CST)
5474     {
5475       int sgn = tree_int_cst_sgn (r);
5476
5477       if (sgn == 0)
5478         return convert (ltype, integer_one_node);
5479
5480       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5481           && (sgn < 0))
5482         {
5483           /* Reciprocal of integer is either 0, -1, or 1, so after
5484              calculating that (which we leave to the back end to do
5485              or not do optimally), don't bother with any multiplying.  */
5486
5487           result = ffecom_tree_divide_ (ltype,
5488                                         convert (ltype, integer_one_node),
5489                                         l,
5490                                         NULL_TREE, NULL, NULL, NULL_TREE);
5491           r = ffecom_1 (NEGATE_EXPR,
5492                         rtype,
5493                         r);
5494           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5495             result = ffecom_1 (ABS_EXPR, rtype,
5496                                result);
5497         }
5498
5499       /* Generate appropriate series of multiplies, preceded
5500          by divide if the exponent is negative.  */
5501
5502       l = save_expr (l);
5503
5504       if (sgn < 0)
5505         {
5506           l = ffecom_tree_divide_ (ltype,
5507                                    convert (ltype, integer_one_node),
5508                                    l,
5509                                    NULL_TREE, NULL, NULL,
5510                                    ffebld_nonter_hook (expr));
5511           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5512           assert (TREE_CODE (r) == INTEGER_CST);
5513
5514           if (tree_int_cst_sgn (r) < 0)
5515             {                   /* The "most negative" number.  */
5516               r = ffecom_1 (NEGATE_EXPR, rtype,
5517                             ffecom_2 (RSHIFT_EXPR, rtype,
5518                                       r,
5519                                       integer_one_node));
5520               l = save_expr (l);
5521               l = ffecom_2 (MULT_EXPR, ltype,
5522                             l,
5523                             l);
5524             }
5525         }
5526
5527       for (;;)
5528         {
5529           if (TREE_INT_CST_LOW (r) & 1)
5530             {
5531               if (result == NULL_TREE)
5532                 result = l;
5533               else
5534                 result = ffecom_2 (MULT_EXPR, ltype,
5535                                    result,
5536                                    l);
5537             }
5538
5539           r = ffecom_2 (RSHIFT_EXPR, rtype,
5540                         r,
5541                         integer_one_node);
5542           if (integer_zerop (r))
5543             break;
5544           assert (TREE_CODE (r) == INTEGER_CST);
5545
5546           l = save_expr (l);
5547           l = ffecom_2 (MULT_EXPR, ltype,
5548                         l,
5549                         l);
5550         }
5551       return result;
5552     }
5553
5554   /* Though rhs isn't a constant, in-line code cannot be expanded
5555      while transforming dummies
5556      because the back end cannot be easily convinced to generate
5557      stores (MODIFY_EXPR), handle temporaries, and so on before
5558      all the appropriate rtx's have been generated for things like
5559      dummy args referenced in rhs -- which doesn't happen until
5560      store_parm_decls() is called (expand_function_start, I believe,
5561      does the actual rtx-stuffing of PARM_DECLs).
5562
5563      So, in this case, let the caller generate the call to the
5564      run-time-library function to evaluate the power for us.  */
5565
5566   if (ffecom_transform_only_dummies_)
5567     return NULL_TREE;
5568
5569   /* Right-hand operand not a constant, expand in-line code to figure
5570      out how to do the multiplies, &c.
5571
5572      The returned expression is expressed this way in GNU C, where l and
5573      r are the "inputs":
5574
5575      ({ typeof (r) rtmp = r;
5576         typeof (l) ltmp = l;
5577         typeof (l) result;
5578
5579         if (rtmp == 0)
5580           result = 1;
5581         else
5582           {
5583             if ((basetypeof (l) == basetypeof (int))
5584                 && (rtmp < 0))
5585               {
5586                 result = ((typeof (l)) 1) / ltmp;
5587                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5588                   result = -result;
5589               }
5590             else
5591               {
5592                 result = 1;
5593                 if ((basetypeof (l) != basetypeof (int))
5594                     && (rtmp < 0))
5595                   {
5596                     ltmp = ((typeof (l)) 1) / ltmp;
5597                     rtmp = -rtmp;
5598                     if (rtmp < 0)
5599                       {
5600                         rtmp = -(rtmp >> 1);
5601                         ltmp *= ltmp;
5602                       }
5603                   }
5604                 for (;;)
5605                   {
5606                     if (rtmp & 1)
5607                       result *= ltmp;
5608                     if ((rtmp >>= 1) == 0)
5609                       break;
5610                     ltmp *= ltmp;
5611                   }
5612               }
5613           }
5614         result;
5615      })
5616
5617      Note that some of the above is compile-time collapsable, such as
5618      the first part of the if statements that checks the base type of
5619      l against int.  The if statements are phrased that way to suggest
5620      an easy way to generate the if/else constructs here, knowing that
5621      the back end should (and probably does) eliminate the resulting
5622      dead code (either the int case or the non-int case), something
5623      it couldn't do without the redundant phrasing, requiring explicit
5624      dead-code elimination here, which would be kind of difficult to
5625      read.  */
5626
5627   {
5628     tree rtmp;
5629     tree ltmp;
5630     tree divide;
5631     tree basetypeof_l_is_int;
5632     tree se;
5633     tree t;
5634
5635     basetypeof_l_is_int
5636       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5637
5638     se = expand_start_stmt_expr ();
5639
5640     ffecom_start_compstmt ();
5641
5642 #ifndef HAHA
5643     rtmp = ffecom_make_tempvar ("power_r", rtype,
5644                                 FFETARGET_charactersizeNONE, -1);
5645     ltmp = ffecom_make_tempvar ("power_l", ltype,
5646                                 FFETARGET_charactersizeNONE, -1);
5647     result = ffecom_make_tempvar ("power_res", ltype,
5648                                   FFETARGET_charactersizeNONE, -1);
5649     if (TREE_CODE (ltype) == COMPLEX_TYPE
5650         || TREE_CODE (ltype) == RECORD_TYPE)
5651       divide = ffecom_make_tempvar ("power_div", ltype,
5652                                     FFETARGET_charactersizeNONE, -1);
5653     else
5654       divide = NULL_TREE;
5655 #else  /* HAHA */
5656     {
5657       tree hook;
5658
5659       hook = ffebld_nonter_hook (expr);
5660       assert (hook);
5661       assert (TREE_CODE (hook) == TREE_VEC);
5662       assert (TREE_VEC_LENGTH (hook) == 4);
5663       rtmp = TREE_VEC_ELT (hook, 0);
5664       ltmp = TREE_VEC_ELT (hook, 1);
5665       result = TREE_VEC_ELT (hook, 2);
5666       divide = TREE_VEC_ELT (hook, 3);
5667       if (TREE_CODE (ltype) == COMPLEX_TYPE
5668           || TREE_CODE (ltype) == RECORD_TYPE)
5669         assert (divide);
5670       else
5671         assert (! divide);
5672     }
5673 #endif  /* HAHA */
5674
5675     expand_expr_stmt (ffecom_modify (void_type_node,
5676                                      rtmp,
5677                                      r));
5678     expand_expr_stmt (ffecom_modify (void_type_node,
5679                                      ltmp,
5680                                      l));
5681     expand_start_cond (ffecom_truth_value
5682                        (ffecom_2 (EQ_EXPR, integer_type_node,
5683                                   rtmp,
5684                                   convert (rtype, integer_zero_node))),
5685                        0);
5686     expand_expr_stmt (ffecom_modify (void_type_node,
5687                                      result,
5688                                      convert (ltype, integer_one_node)));
5689     expand_start_else ();
5690     if (! integer_zerop (basetypeof_l_is_int))
5691       {
5692         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5693                                      rtmp,
5694                                      convert (rtype,
5695                                               integer_zero_node)),
5696                            0);
5697         expand_expr_stmt (ffecom_modify (void_type_node,
5698                                          result,
5699                                          ffecom_tree_divide_
5700                                          (ltype,
5701                                           convert (ltype, integer_one_node),
5702                                           ltmp,
5703                                           NULL_TREE, NULL, NULL,
5704                                           divide)));
5705         expand_start_cond (ffecom_truth_value
5706                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5707                                       ffecom_2 (LT_EXPR, integer_type_node,
5708                                                 ltmp,
5709                                                 convert (ltype,
5710                                                          integer_zero_node)),
5711                                       ffecom_2 (EQ_EXPR, integer_type_node,
5712                                                 ffecom_2 (BIT_AND_EXPR,
5713                                                           rtype,
5714                                                           ffecom_1 (NEGATE_EXPR,
5715                                                                     rtype,
5716                                                                     rtmp),
5717                                                           convert (rtype,
5718                                                                    integer_one_node)),
5719                                                 convert (rtype,
5720                                                          integer_zero_node)))),
5721                            0);
5722         expand_expr_stmt (ffecom_modify (void_type_node,
5723                                          result,
5724                                          ffecom_1 (NEGATE_EXPR,
5725                                                    ltype,
5726                                                    result)));
5727         expand_end_cond ();
5728         expand_start_else ();
5729       }
5730     expand_expr_stmt (ffecom_modify (void_type_node,
5731                                      result,
5732                                      convert (ltype, integer_one_node)));
5733     expand_start_cond (ffecom_truth_value
5734                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5735                                   ffecom_truth_value_invert
5736                                   (basetypeof_l_is_int),
5737                                   ffecom_2 (LT_EXPR, integer_type_node,
5738                                             rtmp,
5739                                             convert (rtype,
5740                                                      integer_zero_node)))),
5741                        0);
5742     expand_expr_stmt (ffecom_modify (void_type_node,
5743                                      ltmp,
5744                                      ffecom_tree_divide_
5745                                      (ltype,
5746                                       convert (ltype, integer_one_node),
5747                                       ltmp,
5748                                       NULL_TREE, NULL, NULL,
5749                                       divide)));
5750     expand_expr_stmt (ffecom_modify (void_type_node,
5751                                      rtmp,
5752                                      ffecom_1 (NEGATE_EXPR, rtype,
5753                                                rtmp)));
5754     expand_start_cond (ffecom_truth_value
5755                        (ffecom_2 (LT_EXPR, integer_type_node,
5756                                   rtmp,
5757                                   convert (rtype, integer_zero_node))),
5758                        0);
5759     expand_expr_stmt (ffecom_modify (void_type_node,
5760                                      rtmp,
5761                                      ffecom_1 (NEGATE_EXPR, rtype,
5762                                                ffecom_2 (RSHIFT_EXPR,
5763                                                          rtype,
5764                                                          rtmp,
5765                                                          integer_one_node))));
5766     expand_expr_stmt (ffecom_modify (void_type_node,
5767                                      ltmp,
5768                                      ffecom_2 (MULT_EXPR, ltype,
5769                                                ltmp,
5770                                                ltmp)));
5771     expand_end_cond ();
5772     expand_end_cond ();
5773     expand_start_loop (1);
5774     expand_start_cond (ffecom_truth_value
5775                        (ffecom_2 (BIT_AND_EXPR, rtype,
5776                                   rtmp,
5777                                   convert (rtype, integer_one_node))),
5778                        0);
5779     expand_expr_stmt (ffecom_modify (void_type_node,
5780                                      result,
5781                                      ffecom_2 (MULT_EXPR, ltype,
5782                                                result,
5783                                                ltmp)));
5784     expand_end_cond ();
5785     expand_exit_loop_if_false (NULL,
5786                                ffecom_truth_value
5787                                (ffecom_modify (rtype,
5788                                                rtmp,
5789                                                ffecom_2 (RSHIFT_EXPR,
5790                                                          rtype,
5791                                                          rtmp,
5792                                                          integer_one_node))));
5793     expand_expr_stmt (ffecom_modify (void_type_node,
5794                                      ltmp,
5795                                      ffecom_2 (MULT_EXPR, ltype,
5796                                                ltmp,
5797                                                ltmp)));
5798     expand_end_loop ();
5799     expand_end_cond ();
5800     if (!integer_zerop (basetypeof_l_is_int))
5801       expand_end_cond ();
5802     expand_expr_stmt (result);
5803
5804     t = ffecom_end_compstmt ();
5805
5806     result = expand_end_stmt_expr (se);
5807
5808     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5809
5810     if (TREE_CODE (t) == BLOCK)
5811       {
5812         /* Make a BIND_EXPR for the BLOCK already made.  */
5813         result = build (BIND_EXPR, TREE_TYPE (result),
5814                         NULL_TREE, result, t);
5815         /* Remove the block from the tree at this point.
5816            It gets put back at the proper place
5817            when the BIND_EXPR is expanded.  */
5818         delete_block (t);
5819       }
5820     else
5821       result = t;
5822   }
5823
5824   return result;
5825 }
5826
5827 #endif
5828 /* ffecom_expr_transform_ -- Transform symbols in expr
5829
5830    ffebld expr;  // FFE expression.
5831    ffecom_expr_transform_ (expr);
5832
5833    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5834
5835 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5836 static void
5837 ffecom_expr_transform_ (ffebld expr)
5838 {
5839   tree t;
5840   ffesymbol s;
5841
5842 tail_recurse:                   /* :::::::::::::::::::: */
5843
5844   if (expr == NULL)
5845     return;
5846
5847   switch (ffebld_op (expr))
5848     {
5849     case FFEBLD_opSYMTER:
5850       s = ffebld_symter (expr);
5851       t = ffesymbol_hook (s).decl_tree;
5852       if ((t == NULL_TREE)
5853           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5854               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5855                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5856         {
5857           s = ffecom_sym_transform_ (s);
5858           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5859                                                    DIMENSION expr? */
5860         }
5861       break;                    /* Ok if (t == NULL) here. */
5862
5863     case FFEBLD_opITEM:
5864       ffecom_expr_transform_ (ffebld_head (expr));
5865       expr = ffebld_trail (expr);
5866       goto tail_recurse;        /* :::::::::::::::::::: */
5867
5868     default:
5869       break;
5870     }
5871
5872   switch (ffebld_arity (expr))
5873     {
5874     case 2:
5875       ffecom_expr_transform_ (ffebld_left (expr));
5876       expr = ffebld_right (expr);
5877       goto tail_recurse;        /* :::::::::::::::::::: */
5878
5879     case 1:
5880       expr = ffebld_left (expr);
5881       goto tail_recurse;        /* :::::::::::::::::::: */
5882
5883     default:
5884       break;
5885     }
5886
5887   return;
5888 }
5889
5890 #endif
5891 /* Make a type based on info in live f2c.h file.  */
5892
5893 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5894 static void
5895 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5896 {
5897   switch (tcode)
5898     {
5899     case FFECOM_f2ccodeCHAR:
5900       *type = make_signed_type (CHAR_TYPE_SIZE);
5901       break;
5902
5903     case FFECOM_f2ccodeSHORT:
5904       *type = make_signed_type (SHORT_TYPE_SIZE);
5905       break;
5906
5907     case FFECOM_f2ccodeINT:
5908       *type = make_signed_type (INT_TYPE_SIZE);
5909       break;
5910
5911     case FFECOM_f2ccodeLONG:
5912       *type = make_signed_type (LONG_TYPE_SIZE);
5913       break;
5914
5915     case FFECOM_f2ccodeLONGLONG:
5916       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5917       break;
5918
5919     case FFECOM_f2ccodeCHARPTR:
5920       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5921                                   ? signed_char_type_node
5922                                   : unsigned_char_type_node);
5923       break;
5924
5925     case FFECOM_f2ccodeFLOAT:
5926       *type = make_node (REAL_TYPE);
5927       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5928       layout_type (*type);
5929       break;
5930
5931     case FFECOM_f2ccodeDOUBLE:
5932       *type = make_node (REAL_TYPE);
5933       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5934       layout_type (*type);
5935       break;
5936
5937     case FFECOM_f2ccodeLONGDOUBLE:
5938       *type = make_node (REAL_TYPE);
5939       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5940       layout_type (*type);
5941       break;
5942
5943     case FFECOM_f2ccodeTWOREALS:
5944       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5945       break;
5946
5947     case FFECOM_f2ccodeTWODOUBLEREALS:
5948       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5949       break;
5950
5951     default:
5952       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5953       *type = error_mark_node;
5954       return;
5955     }
5956
5957   pushdecl (build_decl (TYPE_DECL,
5958                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5959                         *type));
5960 }
5961
5962 #endif
5963 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5964 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5965    given size.  */
5966
5967 static void
5968 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5969                           int code)
5970 {
5971   int j;
5972   tree t;
5973
5974   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5975     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5976         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5977       {
5978         assert (code != -1);
5979         ffecom_f2c_typecode_[bt][j] = code;
5980         code = -1;
5981       }
5982 }
5983
5984 #endif
5985 /* Finish up globals after doing all program units in file
5986
5987    Need to handle only uninitialized COMMON areas.  */
5988
5989 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5990 static ffeglobal
5991 ffecom_finish_global_ (ffeglobal global)
5992 {
5993   tree cbtype;
5994   tree cbt;
5995   tree size;
5996
5997   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5998       return global;
5999
6000   if (ffeglobal_common_init (global))
6001       return global;
6002
6003   cbt = ffeglobal_hook (global);
6004   if ((cbt == NULL_TREE)
6005       || !ffeglobal_common_have_size (global))
6006     return global;              /* No need to make common, never ref'd. */
6007
6008   DECL_EXTERNAL (cbt) = 0;
6009
6010   /* Give the array a size now.  */
6011
6012   size = build_int_2 ((ffeglobal_common_size (global)
6013                       + ffeglobal_common_pad (global)) - 1,
6014                       0);
6015
6016   cbtype = TREE_TYPE (cbt);
6017   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6018                                            integer_zero_node,
6019                                            size);
6020   if (!TREE_TYPE (size))
6021     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6022   layout_type (cbtype);
6023
6024   cbt = start_decl (cbt, FALSE);
6025   assert (cbt == ffeglobal_hook (global));
6026
6027   finish_decl (cbt, NULL_TREE, FALSE);
6028
6029   return global;
6030 }
6031
6032 #endif
6033 /* Finish up any untransformed symbols.  */
6034
6035 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6036 static ffesymbol
6037 ffecom_finish_symbol_transform_ (ffesymbol s)
6038 {
6039   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6040     return s;
6041
6042   /* It's easy to know to transform an untransformed symbol, to make sure
6043      we put out debugging info for it.  But COMMON variables, unlike
6044      EQUIVALENCE ones, aren't given declarations in addition to the
6045      tree expressions that specify offsets, because COMMON variables
6046      can be referenced in the outer scope where only dummy arguments
6047      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6048      VAR_DECLs for COMMON variables when we transform them for real
6049      use, and therefore we do all the VAR_DECL creating here.  */
6050
6051   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6052     {
6053       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6054           || (ffesymbol_where (s) != FFEINFO_whereNONE
6055               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6056               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6057         /* Not transformed, and not CHARACTER*(*), and not a dummy
6058            argument, which can happen only if the entry point names
6059            it "rides in on" are all invalidated for other reasons.  */
6060         s = ffecom_sym_transform_ (s);
6061     }
6062
6063   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6064       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6065     {
6066       /* This isn't working, at least for dbxout.  The .s file looks
6067          okay to me (burley), but in gdb 4.9 at least, the variables
6068          appear to reside somewhere outside of the common area, so
6069          it doesn't make sense to mislead anyone by generating the info
6070          on those variables until this is fixed.  NOTE: Same problem
6071          with EQUIVALENCE, sadly...see similar #if later.  */
6072       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6073                              ffesymbol_storage (s));
6074     }
6075
6076   return s;
6077 }
6078
6079 #endif
6080 /* Append underscore(s) to name before calling get_identifier.  "us"
6081    is nonzero if the name already contains an underscore and thus
6082    needs two underscores appended.  */
6083
6084 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6085 static tree
6086 ffecom_get_appended_identifier_ (char us, const char *name)
6087 {
6088   int i;
6089   char *newname;
6090   tree id;
6091
6092   newname = xmalloc ((i = strlen (name)) + 1
6093                      + ffe_is_underscoring ()
6094                      + us);
6095   memcpy (newname, name, i);
6096   newname[i] = '_';
6097   newname[i + us] = '_';
6098   newname[i + 1 + us] = '\0';
6099   id = get_identifier (newname);
6100
6101   free (newname);
6102
6103   return id;
6104 }
6105
6106 #endif
6107 /* Decide whether to append underscore to name before calling
6108    get_identifier.  */
6109
6110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6111 static tree
6112 ffecom_get_external_identifier_ (ffesymbol s)
6113 {
6114   char us;
6115   const char *name = ffesymbol_text (s);
6116
6117   /* If name is a built-in name, just return it as is.  */
6118
6119   if (!ffe_is_underscoring ()
6120       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6121 #if FFETARGET_isENFORCED_MAIN_NAME
6122       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6123 #else
6124       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6125 #endif
6126       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6127     return get_identifier (name);
6128
6129   us = ffe_is_second_underscore ()
6130     ? (strchr (name, '_') != NULL)
6131       : 0;
6132
6133   return ffecom_get_appended_identifier_ (us, name);
6134 }
6135
6136 #endif
6137 /* Decide whether to append underscore to internal name before calling
6138    get_identifier.
6139
6140    This is for non-external, top-function-context names only.  Transform
6141    identifier so it doesn't conflict with the transformed result
6142    of using a _different_ external name.  E.g. if "CALL FOO" is
6143    transformed into "FOO_();", then the variable in "FOO_ = 3"
6144    must be transformed into something that does not conflict, since
6145    these two things should be independent.
6146
6147    The transformation is as follows.  If the name does not contain
6148    an underscore, there is no possible conflict, so just return.
6149    If the name does contain an underscore, then transform it just
6150    like we transform an external identifier.  */
6151
6152 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6153 static tree
6154 ffecom_get_identifier_ (const char *name)
6155 {
6156   /* If name does not contain an underscore, just return it as is.  */
6157
6158   if (!ffe_is_underscoring ()
6159       || (strchr (name, '_') == NULL))
6160     return get_identifier (name);
6161
6162   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6163                                           name);
6164 }
6165
6166 #endif
6167 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6168
6169    tree t;
6170    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6171    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6172          ffesymbol_kindtype(s));
6173
6174    Call after setting up containing function and getting trees for all
6175    other symbols.  */
6176
6177 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6178 static tree
6179 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6180 {
6181   ffebld expr = ffesymbol_sfexpr (s);
6182   tree type;
6183   tree func;
6184   tree result;
6185   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6186   static bool recurse = FALSE;
6187   int old_lineno = lineno;
6188   const char *old_input_filename = input_filename;
6189
6190   ffecom_nested_entry_ = s;
6191
6192   /* For now, we don't have a handy pointer to where the sfunc is actually
6193      defined, though that should be easy to add to an ffesymbol. (The
6194      token/where info available might well point to the place where the type
6195      of the sfunc is declared, especially if that precedes the place where
6196      the sfunc itself is defined, which is typically the case.)  We should
6197      put out a null pointer rather than point somewhere wrong, but I want to
6198      see how it works at this point.  */
6199
6200   input_filename = ffesymbol_where_filename (s);
6201   lineno = ffesymbol_where_filelinenum (s);
6202
6203   /* Pretransform the expression so any newly discovered things belong to the
6204      outer program unit, not to the statement function. */
6205
6206   ffecom_expr_transform_ (expr);
6207
6208   /* Make sure no recursive invocation of this fn (a specific case of failing
6209      to pretransform an sfunc's expression, i.e. where its expression
6210      references another untransformed sfunc) happens. */
6211
6212   assert (!recurse);
6213   recurse = TRUE;
6214
6215   push_f_function_context ();
6216
6217   if (charfunc)
6218     type = void_type_node;
6219   else
6220     {
6221       type = ffecom_tree_type[bt][kt];
6222       if (type == NULL_TREE)
6223         type = integer_type_node;       /* _sym_exec_transition reports
6224                                            error. */
6225     }
6226
6227   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6228                   build_function_type (type, NULL_TREE),
6229                   1,            /* nested/inline */
6230                   0);           /* TREE_PUBLIC */
6231
6232   /* We don't worry about COMPLEX return values here, because this is
6233      entirely internal to our code, and gcc has the ability to return COMPLEX
6234      directly as a value.  */
6235
6236   if (charfunc)
6237     {                           /* Prepend arg for where result goes. */
6238       tree type;
6239
6240       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6241
6242       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6243
6244       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6245
6246       type = build_pointer_type (type);
6247       result = build_decl (PARM_DECL, result, type);
6248
6249       push_parm_decl (result);
6250     }
6251   else
6252     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6253
6254   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6255
6256   store_parm_decls (0);
6257
6258   ffecom_start_compstmt ();
6259
6260   if (expr != NULL)
6261     {
6262       if (charfunc)
6263         {
6264           ffetargetCharacterSize sz = ffesymbol_size (s);
6265           tree result_length;
6266
6267           result_length = build_int_2 (sz, 0);
6268           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6269
6270           ffecom_prepare_let_char_ (sz, expr);
6271
6272           ffecom_prepare_end ();
6273
6274           ffecom_let_char_ (result, result_length, sz, expr);
6275           expand_null_return ();
6276         }
6277       else
6278         {
6279           ffecom_prepare_expr (expr);
6280
6281           ffecom_prepare_end ();
6282
6283           expand_return (ffecom_modify (NULL_TREE,
6284                                         DECL_RESULT (current_function_decl),
6285                                         ffecom_expr (expr)));
6286         }
6287     }
6288
6289   ffecom_end_compstmt ();
6290
6291   func = current_function_decl;
6292   finish_function (1);
6293
6294   pop_f_function_context ();
6295
6296   recurse = FALSE;
6297
6298   lineno = old_lineno;
6299   input_filename = old_input_filename;
6300
6301   ffecom_nested_entry_ = NULL;
6302
6303   return func;
6304 }
6305
6306 #endif
6307
6308 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6309 static const char *
6310 ffecom_gfrt_args_ (ffecomGfrt ix)
6311 {
6312   return ffecom_gfrt_argstring_[ix];
6313 }
6314
6315 #endif
6316 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6317 static tree
6318 ffecom_gfrt_tree_ (ffecomGfrt ix)
6319 {
6320   if (ffecom_gfrt_[ix] == NULL_TREE)
6321     ffecom_make_gfrt_ (ix);
6322
6323   return ffecom_1 (ADDR_EXPR,
6324                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6325                    ffecom_gfrt_[ix]);
6326 }
6327
6328 #endif
6329 /* Return initialize-to-zero expression for this VAR_DECL.  */
6330
6331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6332 /* A somewhat evil way to prevent the garbage collector
6333    from collecting 'tree' structures.  */
6334 #define NUM_TRACKED_CHUNK 63
6335 static struct tree_ggc_tracker
6336 {
6337   struct tree_ggc_tracker *next;
6338   tree trees[NUM_TRACKED_CHUNK];
6339 } *tracker_head = NULL;
6340
6341 static void
6342 mark_tracker_head (void *arg)
6343 {
6344   struct tree_ggc_tracker *head;
6345   int i;
6346
6347   for (head = * (struct tree_ggc_tracker **) arg;
6348        head != NULL;
6349        head = head->next)
6350   {
6351     ggc_mark (head);
6352     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6353       ggc_mark_tree (head->trees[i]);
6354   }
6355 }
6356
6357 void
6358 ffecom_save_tree_forever (tree t)
6359 {
6360   int i;
6361   if (tracker_head != NULL)
6362     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6363       if (tracker_head->trees[i] == NULL)
6364         {
6365           tracker_head->trees[i] = t;
6366           return;
6367         }
6368
6369   {
6370     /* Need to allocate a new block.  */
6371     struct tree_ggc_tracker *old_head = tracker_head;
6372
6373     tracker_head = ggc_alloc (sizeof (*tracker_head));
6374     tracker_head->next = old_head;
6375     tracker_head->trees[0] = t;
6376     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6377       tracker_head->trees[i] = NULL;
6378   }
6379 }
6380
6381 static tree
6382 ffecom_init_zero_ (tree decl)
6383 {
6384   tree init;
6385   int incremental = TREE_STATIC (decl);
6386   tree type = TREE_TYPE (decl);
6387
6388   if (incremental)
6389     {
6390       make_decl_rtl (decl, NULL);
6391       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6392     }
6393
6394   if ((TREE_CODE (type) != ARRAY_TYPE)
6395       && (TREE_CODE (type) != RECORD_TYPE)
6396       && (TREE_CODE (type) != UNION_TYPE)
6397       && !incremental)
6398     init = convert (type, integer_zero_node);
6399   else if (!incremental)
6400     {
6401       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6402       TREE_CONSTANT (init) = 1;
6403       TREE_STATIC (init) = 1;
6404     }
6405   else
6406     {
6407       assemble_zeros (int_size_in_bytes (type));
6408       init = error_mark_node;
6409     }
6410
6411   return init;
6412 }
6413
6414 #endif
6415 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6416 static tree
6417 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6418                          tree *maybe_tree)
6419 {
6420   tree expr_tree;
6421   tree length_tree;
6422
6423   switch (ffebld_op (arg))
6424     {
6425     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6426       if (ffetarget_length_character1
6427           (ffebld_constant_character1
6428            (ffebld_conter (arg))) == 0)
6429         {
6430           *maybe_tree = integer_zero_node;
6431           return convert (tree_type, integer_zero_node);
6432         }
6433
6434       *maybe_tree = integer_one_node;
6435       expr_tree = build_int_2 (*ffetarget_text_character1
6436                                (ffebld_constant_character1
6437                                 (ffebld_conter (arg))),
6438                                0);
6439       TREE_TYPE (expr_tree) = tree_type;
6440       return expr_tree;
6441
6442     case FFEBLD_opSYMTER:
6443     case FFEBLD_opARRAYREF:
6444     case FFEBLD_opFUNCREF:
6445     case FFEBLD_opSUBSTR:
6446       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6447
6448       if ((expr_tree == error_mark_node)
6449           || (length_tree == error_mark_node))
6450         {
6451           *maybe_tree = error_mark_node;
6452           return error_mark_node;
6453         }
6454
6455       if (integer_zerop (length_tree))
6456         {
6457           *maybe_tree = integer_zero_node;
6458           return convert (tree_type, integer_zero_node);
6459         }
6460
6461       expr_tree
6462         = ffecom_1 (INDIRECT_REF,
6463                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6464                     expr_tree);
6465       expr_tree
6466         = ffecom_2 (ARRAY_REF,
6467                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6468                     expr_tree,
6469                     integer_one_node);
6470       expr_tree = convert (tree_type, expr_tree);
6471
6472       if (TREE_CODE (length_tree) == INTEGER_CST)
6473         *maybe_tree = integer_one_node;
6474       else                      /* Must check length at run time.  */
6475         *maybe_tree
6476           = ffecom_truth_value
6477             (ffecom_2 (GT_EXPR, integer_type_node,
6478                        length_tree,
6479                        ffecom_f2c_ftnlen_zero_node));
6480       return expr_tree;
6481
6482     case FFEBLD_opPAREN:
6483     case FFEBLD_opCONVERT:
6484       if (ffeinfo_size (ffebld_info (arg)) == 0)
6485         {
6486           *maybe_tree = integer_zero_node;
6487           return convert (tree_type, integer_zero_node);
6488         }
6489       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6490                                       maybe_tree);
6491
6492     case FFEBLD_opCONCATENATE:
6493       {
6494         tree maybe_left;
6495         tree maybe_right;
6496         tree expr_left;
6497         tree expr_right;
6498
6499         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6500                                              &maybe_left);
6501         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6502                                               &maybe_right);
6503         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6504                                 maybe_left,
6505                                 maybe_right);
6506         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6507                               maybe_left,
6508                               expr_left,
6509                               expr_right);
6510         return expr_tree;
6511       }
6512
6513     default:
6514       assert ("bad op in ICHAR" == NULL);
6515       return error_mark_node;
6516     }
6517 }
6518
6519 #endif
6520 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6521
6522    tree length_arg;
6523    ffebld expr;
6524    length_arg = ffecom_intrinsic_len_ (expr);
6525
6526    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6527    subexpressions by constructing the appropriate tree for the
6528    length-of-character-text argument in a calling sequence.  */
6529
6530 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6531 static tree
6532 ffecom_intrinsic_len_ (ffebld expr)
6533 {
6534   ffetargetCharacter1 val;
6535   tree length;
6536
6537   switch (ffebld_op (expr))
6538     {
6539     case FFEBLD_opCONTER:
6540       val = ffebld_constant_character1 (ffebld_conter (expr));
6541       length = build_int_2 (ffetarget_length_character1 (val), 0);
6542       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6543       break;
6544
6545     case FFEBLD_opSYMTER:
6546       {
6547         ffesymbol s = ffebld_symter (expr);
6548         tree item;
6549
6550         item = ffesymbol_hook (s).decl_tree;
6551         if (item == NULL_TREE)
6552           {
6553             s = ffecom_sym_transform_ (s);
6554             item = ffesymbol_hook (s).decl_tree;
6555           }
6556         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6557           {
6558             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6559               length = ffesymbol_hook (s).length_tree;
6560             else
6561               {
6562                 length = build_int_2 (ffesymbol_size (s), 0);
6563                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6564               }
6565           }
6566         else if (item == error_mark_node)
6567           length = error_mark_node;
6568         else                    /* FFEINFO_kindFUNCTION: */
6569           length = NULL_TREE;
6570       }
6571       break;
6572
6573     case FFEBLD_opARRAYREF:
6574       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6575       break;
6576
6577     case FFEBLD_opSUBSTR:
6578       {
6579         ffebld start;
6580         ffebld end;
6581         ffebld thing = ffebld_right (expr);
6582         tree start_tree;
6583         tree end_tree;
6584
6585         assert (ffebld_op (thing) == FFEBLD_opITEM);
6586         start = ffebld_head (thing);
6587         thing = ffebld_trail (thing);
6588         assert (ffebld_trail (thing) == NULL);
6589         end = ffebld_head (thing);
6590
6591         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6592
6593         if (length == error_mark_node)
6594           break;
6595
6596         if (start == NULL)
6597           {
6598             if (end == NULL)
6599               ;
6600             else
6601               {
6602                 length = convert (ffecom_f2c_ftnlen_type_node,
6603                                   ffecom_expr (end));
6604               }
6605           }
6606         else
6607           {
6608             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6609                                   ffecom_expr (start));
6610
6611             if (start_tree == error_mark_node)
6612               {
6613                 length = error_mark_node;
6614                 break;
6615               }
6616
6617             if (end == NULL)
6618               {
6619                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6620                                    ffecom_f2c_ftnlen_one_node,
6621                                    ffecom_2 (MINUS_EXPR,
6622                                              ffecom_f2c_ftnlen_type_node,
6623                                              length,
6624                                              start_tree));
6625               }
6626             else
6627               {
6628                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6629                                     ffecom_expr (end));
6630
6631                 if (end_tree == error_mark_node)
6632                   {
6633                     length = error_mark_node;
6634                     break;
6635                   }
6636
6637                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6638                                    ffecom_f2c_ftnlen_one_node,
6639                                    ffecom_2 (MINUS_EXPR,
6640                                              ffecom_f2c_ftnlen_type_node,
6641                                              end_tree, start_tree));
6642               }
6643           }
6644       }
6645       break;
6646
6647     case FFEBLD_opCONCATENATE:
6648       length
6649         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6650                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6651                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6652       break;
6653
6654     case FFEBLD_opFUNCREF:
6655     case FFEBLD_opCONVERT:
6656       length = build_int_2 (ffebld_size (expr), 0);
6657       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6658       break;
6659
6660     default:
6661       assert ("bad op for single char arg expr" == NULL);
6662       length = ffecom_f2c_ftnlen_zero_node;
6663       break;
6664     }
6665
6666   assert (length != NULL_TREE);
6667
6668   return length;
6669 }
6670
6671 #endif
6672 /* Handle CHARACTER assignments.
6673
6674    Generates code to do the assignment.  Used by ordinary assignment
6675    statement handler ffecom_let_stmt and by statement-function
6676    handler to generate code for a statement function.  */
6677
6678 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6679 static void
6680 ffecom_let_char_ (tree dest_tree, tree dest_length,
6681                   ffetargetCharacterSize dest_size, ffebld source)
6682 {
6683   ffecomConcatList_ catlist;
6684   tree source_length;
6685   tree source_tree;
6686   tree expr_tree;
6687
6688   if ((dest_tree == error_mark_node)
6689       || (dest_length == error_mark_node))
6690     return;
6691
6692   assert (dest_tree != NULL_TREE);
6693   assert (dest_length != NULL_TREE);
6694
6695   /* Source might be an opCONVERT, which just means it is a different size
6696      than the destination.  Since the underlying implementation here handles
6697      that (directly or via the s_copy or s_cat run-time-library functions),
6698      we don't need the "convenience" of an opCONVERT that tells us to
6699      truncate or blank-pad, particularly since the resulting implementation
6700      would probably be slower than otherwise. */
6701
6702   while (ffebld_op (source) == FFEBLD_opCONVERT)
6703     source = ffebld_left (source);
6704
6705   catlist = ffecom_concat_list_new_ (source, dest_size);
6706   switch (ffecom_concat_list_count_ (catlist))
6707     {
6708     case 0:                     /* Shouldn't happen, but in case it does... */
6709       ffecom_concat_list_kill_ (catlist);
6710       source_tree = null_pointer_node;
6711       source_length = ffecom_f2c_ftnlen_zero_node;
6712       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6713       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6714       TREE_CHAIN (TREE_CHAIN (expr_tree))
6715         = build_tree_list (NULL_TREE, dest_length);
6716       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6717         = build_tree_list (NULL_TREE, source_length);
6718
6719       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6720       TREE_SIDE_EFFECTS (expr_tree) = 1;
6721
6722       expand_expr_stmt (expr_tree);
6723
6724       return;
6725
6726     case 1:                     /* The (fairly) easy case. */
6727       ffecom_char_args_ (&source_tree, &source_length,
6728                          ffecom_concat_list_expr_ (catlist, 0));
6729       ffecom_concat_list_kill_ (catlist);
6730       assert (source_tree != NULL_TREE);
6731       assert (source_length != NULL_TREE);
6732
6733       if ((source_tree == error_mark_node)
6734           || (source_length == error_mark_node))
6735         return;
6736
6737       if (dest_size == 1)
6738         {
6739           dest_tree
6740             = ffecom_1 (INDIRECT_REF,
6741                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6742                                                       (dest_tree))),
6743                         dest_tree);
6744           dest_tree
6745             = ffecom_2 (ARRAY_REF,
6746                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6747                                                       (dest_tree))),
6748                         dest_tree,
6749                         integer_one_node);
6750           source_tree
6751             = ffecom_1 (INDIRECT_REF,
6752                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6753                                                       (source_tree))),
6754                         source_tree);
6755           source_tree
6756             = ffecom_2 (ARRAY_REF,
6757                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6758                                                       (source_tree))),
6759                         source_tree,
6760                         integer_one_node);
6761
6762           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6763
6764           expand_expr_stmt (expr_tree);
6765
6766           return;
6767         }
6768
6769       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6770       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6771       TREE_CHAIN (TREE_CHAIN (expr_tree))
6772         = build_tree_list (NULL_TREE, dest_length);
6773       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6774         = build_tree_list (NULL_TREE, source_length);
6775
6776       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6777       TREE_SIDE_EFFECTS (expr_tree) = 1;
6778
6779       expand_expr_stmt (expr_tree);
6780
6781       return;
6782
6783     default:                    /* Must actually concatenate things. */
6784       break;
6785     }
6786
6787   /* Heavy-duty concatenation. */
6788
6789   {
6790     int count = ffecom_concat_list_count_ (catlist);
6791     int i;
6792     tree lengths;
6793     tree items;
6794     tree length_array;
6795     tree item_array;
6796     tree citem;
6797     tree clength;
6798
6799 #ifdef HOHO
6800     length_array
6801       = lengths
6802       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6803                              FFETARGET_charactersizeNONE, count, TRUE);
6804     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6805                                               FFETARGET_charactersizeNONE,
6806                                               count, TRUE);
6807 #else
6808     {
6809       tree hook;
6810
6811       hook = ffebld_nonter_hook (source);
6812       assert (hook);
6813       assert (TREE_CODE (hook) == TREE_VEC);
6814       assert (TREE_VEC_LENGTH (hook) == 2);
6815       length_array = lengths = TREE_VEC_ELT (hook, 0);
6816       item_array = items = TREE_VEC_ELT (hook, 1);
6817     }
6818 #endif
6819
6820     for (i = 0; i < count; ++i)
6821       {
6822         ffecom_char_args_ (&citem, &clength,
6823                            ffecom_concat_list_expr_ (catlist, i));
6824         if ((citem == error_mark_node)
6825             || (clength == error_mark_node))
6826           {
6827             ffecom_concat_list_kill_ (catlist);
6828             return;
6829           }
6830
6831         items
6832           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6833                       ffecom_modify (void_type_node,
6834                                      ffecom_2 (ARRAY_REF,
6835                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6836                                                item_array,
6837                                                build_int_2 (i, 0)),
6838                                      citem),
6839                       items);
6840         lengths
6841           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6842                       ffecom_modify (void_type_node,
6843                                      ffecom_2 (ARRAY_REF,
6844                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6845                                                length_array,
6846                                                build_int_2 (i, 0)),
6847                                      clength),
6848                       lengths);
6849       }
6850
6851     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6852     TREE_CHAIN (expr_tree)
6853       = build_tree_list (NULL_TREE,
6854                          ffecom_1 (ADDR_EXPR,
6855                                    build_pointer_type (TREE_TYPE (items)),
6856                                    items));
6857     TREE_CHAIN (TREE_CHAIN (expr_tree))
6858       = build_tree_list (NULL_TREE,
6859                          ffecom_1 (ADDR_EXPR,
6860                                    build_pointer_type (TREE_TYPE (lengths)),
6861                                    lengths));
6862     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6863       = build_tree_list
6864         (NULL_TREE,
6865          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6866                    convert (ffecom_f2c_ftnlen_type_node,
6867                             build_int_2 (count, 0))));
6868     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6869       = build_tree_list (NULL_TREE, dest_length);
6870
6871     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6872     TREE_SIDE_EFFECTS (expr_tree) = 1;
6873
6874     expand_expr_stmt (expr_tree);
6875   }
6876
6877   ffecom_concat_list_kill_ (catlist);
6878 }
6879
6880 #endif
6881 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6882
6883    ffecomGfrt ix;
6884    ffecom_make_gfrt_(ix);
6885
6886    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6887    for the indicated run-time routine (ix).  */
6888
6889 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6890 static void
6891 ffecom_make_gfrt_ (ffecomGfrt ix)
6892 {
6893   tree t;
6894   tree ttype;
6895
6896   switch (ffecom_gfrt_type_[ix])
6897     {
6898     case FFECOM_rttypeVOID_:
6899       ttype = void_type_node;
6900       break;
6901
6902     case FFECOM_rttypeVOIDSTAR_:
6903       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6904       break;
6905
6906     case FFECOM_rttypeFTNINT_:
6907       ttype = ffecom_f2c_ftnint_type_node;
6908       break;
6909
6910     case FFECOM_rttypeINTEGER_:
6911       ttype = ffecom_f2c_integer_type_node;
6912       break;
6913
6914     case FFECOM_rttypeLONGINT_:
6915       ttype = ffecom_f2c_longint_type_node;
6916       break;
6917
6918     case FFECOM_rttypeLOGICAL_:
6919       ttype = ffecom_f2c_logical_type_node;
6920       break;
6921
6922     case FFECOM_rttypeREAL_F2C_:
6923       ttype = double_type_node;
6924       break;
6925
6926     case FFECOM_rttypeREAL_GNU_:
6927       ttype = float_type_node;
6928       break;
6929
6930     case FFECOM_rttypeCOMPLEX_F2C_:
6931       ttype = void_type_node;
6932       break;
6933
6934     case FFECOM_rttypeCOMPLEX_GNU_:
6935       ttype = ffecom_f2c_complex_type_node;
6936       break;
6937
6938     case FFECOM_rttypeDOUBLE_:
6939       ttype = double_type_node;
6940       break;
6941
6942     case FFECOM_rttypeDOUBLEREAL_:
6943       ttype = ffecom_f2c_doublereal_type_node;
6944       break;
6945
6946     case FFECOM_rttypeDBLCMPLX_F2C_:
6947       ttype = void_type_node;
6948       break;
6949
6950     case FFECOM_rttypeDBLCMPLX_GNU_:
6951       ttype = ffecom_f2c_doublecomplex_type_node;
6952       break;
6953
6954     case FFECOM_rttypeCHARACTER_:
6955       ttype = void_type_node;
6956       break;
6957
6958     default:
6959       ttype = NULL;
6960       assert ("bad rttype" == NULL);
6961       break;
6962     }
6963
6964   ttype = build_function_type (ttype, NULL_TREE);
6965   t = build_decl (FUNCTION_DECL,
6966                   get_identifier (ffecom_gfrt_name_[ix]),
6967                   ttype);
6968   DECL_EXTERNAL (t) = 1;
6969   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6970   TREE_PUBLIC (t) = 1;
6971   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6972
6973   /* Sanity check:  A function that's const cannot be volatile.  */
6974
6975   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6976
6977   /* Sanity check: A function that's const cannot return complex.  */
6978
6979   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6980
6981   t = start_decl (t, TRUE);
6982
6983   finish_decl (t, NULL_TREE, TRUE);
6984
6985   ffecom_gfrt_[ix] = t;
6986 }
6987
6988 #endif
6989 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6990
6991 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6992 static void
6993 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6994 {
6995   ffesymbol s = ffestorag_symbol (st);
6996
6997   if (ffesymbol_namelisted (s))
6998     ffecom_member_namelisted_ = TRUE;
6999 }
7000
7001 #endif
7002 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7003    the member so debugger will see it.  Otherwise nobody should be
7004    referencing the member.  */
7005
7006 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7007 static void
7008 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7009 {
7010   ffesymbol s;
7011   tree t;
7012   tree mt;
7013   tree type;
7014
7015   if ((mst == NULL)
7016       || ((mt = ffestorag_hook (mst)) == NULL)
7017       || (mt == error_mark_node))
7018     return;
7019
7020   if ((st == NULL)
7021       || ((s = ffestorag_symbol (st)) == NULL))
7022     return;
7023
7024   type = ffecom_type_localvar_ (s,
7025                                 ffesymbol_basictype (s),
7026                                 ffesymbol_kindtype (s));
7027   if (type == error_mark_node)
7028     return;
7029
7030   t = build_decl (VAR_DECL,
7031                   ffecom_get_identifier_ (ffesymbol_text (s)),
7032                   type);
7033
7034   TREE_STATIC (t) = TREE_STATIC (mt);
7035   DECL_INITIAL (t) = NULL_TREE;
7036   TREE_ASM_WRITTEN (t) = 1;
7037   TREE_USED (t) = 1;
7038
7039   SET_DECL_RTL (t,
7040                 gen_rtx (MEM, TYPE_MODE (type),
7041                          plus_constant (XEXP (DECL_RTL (mt), 0),
7042                                         ffestorag_modulo (mst)
7043                                         + ffestorag_offset (st)
7044                                         - ffestorag_offset (mst))));
7045
7046   t = start_decl (t, FALSE);
7047
7048   finish_decl (t, NULL_TREE, FALSE);
7049 }
7050
7051 #endif
7052 /* Prepare source expression for assignment into a destination perhaps known
7053    to be of a specific size.  */
7054
7055 static void
7056 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7057 {
7058   ffecomConcatList_ catlist;
7059   int count;
7060   int i;
7061   tree ltmp;
7062   tree itmp;
7063   tree tempvar = NULL_TREE;
7064
7065   while (ffebld_op (source) == FFEBLD_opCONVERT)
7066     source = ffebld_left (source);
7067
7068   catlist = ffecom_concat_list_new_ (source, dest_size);
7069   count = ffecom_concat_list_count_ (catlist);
7070
7071   if (count >= 2)
7072     {
7073       ltmp
7074         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7075                                FFETARGET_charactersizeNONE, count);
7076       itmp
7077         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7078                                FFETARGET_charactersizeNONE, count);
7079
7080       tempvar = make_tree_vec (2);
7081       TREE_VEC_ELT (tempvar, 0) = ltmp;
7082       TREE_VEC_ELT (tempvar, 1) = itmp;
7083     }
7084
7085   for (i = 0; i < count; ++i)
7086     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7087
7088   ffecom_concat_list_kill_ (catlist);
7089
7090   if (tempvar)
7091     {
7092       ffebld_nonter_set_hook (source, tempvar);
7093       current_binding_level->prep_state = 1;
7094     }
7095 }
7096
7097 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7098
7099    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7100    (which generates their trees) and then their trees get push_parm_decl'd.
7101
7102    The second arg is TRUE if the dummies are for a statement function, in
7103    which case lengths are not pushed for character arguments (since they are
7104    always known by both the caller and the callee, though the code allows
7105    for someday permitting CHAR*(*) stmtfunc dummies).  */
7106
7107 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7108 static void
7109 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7110 {
7111   ffebld dummy;
7112   ffebld dumlist;
7113   ffesymbol s;
7114   tree parm;
7115
7116   ffecom_transform_only_dummies_ = TRUE;
7117
7118   /* First push the parms corresponding to actual dummy "contents".  */
7119
7120   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7121     {
7122       dummy = ffebld_head (dumlist);
7123       switch (ffebld_op (dummy))
7124         {
7125         case FFEBLD_opSTAR:
7126         case FFEBLD_opANY:
7127           continue;             /* Forget alternate returns. */
7128
7129         default:
7130           break;
7131         }
7132       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7133       s = ffebld_symter (dummy);
7134       parm = ffesymbol_hook (s).decl_tree;
7135       if (parm == NULL_TREE)
7136         {
7137           s = ffecom_sym_transform_ (s);
7138           parm = ffesymbol_hook (s).decl_tree;
7139           assert (parm != NULL_TREE);
7140         }
7141       if (parm != error_mark_node)
7142         push_parm_decl (parm);
7143     }
7144
7145   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7146
7147   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7148     {
7149       dummy = ffebld_head (dumlist);
7150       switch (ffebld_op (dummy))
7151         {
7152         case FFEBLD_opSTAR:
7153         case FFEBLD_opANY:
7154           continue;             /* Forget alternate returns, they mean
7155                                    NOTHING! */
7156
7157         default:
7158           break;
7159         }
7160       s = ffebld_symter (dummy);
7161       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7162         continue;               /* Only looking for CHARACTER arguments. */
7163       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7164         continue;               /* Stmtfunc arg with known size needs no
7165                                    length param. */
7166       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7167         continue;               /* Only looking for variables and arrays. */
7168       parm = ffesymbol_hook (s).length_tree;
7169       assert (parm != NULL_TREE);
7170       if (parm != error_mark_node)
7171         push_parm_decl (parm);
7172     }
7173
7174   ffecom_transform_only_dummies_ = FALSE;
7175 }
7176
7177 #endif
7178 /* ffecom_start_progunit_ -- Beginning of program unit
7179
7180    Does GNU back end stuff necessary to teach it about the start of its
7181    equivalent of a Fortran program unit.  */
7182
7183 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7184 static void
7185 ffecom_start_progunit_ ()
7186 {
7187   ffesymbol fn = ffecom_primary_entry_;
7188   ffebld arglist;
7189   tree id;                      /* Identifier (name) of function. */
7190   tree type;                    /* Type of function. */
7191   tree result;                  /* Result of function. */
7192   ffeinfoBasictype bt;
7193   ffeinfoKindtype kt;
7194   ffeglobal g;
7195   ffeglobalType gt;
7196   ffeglobalType egt = FFEGLOBAL_type;
7197   bool charfunc;
7198   bool cmplxfunc;
7199   bool altentries = (ffecom_num_entrypoints_ != 0);
7200   bool multi
7201   = altentries
7202   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7203   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7204   bool main_program = FALSE;
7205   int old_lineno = lineno;
7206   const char *old_input_filename = input_filename;
7207
7208   assert (fn != NULL);
7209   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7210
7211   input_filename = ffesymbol_where_filename (fn);
7212   lineno = ffesymbol_where_filelinenum (fn);
7213
7214   switch (ffecom_primary_entry_kind_)
7215     {
7216     case FFEINFO_kindPROGRAM:
7217       main_program = TRUE;
7218       gt = FFEGLOBAL_typeMAIN;
7219       bt = FFEINFO_basictypeNONE;
7220       kt = FFEINFO_kindtypeNONE;
7221       type = ffecom_tree_fun_type_void;
7222       charfunc = FALSE;
7223       cmplxfunc = FALSE;
7224       break;
7225
7226     case FFEINFO_kindBLOCKDATA:
7227       gt = FFEGLOBAL_typeBDATA;
7228       bt = FFEINFO_basictypeNONE;
7229       kt = FFEINFO_kindtypeNONE;
7230       type = ffecom_tree_fun_type_void;
7231       charfunc = FALSE;
7232       cmplxfunc = FALSE;
7233       break;
7234
7235     case FFEINFO_kindFUNCTION:
7236       gt = FFEGLOBAL_typeFUNC;
7237       egt = FFEGLOBAL_typeEXT;
7238       bt = ffesymbol_basictype (fn);
7239       kt = ffesymbol_kindtype (fn);
7240       if (bt == FFEINFO_basictypeNONE)
7241         {
7242           ffeimplic_establish_symbol (fn);
7243           if (ffesymbol_funcresult (fn) != NULL)
7244             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7245           bt = ffesymbol_basictype (fn);
7246           kt = ffesymbol_kindtype (fn);
7247         }
7248
7249       if (multi)
7250         charfunc = cmplxfunc = FALSE;
7251       else if (bt == FFEINFO_basictypeCHARACTER)
7252         charfunc = TRUE, cmplxfunc = FALSE;
7253       else if ((bt == FFEINFO_basictypeCOMPLEX)
7254                && ffesymbol_is_f2c (fn)
7255                && !altentries)
7256         charfunc = FALSE, cmplxfunc = TRUE;
7257       else
7258         charfunc = cmplxfunc = FALSE;
7259
7260       if (multi || charfunc)
7261         type = ffecom_tree_fun_type_void;
7262       else if (ffesymbol_is_f2c (fn) && !altentries)
7263         type = ffecom_tree_fun_type[bt][kt];
7264       else
7265         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7266
7267       if ((type == NULL_TREE)
7268           || (TREE_TYPE (type) == NULL_TREE))
7269         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7270       break;
7271
7272     case FFEINFO_kindSUBROUTINE:
7273       gt = FFEGLOBAL_typeSUBR;
7274       egt = FFEGLOBAL_typeEXT;
7275       bt = FFEINFO_basictypeNONE;
7276       kt = FFEINFO_kindtypeNONE;
7277       if (ffecom_is_altreturning_)
7278         type = ffecom_tree_subr_type;
7279       else
7280         type = ffecom_tree_fun_type_void;
7281       charfunc = FALSE;
7282       cmplxfunc = FALSE;
7283       break;
7284
7285     default:
7286       assert ("say what??" == NULL);
7287       /* Fall through. */
7288     case FFEINFO_kindANY:
7289       gt = FFEGLOBAL_typeANY;
7290       bt = FFEINFO_basictypeNONE;
7291       kt = FFEINFO_kindtypeNONE;
7292       type = error_mark_node;
7293       charfunc = FALSE;
7294       cmplxfunc = FALSE;
7295       break;
7296     }
7297
7298   if (altentries)
7299     {
7300       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7301                                            ffesymbol_text (fn));
7302     }
7303 #if FFETARGET_isENFORCED_MAIN
7304   else if (main_program)
7305     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7306 #endif
7307   else
7308     id = ffecom_get_external_identifier_ (fn);
7309
7310   start_function (id,
7311                   type,
7312                   0,            /* nested/inline */
7313                   !altentries); /* TREE_PUBLIC */
7314
7315   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7316
7317   if (!altentries
7318       && ((g = ffesymbol_global (fn)) != NULL)
7319       && ((ffeglobal_type (g) == gt)
7320           || (ffeglobal_type (g) == egt)))
7321     {
7322       ffeglobal_set_hook (g, current_function_decl);
7323     }
7324
7325   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7326      exec-transitioning needs current_function_decl to be filled in.  So we
7327      do these things in two phases. */
7328
7329   if (altentries)
7330     {                           /* 1st arg identifies which entrypoint. */
7331       ffecom_which_entrypoint_decl_
7332         = build_decl (PARM_DECL,
7333                       ffecom_get_invented_identifier ("__g77_%s",
7334                                                       "which_entrypoint"),
7335                       integer_type_node);
7336       push_parm_decl (ffecom_which_entrypoint_decl_);
7337     }
7338
7339   if (charfunc
7340       || cmplxfunc
7341       || multi)
7342     {                           /* Arg for result (return value). */
7343       tree type;
7344       tree length;
7345
7346       if (charfunc)
7347         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7348       else if (cmplxfunc)
7349         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7350       else
7351         type = ffecom_multi_type_node_;
7352
7353       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7354
7355       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7356
7357       if (charfunc)
7358         length = ffecom_char_enhance_arg_ (&type, fn);
7359       else
7360         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7361
7362       type = build_pointer_type (type);
7363       result = build_decl (PARM_DECL, result, type);
7364
7365       push_parm_decl (result);
7366       if (multi)
7367         ffecom_multi_retval_ = result;
7368       else
7369         ffecom_func_result_ = result;
7370
7371       if (charfunc)
7372         {
7373           push_parm_decl (length);
7374           ffecom_func_length_ = length;
7375         }
7376     }
7377
7378   if (ffecom_primary_entry_is_proc_)
7379     {
7380       if (altentries)
7381         arglist = ffecom_master_arglist_;
7382       else
7383         arglist = ffesymbol_dummyargs (fn);
7384       ffecom_push_dummy_decls_ (arglist, FALSE);
7385     }
7386
7387   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7388     store_parm_decls (main_program ? 1 : 0);
7389
7390   ffecom_start_compstmt ();
7391   /* Disallow temp vars at this level.  */
7392   current_binding_level->prep_state = 2;
7393
7394   lineno = old_lineno;
7395   input_filename = old_input_filename;
7396
7397   /* This handles any symbols still untransformed, in case -g specified.
7398      This used to be done in ffecom_finish_progunit, but it turns out to
7399      be necessary to do it here so that statement functions are
7400      expanded before code.  But don't bother for BLOCK DATA.  */
7401
7402   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7403     ffesymbol_drive (ffecom_finish_symbol_transform_);
7404 }
7405
7406 #endif
7407 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7408
7409    ffesymbol s;
7410    ffecom_sym_transform_(s);
7411
7412    The ffesymbol_hook info for s is updated with appropriate backend info
7413    on the symbol.  */
7414
7415 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7416 static ffesymbol
7417 ffecom_sym_transform_ (ffesymbol s)
7418 {
7419   tree t;                       /* Transformed thingy. */
7420   tree tlen;                    /* Length if CHAR*(*). */
7421   bool addr;                    /* Is t the address of the thingy? */
7422   ffeinfoBasictype bt;
7423   ffeinfoKindtype kt;
7424   ffeglobal g;
7425   int old_lineno = lineno;
7426   const char *old_input_filename = input_filename;
7427
7428   /* Must ensure special ASSIGN variables are declared at top of outermost
7429      block, else they'll end up in the innermost block when their first
7430      ASSIGN is seen, which leaves them out of scope when they're the
7431      subject of a GOTO or I/O statement.
7432
7433      We make this variable even if -fugly-assign.  Just let it go unused,
7434      in case it turns out there are cases where we really want to use this
7435      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7436
7437   if (! ffecom_transform_only_dummies_
7438       && ffesymbol_assigned (s)
7439       && ! ffesymbol_hook (s).assign_tree)
7440     s = ffecom_sym_transform_assign_ (s);
7441
7442   if (ffesymbol_sfdummyparent (s) == NULL)
7443     {
7444       input_filename = ffesymbol_where_filename (s);
7445       lineno = ffesymbol_where_filelinenum (s);
7446     }
7447   else
7448     {
7449       ffesymbol sf = ffesymbol_sfdummyparent (s);
7450
7451       input_filename = ffesymbol_where_filename (sf);
7452       lineno = ffesymbol_where_filelinenum (sf);
7453     }
7454
7455   bt = ffeinfo_basictype (ffebld_info (s));
7456   kt = ffeinfo_kindtype (ffebld_info (s));
7457
7458   t = NULL_TREE;
7459   tlen = NULL_TREE;
7460   addr = FALSE;
7461
7462   switch (ffesymbol_kind (s))
7463     {
7464     case FFEINFO_kindNONE:
7465       switch (ffesymbol_where (s))
7466         {
7467         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7468           assert (ffecom_transform_only_dummies_);
7469
7470           /* Before 0.4, this could be ENTITY/DUMMY, but see
7471              ffestu_sym_end_transition -- no longer true (in particular, if
7472              it could be an ENTITY, it _will_ be made one, so that
7473              possibility won't come through here).  So we never make length
7474              arg for CHARACTER type.  */
7475
7476           t = build_decl (PARM_DECL,
7477                           ffecom_get_identifier_ (ffesymbol_text (s)),
7478                           ffecom_tree_ptr_to_subr_type);
7479 #if BUILT_FOR_270
7480           DECL_ARTIFICIAL (t) = 1;
7481 #endif
7482           addr = TRUE;
7483           break;
7484
7485         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7486           assert (!ffecom_transform_only_dummies_);
7487
7488           if (((g = ffesymbol_global (s)) != NULL)
7489               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7490                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7491                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7492               && (ffeglobal_hook (g) != NULL_TREE)
7493               && ffe_is_globals ())
7494             {
7495               t = ffeglobal_hook (g);
7496               break;
7497             }
7498
7499           t = build_decl (FUNCTION_DECL,
7500                           ffecom_get_external_identifier_ (s),
7501                           ffecom_tree_subr_type);       /* Assume subr. */
7502           DECL_EXTERNAL (t) = 1;
7503           TREE_PUBLIC (t) = 1;
7504
7505           t = start_decl (t, FALSE);
7506           finish_decl (t, NULL_TREE, FALSE);
7507
7508           if ((g != NULL)
7509               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7510                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7511                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7512             ffeglobal_set_hook (g, t);
7513
7514           ffecom_save_tree_forever (t);
7515
7516           break;
7517
7518         default:
7519           assert ("NONE where unexpected" == NULL);
7520           /* Fall through. */
7521         case FFEINFO_whereANY:
7522           break;
7523         }
7524       break;
7525
7526     case FFEINFO_kindENTITY:
7527       switch (ffeinfo_where (ffesymbol_info (s)))
7528         {
7529
7530         case FFEINFO_whereCONSTANT:
7531           /* ~~Debugging info needed? */
7532           assert (!ffecom_transform_only_dummies_);
7533           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7534           break;
7535
7536         case FFEINFO_whereLOCAL:
7537           assert (!ffecom_transform_only_dummies_);
7538
7539           {
7540             ffestorag st = ffesymbol_storage (s);
7541             tree type;
7542
7543             if ((st != NULL)
7544                 && (ffestorag_size (st) == 0))
7545               {
7546                 t = error_mark_node;
7547                 break;
7548               }
7549
7550             type = ffecom_type_localvar_ (s, bt, kt);
7551
7552             if (type == error_mark_node)
7553               {
7554                 t = error_mark_node;
7555                 break;
7556               }
7557
7558             if ((st != NULL)
7559                 && (ffestorag_parent (st) != NULL))
7560               {                 /* Child of EQUIVALENCE parent. */
7561                 ffestorag est;
7562                 tree et;
7563                 ffetargetOffset offset;
7564
7565                 est = ffestorag_parent (st);
7566                 ffecom_transform_equiv_ (est);
7567
7568                 et = ffestorag_hook (est);
7569                 assert (et != NULL_TREE);
7570
7571                 if (! TREE_STATIC (et))
7572                   put_var_into_stack (et);
7573
7574                 offset = ffestorag_modulo (est)
7575                   + ffestorag_offset (ffesymbol_storage (s))
7576                   - ffestorag_offset (est);
7577
7578                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7579
7580                 /* (t_type *) (((char *) &et) + offset) */
7581
7582                 t = convert (string_type_node,  /* (char *) */
7583                              ffecom_1 (ADDR_EXPR,
7584                                        build_pointer_type (TREE_TYPE (et)),
7585                                        et));
7586                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7587                               t,
7588                               build_int_2 (offset, 0));
7589                 t = convert (build_pointer_type (type),
7590                              t);
7591                 TREE_CONSTANT (t) = staticp (et);
7592
7593                 addr = TRUE;
7594               }
7595             else
7596               {
7597                 tree initexpr;
7598                 bool init = ffesymbol_is_init (s);
7599
7600                 t = build_decl (VAR_DECL,
7601                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7602                                 type);
7603
7604                 if (init
7605                     || ffesymbol_namelisted (s)
7606 #ifdef FFECOM_sizeMAXSTACKITEM
7607                     || ((st != NULL)
7608                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7609 #endif
7610                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7611                         && (ffecom_primary_entry_kind_
7612                             != FFEINFO_kindBLOCKDATA)
7613                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7614                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7615                 else
7616                   TREE_STATIC (t) = 0;  /* No need to make static. */
7617
7618                 if (init || ffe_is_init_local_zero ())
7619                   DECL_INITIAL (t) = error_mark_node;
7620
7621                 /* Keep -Wunused from complaining about var if it
7622                    is used as sfunc arg or DATA implied-DO.  */
7623                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7624                   DECL_IN_SYSTEM_HEADER (t) = 1;
7625
7626                 t = start_decl (t, FALSE);
7627
7628                 if (init)
7629                   {
7630                     if (ffesymbol_init (s) != NULL)
7631                       initexpr = ffecom_expr (ffesymbol_init (s));
7632                     else
7633                       initexpr = ffecom_init_zero_ (t);
7634                   }
7635                 else if (ffe_is_init_local_zero ())
7636                   initexpr = ffecom_init_zero_ (t);
7637                 else
7638                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7639
7640                 finish_decl (t, initexpr, FALSE);
7641
7642                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7643                   {
7644                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7645                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7646                                                    ffestorag_size (st)));
7647                   }
7648               }
7649           }
7650           break;
7651
7652         case FFEINFO_whereRESULT:
7653           assert (!ffecom_transform_only_dummies_);
7654
7655           if (bt == FFEINFO_basictypeCHARACTER)
7656             {                   /* Result is already in list of dummies, use
7657                                    it (& length). */
7658               t = ffecom_func_result_;
7659               tlen = ffecom_func_length_;
7660               addr = TRUE;
7661               break;
7662             }
7663           if ((ffecom_num_entrypoints_ == 0)
7664               && (bt == FFEINFO_basictypeCOMPLEX)
7665               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7666             {                   /* Result is already in list of dummies, use
7667                                    it. */
7668               t = ffecom_func_result_;
7669               addr = TRUE;
7670               break;
7671             }
7672           if (ffecom_func_result_ != NULL_TREE)
7673             {
7674               t = ffecom_func_result_;
7675               break;
7676             }
7677           if ((ffecom_num_entrypoints_ != 0)
7678               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7679             {
7680               assert (ffecom_multi_retval_ != NULL_TREE);
7681               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7682                             ffecom_multi_retval_);
7683               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7684                             t, ffecom_multi_fields_[bt][kt]);
7685
7686               break;
7687             }
7688
7689           t = build_decl (VAR_DECL,
7690                           ffecom_get_identifier_ (ffesymbol_text (s)),
7691                           ffecom_tree_type[bt][kt]);
7692           TREE_STATIC (t) = 0;  /* Put result on stack. */
7693           t = start_decl (t, FALSE);
7694           finish_decl (t, NULL_TREE, FALSE);
7695
7696           ffecom_func_result_ = t;
7697
7698           break;
7699
7700         case FFEINFO_whereDUMMY:
7701           {
7702             tree type;
7703             ffebld dl;
7704             ffebld dim;
7705             tree low;
7706             tree high;
7707             tree old_sizes;
7708             bool adjustable = FALSE;    /* Conditionally adjustable? */
7709
7710             type = ffecom_tree_type[bt][kt];
7711             if (ffesymbol_sfdummyparent (s) != NULL)
7712               {
7713                 if (current_function_decl == ffecom_outer_function_decl_)
7714                   {                     /* Exec transition before sfunc
7715                                            context; get it later. */
7716                     break;
7717                   }
7718                 t = ffecom_get_identifier_ (ffesymbol_text
7719                                             (ffesymbol_sfdummyparent (s)));
7720               }
7721             else
7722               t = ffecom_get_identifier_ (ffesymbol_text (s));
7723
7724             assert (ffecom_transform_only_dummies_);
7725
7726             old_sizes = get_pending_sizes ();
7727             put_pending_sizes (old_sizes);
7728
7729             if (bt == FFEINFO_basictypeCHARACTER)
7730               tlen = ffecom_char_enhance_arg_ (&type, s);
7731             type = ffecom_check_size_overflow_ (s, type, TRUE);
7732
7733             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7734               {
7735                 if (type == error_mark_node)
7736                   break;
7737
7738                 dim = ffebld_head (dl);
7739                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7740                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7741                   low = ffecom_integer_one_node;
7742                 else
7743                   low = ffecom_expr (ffebld_left (dim));
7744                 assert (ffebld_right (dim) != NULL);
7745                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7746                     || ffecom_doing_entry_)
7747                   {
7748                     /* Used to just do high=low.  But for ffecom_tree_
7749                        canonize_ref_, it probably is important to correctly
7750                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7751                        C(2)=CFUNC(C), overlap can happen, while it can't
7752                        for, say, C(1)=CFUNC(C(2)).  */
7753                     /* Even more recently used to set to INT_MAX, but that
7754                        broke when some overflow checking went into the back
7755                        end.  Now we just leave the upper bound unspecified.  */
7756                     high = NULL;
7757                   }
7758                 else
7759                   high = ffecom_expr (ffebld_right (dim));
7760
7761                 /* Determine whether array is conditionally adjustable,
7762                    to decide whether back-end magic is needed.
7763
7764                    Normally the front end uses the back-end function
7765                    variable_size to wrap SAVE_EXPR's around expressions
7766                    affecting the size/shape of an array so that the
7767                    size/shape info doesn't change during execution
7768                    of the compiled code even though variables and
7769                    functions referenced in those expressions might.
7770
7771                    variable_size also makes sure those saved expressions
7772                    get evaluated immediately upon entry to the
7773                    compiled procedure -- the front end normally doesn't
7774                    have to worry about that.
7775
7776                    However, there is a problem with this that affects
7777                    g77's implementation of entry points, and that is
7778                    that it is _not_ true that each invocation of the
7779                    compiled procedure is permitted to evaluate
7780                    array size/shape info -- because it is possible
7781                    that, for some invocations, that info is invalid (in
7782                    which case it is "promised" -- i.e. a violation of
7783                    the Fortran standard -- that the compiled code
7784                    won't reference the array or its size/shape
7785                    during that particular invocation).
7786
7787                    To phrase this in C terms, consider this gcc function:
7788
7789                      void foo (int *n, float (*a)[*n])
7790                      {
7791                        // a is "pointer to array ...", fyi.
7792                      }
7793
7794                    Suppose that, for some invocations, it is permitted
7795                    for a caller of foo to do this:
7796
7797                        foo (NULL, NULL);
7798
7799                    Now the _written_ code for foo can take such a call
7800                    into account by either testing explicitly for whether
7801                    (a == NULL) || (n == NULL) -- presumably it is
7802                    not permitted to reference *a in various fashions
7803                    if (n == NULL) I suppose -- or it can avoid it by
7804                    looking at other info (other arguments, static/global
7805                    data, etc.).
7806
7807                    However, this won't work in gcc 2.5.8 because it'll
7808                    automatically emit the code to save the "*n"
7809                    expression, which'll yield a NULL dereference for
7810                    the "foo (NULL, NULL)" call, something the code
7811                    for foo cannot prevent.
7812
7813                    g77 definitely needs to avoid executing such
7814                    code anytime the pointer to the adjustable array
7815                    is NULL, because even if its bounds expressions
7816                    don't have any references to possible "absent"
7817                    variables like "*n" -- say all variable references
7818                    are to COMMON variables, i.e. global (though in C,
7819                    local static could actually make sense) -- the
7820                    expressions could yield other run-time problems
7821                    for allowably "dead" values in those variables.
7822
7823                    For example, let's consider a more complicated
7824                    version of foo:
7825
7826                      extern int i;
7827                      extern int j;
7828
7829                      void foo (float (*a)[i/j])
7830                      {
7831                        ...
7832                      }
7833
7834                    The above is (essentially) quite valid for Fortran
7835                    but, again, for a call like "foo (NULL);", it is
7836                    permitted for i and j to be undefined when the
7837                    call is made.  If j happened to be zero, for
7838                    example, emitting the code to evaluate "i/j"
7839                    could result in a run-time error.
7840
7841                    Offhand, though I don't have my F77 or F90
7842                    standards handy, it might even be valid for a
7843                    bounds expression to contain a function reference,
7844                    in which case I doubt it is permitted for an
7845                    implementation to invoke that function in the
7846                    Fortran case involved here (invocation of an
7847                    alternate ENTRY point that doesn't have the adjustable
7848                    array as one of its arguments).
7849
7850                    So, the code that the compiler would normally emit
7851                    to preevaluate the size/shape info for an
7852                    adjustable array _must not_ be executed at run time
7853                    in certain cases.  Specifically, for Fortran,
7854                    the case is when the pointer to the adjustable
7855                    array == NULL.  (For gnu-ish C, it might be nice
7856                    for the source code itself to specify an expression
7857                    that, if TRUE, inhibits execution of the code.  Or
7858                    reverse the sense for elegance.)
7859
7860                    (Note that g77 could use a different test than NULL,
7861                    actually, since it happens to always pass an
7862                    integer to the called function that specifies which
7863                    entry point is being invoked.  Hmm, this might
7864                    solve the next problem.)
7865
7866                    One way a user could, I suppose, write "foo" so
7867                    it works is to insert COND_EXPR's for the
7868                    size/shape info so the dangerous stuff isn't
7869                    actually done, as in:
7870
7871                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7872                      {
7873                        ...
7874                      }
7875
7876                    The next problem is that the front end needs to
7877                    be able to tell the back end about the array's
7878                    decl _before_ it tells it about the conditional
7879                    expression to inhibit evaluation of size/shape info,
7880                    as shown above.
7881
7882                    To solve this, the front end needs to be able
7883                    to give the back end the expression to inhibit
7884                    generation of the preevaluation code _after_
7885                    it makes the decl for the adjustable array.
7886
7887                    Until then, the above example using the COND_EXPR
7888                    doesn't pass muster with gcc because the "(a == NULL)"
7889                    part has a reference to "a", which is still
7890                    undefined at that point.
7891
7892                    g77 will therefore use a different mechanism in the
7893                    meantime.  */
7894
7895                 if (!adjustable
7896                     && ((TREE_CODE (low) != INTEGER_CST)
7897                         || (high && TREE_CODE (high) != INTEGER_CST)))
7898                   adjustable = TRUE;
7899
7900 #if 0                           /* Old approach -- see below. */
7901                 if (TREE_CODE (low) != INTEGER_CST)
7902                   low = ffecom_3 (COND_EXPR, integer_type_node,
7903                                   ffecom_adjarray_passed_ (s),
7904                                   low,
7905                                   ffecom_integer_zero_node);
7906
7907                 if (high && TREE_CODE (high) != INTEGER_CST)
7908                   high = ffecom_3 (COND_EXPR, integer_type_node,
7909                                    ffecom_adjarray_passed_ (s),
7910                                    high,
7911                                    ffecom_integer_zero_node);
7912 #endif
7913
7914                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7915                    probably.  Fixes 950302-1.f.  */
7916
7917                 if (TREE_CODE (low) != INTEGER_CST)
7918                   low = variable_size (low);
7919
7920                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7921                    does this, which is why dumb0.c would work.  */
7922
7923                 if (high && TREE_CODE (high) != INTEGER_CST)
7924                   high = variable_size (high);
7925
7926                 type
7927                   = build_array_type
7928                     (type,
7929                      build_range_type (ffecom_integer_type_node,
7930                                        low, high));
7931                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7932               }
7933
7934             if (type == error_mark_node)
7935               {
7936                 t = error_mark_node;
7937                 break;
7938               }
7939
7940             if ((ffesymbol_sfdummyparent (s) == NULL)
7941                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7942               {
7943                 type = build_pointer_type (type);
7944                 addr = TRUE;
7945               }
7946
7947             t = build_decl (PARM_DECL, t, type);
7948 #if BUILT_FOR_270
7949             DECL_ARTIFICIAL (t) = 1;
7950 #endif
7951
7952             /* If this arg is present in every entry point's list of
7953                dummy args, then we're done.  */
7954
7955             if (ffesymbol_numentries (s)
7956                 == (ffecom_num_entrypoints_ + 1))
7957               break;
7958
7959 #if 1
7960
7961             /* If variable_size in stor-layout has been called during
7962                the above, then get_pending_sizes should have the
7963                yet-to-be-evaluated saved expressions pending.
7964                Make the whole lot of them get emitted, conditionally
7965                on whether the array decl ("t" above) is not NULL.  */
7966
7967             {
7968               tree sizes = get_pending_sizes ();
7969               tree tem;
7970
7971               for (tem = sizes;
7972                    tem != old_sizes;
7973                    tem = TREE_CHAIN (tem))
7974                 {
7975                   tree temv = TREE_VALUE (tem);
7976
7977                   if (sizes == tem)
7978                     sizes = temv;
7979                   else
7980                     sizes
7981                       = ffecom_2 (COMPOUND_EXPR,
7982                                   TREE_TYPE (sizes),
7983                                   temv,
7984                                   sizes);
7985                 }
7986
7987               if (sizes != tem)
7988                 {
7989                   sizes
7990                     = ffecom_3 (COND_EXPR,
7991                                 TREE_TYPE (sizes),
7992                                 ffecom_2 (NE_EXPR,
7993                                           integer_type_node,
7994                                           t,
7995                                           null_pointer_node),
7996                                 sizes,
7997                                 convert (TREE_TYPE (sizes),
7998                                          integer_zero_node));
7999                   sizes = ffecom_save_tree (sizes);
8000
8001                   sizes
8002                     = tree_cons (NULL_TREE, sizes, tem);
8003                 }
8004
8005               if (sizes)
8006                 put_pending_sizes (sizes);
8007             }
8008
8009 #else
8010 #if 0
8011             if (adjustable
8012                 && (ffesymbol_numentries (s)
8013                     != ffecom_num_entrypoints_ + 1))
8014               DECL_SOMETHING (t)
8015                 = ffecom_2 (NE_EXPR, integer_type_node,
8016                             t,
8017                             null_pointer_node);
8018 #else
8019 #if 0
8020             if (adjustable
8021                 && (ffesymbol_numentries (s)
8022                     != ffecom_num_entrypoints_ + 1))
8023               {
8024                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8025                 ffebad_here (0, ffesymbol_where_line (s),
8026                              ffesymbol_where_column (s));
8027                 ffebad_string (ffesymbol_text (s));
8028                 ffebad_finish ();
8029               }
8030 #endif
8031 #endif
8032 #endif
8033           }
8034           break;
8035
8036         case FFEINFO_whereCOMMON:
8037           {
8038             ffesymbol cs;
8039             ffeglobal cg;
8040             tree ct;
8041             ffestorag st = ffesymbol_storage (s);
8042             tree type;
8043
8044             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8045             if (st != NULL)     /* Else not laid out. */
8046               {
8047                 ffecom_transform_common_ (cs);
8048                 st = ffesymbol_storage (s);
8049               }
8050
8051             type = ffecom_type_localvar_ (s, bt, kt);
8052
8053             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8054             if ((cg == NULL)
8055                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8056               ct = NULL_TREE;
8057             else
8058               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8059
8060             if ((ct == NULL_TREE)
8061                 || (st == NULL)
8062                 || (type == error_mark_node))
8063               t = error_mark_node;
8064             else
8065               {
8066                 ffetargetOffset offset;
8067                 ffestorag cst;
8068
8069                 cst = ffestorag_parent (st);
8070                 assert (cst == ffesymbol_storage (cs));
8071
8072                 offset = ffestorag_modulo (cst)
8073                   + ffestorag_offset (st)
8074                   - ffestorag_offset (cst);
8075
8076                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8077
8078                 /* (t_type *) (((char *) &ct) + offset) */
8079
8080                 t = convert (string_type_node,  /* (char *) */
8081                              ffecom_1 (ADDR_EXPR,
8082                                        build_pointer_type (TREE_TYPE (ct)),
8083                                        ct));
8084                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8085                               t,
8086                               build_int_2 (offset, 0));
8087                 t = convert (build_pointer_type (type),
8088                              t);
8089                 TREE_CONSTANT (t) = 1;
8090
8091                 addr = TRUE;
8092               }
8093           }
8094           break;
8095
8096         case FFEINFO_whereIMMEDIATE:
8097         case FFEINFO_whereGLOBAL:
8098         case FFEINFO_whereFLEETING:
8099         case FFEINFO_whereFLEETING_CADDR:
8100         case FFEINFO_whereFLEETING_IADDR:
8101         case FFEINFO_whereINTRINSIC:
8102         case FFEINFO_whereCONSTANT_SUBOBJECT:
8103         default:
8104           assert ("ENTITY where unheard of" == NULL);
8105           /* Fall through. */
8106         case FFEINFO_whereANY:
8107           t = error_mark_node;
8108           break;
8109         }
8110       break;
8111
8112     case FFEINFO_kindFUNCTION:
8113       switch (ffeinfo_where (ffesymbol_info (s)))
8114         {
8115         case FFEINFO_whereLOCAL:        /* Me. */
8116           assert (!ffecom_transform_only_dummies_);
8117           t = current_function_decl;
8118           break;
8119
8120         case FFEINFO_whereGLOBAL:
8121           assert (!ffecom_transform_only_dummies_);
8122
8123           if (((g = ffesymbol_global (s)) != NULL)
8124               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8125                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8126               && (ffeglobal_hook (g) != NULL_TREE)
8127               && ffe_is_globals ())
8128             {
8129               t = ffeglobal_hook (g);
8130               break;
8131             }
8132
8133           if (ffesymbol_is_f2c (s)
8134               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8135             t = ffecom_tree_fun_type[bt][kt];
8136           else
8137             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8138
8139           t = build_decl (FUNCTION_DECL,
8140                           ffecom_get_external_identifier_ (s),
8141                           t);
8142           DECL_EXTERNAL (t) = 1;
8143           TREE_PUBLIC (t) = 1;
8144
8145           t = start_decl (t, FALSE);
8146           finish_decl (t, NULL_TREE, FALSE);
8147
8148           if ((g != NULL)
8149               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8150                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8151             ffeglobal_set_hook (g, t);
8152
8153           ffecom_save_tree_forever (t);
8154
8155           break;
8156
8157         case FFEINFO_whereDUMMY:
8158           assert (ffecom_transform_only_dummies_);
8159
8160           if (ffesymbol_is_f2c (s)
8161               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8162             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8163           else
8164             t = build_pointer_type
8165               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8166
8167           t = build_decl (PARM_DECL,
8168                           ffecom_get_identifier_ (ffesymbol_text (s)),
8169                           t);
8170 #if BUILT_FOR_270
8171           DECL_ARTIFICIAL (t) = 1;
8172 #endif
8173           addr = TRUE;
8174           break;
8175
8176         case FFEINFO_whereCONSTANT:     /* Statement function. */
8177           assert (!ffecom_transform_only_dummies_);
8178           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8179           break;
8180
8181         case FFEINFO_whereINTRINSIC:
8182           assert (!ffecom_transform_only_dummies_);
8183           break;                /* Let actual references generate their
8184                                    decls. */
8185
8186         default:
8187           assert ("FUNCTION where unheard of" == NULL);
8188           /* Fall through. */
8189         case FFEINFO_whereANY:
8190           t = error_mark_node;
8191           break;
8192         }
8193       break;
8194
8195     case FFEINFO_kindSUBROUTINE:
8196       switch (ffeinfo_where (ffesymbol_info (s)))
8197         {
8198         case FFEINFO_whereLOCAL:        /* Me. */
8199           assert (!ffecom_transform_only_dummies_);
8200           t = current_function_decl;
8201           break;
8202
8203         case FFEINFO_whereGLOBAL:
8204           assert (!ffecom_transform_only_dummies_);
8205
8206           if (((g = ffesymbol_global (s)) != NULL)
8207               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8208                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8209               && (ffeglobal_hook (g) != NULL_TREE)
8210               && ffe_is_globals ())
8211             {
8212               t = ffeglobal_hook (g);
8213               break;
8214             }
8215
8216           t = build_decl (FUNCTION_DECL,
8217                           ffecom_get_external_identifier_ (s),
8218                           ffecom_tree_subr_type);
8219           DECL_EXTERNAL (t) = 1;
8220           TREE_PUBLIC (t) = 1;
8221
8222           t = start_decl (t, FALSE);
8223           finish_decl (t, NULL_TREE, FALSE);
8224
8225           if ((g != NULL)
8226               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8227                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8228             ffeglobal_set_hook (g, t);
8229
8230           ffecom_save_tree_forever (t);
8231
8232           break;
8233
8234         case FFEINFO_whereDUMMY:
8235           assert (ffecom_transform_only_dummies_);
8236
8237           t = build_decl (PARM_DECL,
8238                           ffecom_get_identifier_ (ffesymbol_text (s)),
8239                           ffecom_tree_ptr_to_subr_type);
8240 #if BUILT_FOR_270
8241           DECL_ARTIFICIAL (t) = 1;
8242 #endif
8243           addr = TRUE;
8244           break;
8245
8246         case FFEINFO_whereINTRINSIC:
8247           assert (!ffecom_transform_only_dummies_);
8248           break;                /* Let actual references generate their
8249                                    decls. */
8250
8251         default:
8252           assert ("SUBROUTINE where unheard of" == NULL);
8253           /* Fall through. */
8254         case FFEINFO_whereANY:
8255           t = error_mark_node;
8256           break;
8257         }
8258       break;
8259
8260     case FFEINFO_kindPROGRAM:
8261       switch (ffeinfo_where (ffesymbol_info (s)))
8262         {
8263         case FFEINFO_whereLOCAL:        /* Me. */
8264           assert (!ffecom_transform_only_dummies_);
8265           t = current_function_decl;
8266           break;
8267
8268         case FFEINFO_whereCOMMON:
8269         case FFEINFO_whereDUMMY:
8270         case FFEINFO_whereGLOBAL:
8271         case FFEINFO_whereRESULT:
8272         case FFEINFO_whereFLEETING:
8273         case FFEINFO_whereFLEETING_CADDR:
8274         case FFEINFO_whereFLEETING_IADDR:
8275         case FFEINFO_whereIMMEDIATE:
8276         case FFEINFO_whereINTRINSIC:
8277         case FFEINFO_whereCONSTANT:
8278         case FFEINFO_whereCONSTANT_SUBOBJECT:
8279         default:
8280           assert ("PROGRAM where unheard of" == NULL);
8281           /* Fall through. */
8282         case FFEINFO_whereANY:
8283           t = error_mark_node;
8284           break;
8285         }
8286       break;
8287
8288     case FFEINFO_kindBLOCKDATA:
8289       switch (ffeinfo_where (ffesymbol_info (s)))
8290         {
8291         case FFEINFO_whereLOCAL:        /* Me. */
8292           assert (!ffecom_transform_only_dummies_);
8293           t = current_function_decl;
8294           break;
8295
8296         case FFEINFO_whereGLOBAL:
8297           assert (!ffecom_transform_only_dummies_);
8298
8299           t = build_decl (FUNCTION_DECL,
8300                           ffecom_get_external_identifier_ (s),
8301                           ffecom_tree_blockdata_type);
8302           DECL_EXTERNAL (t) = 1;
8303           TREE_PUBLIC (t) = 1;
8304
8305           t = start_decl (t, FALSE);
8306           finish_decl (t, NULL_TREE, FALSE);
8307
8308           ffecom_save_tree_forever (t);
8309
8310           break;
8311
8312         case FFEINFO_whereCOMMON:
8313         case FFEINFO_whereDUMMY:
8314         case FFEINFO_whereRESULT:
8315         case FFEINFO_whereFLEETING:
8316         case FFEINFO_whereFLEETING_CADDR:
8317         case FFEINFO_whereFLEETING_IADDR:
8318         case FFEINFO_whereIMMEDIATE:
8319         case FFEINFO_whereINTRINSIC:
8320         case FFEINFO_whereCONSTANT:
8321         case FFEINFO_whereCONSTANT_SUBOBJECT:
8322         default:
8323           assert ("BLOCKDATA where unheard of" == NULL);
8324           /* Fall through. */
8325         case FFEINFO_whereANY:
8326           t = error_mark_node;
8327           break;
8328         }
8329       break;
8330
8331     case FFEINFO_kindCOMMON:
8332       switch (ffeinfo_where (ffesymbol_info (s)))
8333         {
8334         case FFEINFO_whereLOCAL:
8335           assert (!ffecom_transform_only_dummies_);
8336           ffecom_transform_common_ (s);
8337           break;
8338
8339         case FFEINFO_whereNONE:
8340         case FFEINFO_whereCOMMON:
8341         case FFEINFO_whereDUMMY:
8342         case FFEINFO_whereGLOBAL:
8343         case FFEINFO_whereRESULT:
8344         case FFEINFO_whereFLEETING:
8345         case FFEINFO_whereFLEETING_CADDR:
8346         case FFEINFO_whereFLEETING_IADDR:
8347         case FFEINFO_whereIMMEDIATE:
8348         case FFEINFO_whereINTRINSIC:
8349         case FFEINFO_whereCONSTANT:
8350         case FFEINFO_whereCONSTANT_SUBOBJECT:
8351         default:
8352           assert ("COMMON where unheard of" == NULL);
8353           /* Fall through. */
8354         case FFEINFO_whereANY:
8355           t = error_mark_node;
8356           break;
8357         }
8358       break;
8359
8360     case FFEINFO_kindCONSTRUCT:
8361       switch (ffeinfo_where (ffesymbol_info (s)))
8362         {
8363         case FFEINFO_whereLOCAL:
8364           assert (!ffecom_transform_only_dummies_);
8365           break;
8366
8367         case FFEINFO_whereNONE:
8368         case FFEINFO_whereCOMMON:
8369         case FFEINFO_whereDUMMY:
8370         case FFEINFO_whereGLOBAL:
8371         case FFEINFO_whereRESULT:
8372         case FFEINFO_whereFLEETING:
8373         case FFEINFO_whereFLEETING_CADDR:
8374         case FFEINFO_whereFLEETING_IADDR:
8375         case FFEINFO_whereIMMEDIATE:
8376         case FFEINFO_whereINTRINSIC:
8377         case FFEINFO_whereCONSTANT:
8378         case FFEINFO_whereCONSTANT_SUBOBJECT:
8379         default:
8380           assert ("CONSTRUCT where unheard of" == NULL);
8381           /* Fall through. */
8382         case FFEINFO_whereANY:
8383           t = error_mark_node;
8384           break;
8385         }
8386       break;
8387
8388     case FFEINFO_kindNAMELIST:
8389       switch (ffeinfo_where (ffesymbol_info (s)))
8390         {
8391         case FFEINFO_whereLOCAL:
8392           assert (!ffecom_transform_only_dummies_);
8393           t = ffecom_transform_namelist_ (s);
8394           break;
8395
8396         case FFEINFO_whereNONE:
8397         case FFEINFO_whereCOMMON:
8398         case FFEINFO_whereDUMMY:
8399         case FFEINFO_whereGLOBAL:
8400         case FFEINFO_whereRESULT:
8401         case FFEINFO_whereFLEETING:
8402         case FFEINFO_whereFLEETING_CADDR:
8403         case FFEINFO_whereFLEETING_IADDR:
8404         case FFEINFO_whereIMMEDIATE:
8405         case FFEINFO_whereINTRINSIC:
8406         case FFEINFO_whereCONSTANT:
8407         case FFEINFO_whereCONSTANT_SUBOBJECT:
8408         default:
8409           assert ("NAMELIST where unheard of" == NULL);
8410           /* Fall through. */
8411         case FFEINFO_whereANY:
8412           t = error_mark_node;
8413           break;
8414         }
8415       break;
8416
8417     default:
8418       assert ("kind unheard of" == NULL);
8419       /* Fall through. */
8420     case FFEINFO_kindANY:
8421       t = error_mark_node;
8422       break;
8423     }
8424
8425   ffesymbol_hook (s).decl_tree = t;
8426   ffesymbol_hook (s).length_tree = tlen;
8427   ffesymbol_hook (s).addr = addr;
8428
8429   lineno = old_lineno;
8430   input_filename = old_input_filename;
8431
8432   return s;
8433 }
8434
8435 #endif
8436 /* Transform into ASSIGNable symbol.
8437
8438    Symbol has already been transformed, but for whatever reason, the
8439    resulting decl_tree has been deemed not usable for an ASSIGN target.
8440    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8441    another local symbol of type void * and stuff that in the assign_tree
8442    argument.  The F77/F90 standards allow this implementation.  */
8443
8444 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8445 static ffesymbol
8446 ffecom_sym_transform_assign_ (ffesymbol s)
8447 {
8448   tree t;                       /* Transformed thingy. */
8449   int old_lineno = lineno;
8450   const char *old_input_filename = input_filename;
8451
8452   if (ffesymbol_sfdummyparent (s) == NULL)
8453     {
8454       input_filename = ffesymbol_where_filename (s);
8455       lineno = ffesymbol_where_filelinenum (s);
8456     }
8457   else
8458     {
8459       ffesymbol sf = ffesymbol_sfdummyparent (s);
8460
8461       input_filename = ffesymbol_where_filename (sf);
8462       lineno = ffesymbol_where_filelinenum (sf);
8463     }
8464
8465   assert (!ffecom_transform_only_dummies_);
8466
8467   t = build_decl (VAR_DECL,
8468                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8469                                                    ffesymbol_text (s)),
8470                   TREE_TYPE (null_pointer_node));
8471
8472   switch (ffesymbol_where (s))
8473     {
8474     case FFEINFO_whereLOCAL:
8475       /* Unlike for regular vars, SAVE status is easy to determine for
8476          ASSIGNed vars, since there's no initialization, there's no
8477          effective storage association (so "SAVE J" does not apply to
8478          K even given "EQUIVALENCE (J,K)"), there's no size issue
8479          to worry about, etc.  */
8480       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8481           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8482           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8483         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8484       else
8485         TREE_STATIC (t) = 0;    /* No need to make static. */
8486       break;
8487
8488     case FFEINFO_whereCOMMON:
8489       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8490       break;
8491
8492     case FFEINFO_whereDUMMY:
8493       /* Note that twinning a DUMMY means the caller won't see
8494          the ASSIGNed value.  But both F77 and F90 allow implementations
8495          to do this, i.e. disallow Fortran code that would try and
8496          take advantage of actually putting a label into a variable
8497          via a dummy argument (or any other storage association, for
8498          that matter).  */
8499       TREE_STATIC (t) = 0;
8500       break;
8501
8502     default:
8503       TREE_STATIC (t) = 0;
8504       break;
8505     }
8506
8507   t = start_decl (t, FALSE);
8508   finish_decl (t, NULL_TREE, FALSE);
8509
8510   ffesymbol_hook (s).assign_tree = t;
8511
8512   lineno = old_lineno;
8513   input_filename = old_input_filename;
8514
8515   return s;
8516 }
8517
8518 #endif
8519 /* Implement COMMON area in back end.
8520
8521    Because COMMON-based variables can be referenced in the dimension
8522    expressions of dummy (adjustable) arrays, and because dummies
8523    (in the gcc back end) need to be put in the outer binding level
8524    of a function (which has two binding levels, the outer holding
8525    the dummies and the inner holding the other vars), special care
8526    must be taken to handle COMMON areas.
8527
8528    The current strategy is basically to always tell the back end about
8529    the COMMON area as a top-level external reference to just a block
8530    of storage of the master type of that area (e.g. integer, real,
8531    character, whatever -- not a structure).  As a distinct action,
8532    if initial values are provided, tell the back end about the area
8533    as a top-level non-external (initialized) area and remember not to
8534    allow further initialization or expansion of the area.  Meanwhile,
8535    if no initialization happens at all, tell the back end about
8536    the largest size we've seen declared so the space does get reserved.
8537    (This function doesn't handle all that stuff, but it does some
8538    of the important things.)
8539
8540    Meanwhile, for COMMON variables themselves, just keep creating
8541    references like *((float *) (&common_area + offset)) each time
8542    we reference the variable.  In other words, don't make a VAR_DECL
8543    or any kind of component reference (like we used to do before 0.4),
8544    though we might do that as well just for debugging purposes (and
8545    stuff the rtl with the appropriate offset expression).  */
8546
8547 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8548 static void
8549 ffecom_transform_common_ (ffesymbol s)
8550 {
8551   ffestorag st = ffesymbol_storage (s);
8552   ffeglobal g = ffesymbol_global (s);
8553   tree cbt;
8554   tree cbtype;
8555   tree init;
8556   tree high;
8557   bool is_init = ffestorag_is_init (st);
8558
8559   assert (st != NULL);
8560
8561   if ((g == NULL)
8562       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8563     return;
8564
8565   /* First update the size of the area in global terms.  */
8566
8567   ffeglobal_size_common (s, ffestorag_size (st));
8568
8569   if (!ffeglobal_common_init (g))
8570     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8571
8572   cbt = ffeglobal_hook (g);
8573
8574   /* If we already have declared this common block for a previous program
8575      unit, and either we already initialized it or we don't have new
8576      initialization for it, just return what we have without changing it.  */
8577
8578   if ((cbt != NULL_TREE)
8579       && (!is_init
8580           || !DECL_EXTERNAL (cbt)))
8581     {
8582       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8583       return;
8584     }
8585
8586   /* Process inits.  */
8587
8588   if (is_init)
8589     {
8590       if (ffestorag_init (st) != NULL)
8591         {
8592           ffebld sexp;
8593
8594           /* Set the padding for the expression, so ffecom_expr
8595              knows to insert that many zeros.  */
8596           switch (ffebld_op (sexp = ffestorag_init (st)))
8597             {
8598             case FFEBLD_opCONTER:
8599               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8600               break;
8601
8602             case FFEBLD_opARRTER:
8603               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8604               break;
8605
8606             case FFEBLD_opACCTER:
8607               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8608               break;
8609
8610             default:
8611               assert ("bad op for cmn init (pad)" == NULL);
8612               break;
8613             }
8614
8615           init = ffecom_expr (sexp);
8616           if (init == error_mark_node)
8617             {                   /* Hopefully the back end complained! */
8618               init = NULL_TREE;
8619               if (cbt != NULL_TREE)
8620                 return;
8621             }
8622         }
8623       else
8624         init = error_mark_node;
8625     }
8626   else
8627     init = NULL_TREE;
8628
8629   /* cbtype must be permanently allocated!  */
8630
8631   /* Allocate the MAX of the areas so far, seen filewide.  */
8632   high = build_int_2 ((ffeglobal_common_size (g)
8633                        + ffeglobal_common_pad (g)) - 1, 0);
8634   TREE_TYPE (high) = ffecom_integer_type_node;
8635
8636   if (init)
8637     cbtype = build_array_type (char_type_node,
8638                                build_range_type (integer_type_node,
8639                                                  integer_zero_node,
8640                                                  high));
8641   else
8642     cbtype = build_array_type (char_type_node, NULL_TREE);
8643
8644   if (cbt == NULL_TREE)
8645     {
8646       cbt
8647         = build_decl (VAR_DECL,
8648                       ffecom_get_external_identifier_ (s),
8649                       cbtype);
8650       TREE_STATIC (cbt) = 1;
8651       TREE_PUBLIC (cbt) = 1;
8652     }
8653   else
8654     {
8655       assert (is_init);
8656       TREE_TYPE (cbt) = cbtype;
8657     }
8658   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8659   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8660
8661   cbt = start_decl (cbt, TRUE);
8662   if (ffeglobal_hook (g) != NULL)
8663     assert (cbt == ffeglobal_hook (g));
8664
8665   assert (!init || !DECL_EXTERNAL (cbt));
8666
8667   /* Make sure that any type can live in COMMON and be referenced
8668      without getting a bus error.  We could pick the most restrictive
8669      alignment of all entities actually placed in the COMMON, but
8670      this seems easy enough.  */
8671
8672   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8673   DECL_USER_ALIGN (cbt) = 0;
8674
8675   if (is_init && (ffestorag_init (st) == NULL))
8676     init = ffecom_init_zero_ (cbt);
8677
8678   finish_decl (cbt, init, TRUE);
8679
8680   if (is_init)
8681     ffestorag_set_init (st, ffebld_new_any ());
8682
8683   if (init)
8684     {
8685       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8686       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8687       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8688                                      (ffeglobal_common_size (g)
8689                                       + ffeglobal_common_pad (g))));
8690     }
8691
8692   ffeglobal_set_hook (g, cbt);
8693
8694   ffestorag_set_hook (st, cbt);
8695
8696   ffecom_save_tree_forever (cbt);
8697 }
8698
8699 #endif
8700 /* Make master area for local EQUIVALENCE.  */
8701
8702 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8703 static void
8704 ffecom_transform_equiv_ (ffestorag eqst)
8705 {
8706   tree eqt;
8707   tree eqtype;
8708   tree init;
8709   tree high;
8710   bool is_init = ffestorag_is_init (eqst);
8711
8712   assert (eqst != NULL);
8713
8714   eqt = ffestorag_hook (eqst);
8715
8716   if (eqt != NULL_TREE)
8717     return;
8718
8719   /* Process inits.  */
8720
8721   if (is_init)
8722     {
8723       if (ffestorag_init (eqst) != NULL)
8724         {
8725           ffebld sexp;
8726
8727           /* Set the padding for the expression, so ffecom_expr
8728              knows to insert that many zeros.  */
8729           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8730             {
8731             case FFEBLD_opCONTER:
8732               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8733               break;
8734
8735             case FFEBLD_opARRTER:
8736               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8737               break;
8738
8739             case FFEBLD_opACCTER:
8740               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8741               break;
8742
8743             default:
8744               assert ("bad op for eqv init (pad)" == NULL);
8745               break;
8746             }
8747
8748           init = ffecom_expr (sexp);
8749           if (init == error_mark_node)
8750             init = NULL_TREE;   /* Hopefully the back end complained! */
8751         }
8752       else
8753         init = error_mark_node;
8754     }
8755   else if (ffe_is_init_local_zero ())
8756     init = error_mark_node;
8757   else
8758     init = NULL_TREE;
8759
8760   ffecom_member_namelisted_ = FALSE;
8761   ffestorag_drive (ffestorag_list_equivs (eqst),
8762                    &ffecom_member_phase1_,
8763                    eqst);
8764
8765   high = build_int_2 ((ffestorag_size (eqst)
8766                        + ffestorag_modulo (eqst)) - 1, 0);
8767   TREE_TYPE (high) = ffecom_integer_type_node;
8768
8769   eqtype = build_array_type (char_type_node,
8770                              build_range_type (ffecom_integer_type_node,
8771                                                ffecom_integer_zero_node,
8772                                                high));
8773
8774   eqt = build_decl (VAR_DECL,
8775                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8776                                                     ffesymbol_text
8777                                                     (ffestorag_symbol (eqst))),
8778                     eqtype);
8779   DECL_EXTERNAL (eqt) = 0;
8780   if (is_init
8781       || ffecom_member_namelisted_
8782 #ifdef FFECOM_sizeMAXSTACKITEM
8783       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8784 #endif
8785       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8786           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8787           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8788     TREE_STATIC (eqt) = 1;
8789   else
8790     TREE_STATIC (eqt) = 0;
8791   TREE_PUBLIC (eqt) = 0;
8792   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8793   DECL_CONTEXT (eqt) = current_function_decl;
8794   if (init)
8795     DECL_INITIAL (eqt) = error_mark_node;
8796   else
8797     DECL_INITIAL (eqt) = NULL_TREE;
8798
8799   eqt = start_decl (eqt, FALSE);
8800
8801   /* Make sure that any type can live in EQUIVALENCE and be referenced
8802      without getting a bus error.  We could pick the most restrictive
8803      alignment of all entities actually placed in the EQUIVALENCE, but
8804      this seems easy enough.  */
8805
8806   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8807   DECL_USER_ALIGN (eqt) = 0;
8808
8809   if ((!is_init && ffe_is_init_local_zero ())
8810       || (is_init && (ffestorag_init (eqst) == NULL)))
8811     init = ffecom_init_zero_ (eqt);
8812
8813   finish_decl (eqt, init, FALSE);
8814
8815   if (is_init)
8816     ffestorag_set_init (eqst, ffebld_new_any ());
8817
8818   {
8819     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8820     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8821                                    (ffestorag_size (eqst)
8822                                     + ffestorag_modulo (eqst))));
8823   }
8824
8825   ffestorag_set_hook (eqst, eqt);
8826
8827   ffestorag_drive (ffestorag_list_equivs (eqst),
8828                    &ffecom_member_phase2_,
8829                    eqst);
8830 }
8831
8832 #endif
8833 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8834
8835 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8836 static tree
8837 ffecom_transform_namelist_ (ffesymbol s)
8838 {
8839   tree nmlt;
8840   tree nmltype = ffecom_type_namelist_ ();
8841   tree nmlinits;
8842   tree nameinit;
8843   tree varsinit;
8844   tree nvarsinit;
8845   tree field;
8846   tree high;
8847   int i;
8848   static int mynumber = 0;
8849
8850   nmlt = build_decl (VAR_DECL,
8851                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8852                                                      mynumber++),
8853                      nmltype);
8854   TREE_STATIC (nmlt) = 1;
8855   DECL_INITIAL (nmlt) = error_mark_node;
8856
8857   nmlt = start_decl (nmlt, FALSE);
8858
8859   /* Process inits.  */
8860
8861   i = strlen (ffesymbol_text (s));
8862
8863   high = build_int_2 (i, 0);
8864   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8865
8866   nameinit = ffecom_build_f2c_string_ (i + 1,
8867                                        ffesymbol_text (s));
8868   TREE_TYPE (nameinit)
8869     = build_type_variant
8870     (build_array_type
8871      (char_type_node,
8872       build_range_type (ffecom_f2c_ftnlen_type_node,
8873                         ffecom_f2c_ftnlen_one_node,
8874                         high)),
8875      1, 0);
8876   TREE_CONSTANT (nameinit) = 1;
8877   TREE_STATIC (nameinit) = 1;
8878   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8879                        nameinit);
8880
8881   varsinit = ffecom_vardesc_array_ (s);
8882   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8883                        varsinit);
8884   TREE_CONSTANT (varsinit) = 1;
8885   TREE_STATIC (varsinit) = 1;
8886
8887   {
8888     ffebld b;
8889
8890     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8891       ++i;
8892   }
8893   nvarsinit = build_int_2 (i, 0);
8894   TREE_TYPE (nvarsinit) = integer_type_node;
8895   TREE_CONSTANT (nvarsinit) = 1;
8896   TREE_STATIC (nvarsinit) = 1;
8897
8898   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8899   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8900                                            varsinit);
8901   TREE_CHAIN (TREE_CHAIN (nmlinits))
8902     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8903
8904   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8905   TREE_CONSTANT (nmlinits) = 1;
8906   TREE_STATIC (nmlinits) = 1;
8907
8908   finish_decl (nmlt, nmlinits, FALSE);
8909
8910   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8911
8912   return nmlt;
8913 }
8914
8915 #endif
8916
8917 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8918    analyzed on the assumption it is calculating a pointer to be
8919    indirected through.  It must return the proper decl and offset,
8920    taking into account different units of measurements for offsets.  */
8921
8922 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8923 static void
8924 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8925                            tree t)
8926 {
8927   switch (TREE_CODE (t))
8928     {
8929     case NOP_EXPR:
8930     case CONVERT_EXPR:
8931     case NON_LVALUE_EXPR:
8932       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8933       break;
8934
8935     case PLUS_EXPR:
8936       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8937       if ((*decl == NULL_TREE)
8938           || (*decl == error_mark_node))
8939         break;
8940
8941       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8942         {
8943           /* An offset into COMMON.  */
8944           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8945                                  *offset, TREE_OPERAND (t, 1)));
8946           /* Convert offset (presumably in bytes) into canonical units
8947              (presumably bits).  */
8948           *offset = size_binop (MULT_EXPR,
8949                                 convert (bitsizetype, *offset),
8950                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8951           break;
8952         }
8953       /* Not a COMMON reference, so an unrecognized pattern.  */
8954       *decl = error_mark_node;
8955       break;
8956
8957     case PARM_DECL:
8958       *decl = t;
8959       *offset = bitsize_zero_node;
8960       break;
8961
8962     case ADDR_EXPR:
8963       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8964         {
8965           /* A reference to COMMON.  */
8966           *decl = TREE_OPERAND (t, 0);
8967           *offset = bitsize_zero_node;
8968           break;
8969         }
8970       /* Fall through.  */
8971     default:
8972       /* Not a COMMON reference, so an unrecognized pattern.  */
8973       *decl = error_mark_node;
8974       break;
8975     }
8976 }
8977 #endif
8978
8979 /* Given a tree that is possibly intended for use as an lvalue, return
8980    information representing a canonical view of that tree as a decl, an
8981    offset into that decl, and a size for the lvalue.
8982
8983    If there's no applicable decl, NULL_TREE is returned for the decl,
8984    and the other fields are left undefined.
8985
8986    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8987    is returned for the decl, and the other fields are left undefined.
8988
8989    Otherwise, the decl returned currently is either a VAR_DECL or a
8990    PARM_DECL.
8991
8992    The offset returned is always valid, but of course not necessarily
8993    a constant, and not necessarily converted into the appropriate
8994    type, leaving that up to the caller (so as to avoid that overhead
8995    if the decls being looked at are different anyway).
8996
8997    If the size cannot be determined (e.g. an adjustable array),
8998    an ERROR_MARK node is returned for the size.  Otherwise, the
8999    size returned is valid, not necessarily a constant, and not
9000    necessarily converted into the appropriate type as with the
9001    offset.
9002
9003    Note that the offset and size expressions are expressed in the
9004    base storage units (usually bits) rather than in the units of
9005    the type of the decl, because two decls with different types
9006    might overlap but with apparently non-overlapping array offsets,
9007    whereas converting the array offsets to consistant offsets will
9008    reveal the overlap.  */
9009
9010 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9011 static void
9012 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9013                            tree *size, tree t)
9014 {
9015   /* The default path is to report a nonexistant decl.  */
9016   *decl = NULL_TREE;
9017
9018   if (t == NULL_TREE)
9019     return;
9020
9021   switch (TREE_CODE (t))
9022     {
9023     case ERROR_MARK:
9024     case IDENTIFIER_NODE:
9025     case INTEGER_CST:
9026     case REAL_CST:
9027     case COMPLEX_CST:
9028     case STRING_CST:
9029     case CONST_DECL:
9030     case PLUS_EXPR:
9031     case MINUS_EXPR:
9032     case MULT_EXPR:
9033     case TRUNC_DIV_EXPR:
9034     case CEIL_DIV_EXPR:
9035     case FLOOR_DIV_EXPR:
9036     case ROUND_DIV_EXPR:
9037     case TRUNC_MOD_EXPR:
9038     case CEIL_MOD_EXPR:
9039     case FLOOR_MOD_EXPR:
9040     case ROUND_MOD_EXPR:
9041     case RDIV_EXPR:
9042     case EXACT_DIV_EXPR:
9043     case FIX_TRUNC_EXPR:
9044     case FIX_CEIL_EXPR:
9045     case FIX_FLOOR_EXPR:
9046     case FIX_ROUND_EXPR:
9047     case FLOAT_EXPR:
9048     case NEGATE_EXPR:
9049     case MIN_EXPR:
9050     case MAX_EXPR:
9051     case ABS_EXPR:
9052     case FFS_EXPR:
9053     case LSHIFT_EXPR:
9054     case RSHIFT_EXPR:
9055     case LROTATE_EXPR:
9056     case RROTATE_EXPR:
9057     case BIT_IOR_EXPR:
9058     case BIT_XOR_EXPR:
9059     case BIT_AND_EXPR:
9060     case BIT_ANDTC_EXPR:
9061     case BIT_NOT_EXPR:
9062     case TRUTH_ANDIF_EXPR:
9063     case TRUTH_ORIF_EXPR:
9064     case TRUTH_AND_EXPR:
9065     case TRUTH_OR_EXPR:
9066     case TRUTH_XOR_EXPR:
9067     case TRUTH_NOT_EXPR:
9068     case LT_EXPR:
9069     case LE_EXPR:
9070     case GT_EXPR:
9071     case GE_EXPR:
9072     case EQ_EXPR:
9073     case NE_EXPR:
9074     case COMPLEX_EXPR:
9075     case CONJ_EXPR:
9076     case REALPART_EXPR:
9077     case IMAGPART_EXPR:
9078     case LABEL_EXPR:
9079     case COMPONENT_REF:
9080     case COMPOUND_EXPR:
9081     case ADDR_EXPR:
9082       return;
9083
9084     case VAR_DECL:
9085     case PARM_DECL:
9086       *decl = t;
9087       *offset = bitsize_zero_node;
9088       *size = TYPE_SIZE (TREE_TYPE (t));
9089       return;
9090
9091     case ARRAY_REF:
9092       {
9093         tree array = TREE_OPERAND (t, 0);
9094         tree element = TREE_OPERAND (t, 1);
9095         tree init_offset;
9096
9097         if ((array == NULL_TREE)
9098             || (element == NULL_TREE))
9099           {
9100             *decl = error_mark_node;
9101             return;
9102           }
9103
9104         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9105                                    array);
9106         if ((*decl == NULL_TREE)
9107             || (*decl == error_mark_node))
9108           return;
9109
9110         /* Calculate ((element - base) * NBBY) + init_offset.  */
9111         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9112                                element,
9113                                TYPE_MIN_VALUE (TYPE_DOMAIN
9114                                                (TREE_TYPE (array)))));
9115
9116         *offset = size_binop (MULT_EXPR,
9117                               convert (bitsizetype, *offset),
9118                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9119
9120         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9121
9122         *size = TYPE_SIZE (TREE_TYPE (t));
9123         return;
9124       }
9125
9126     case INDIRECT_REF:
9127
9128       /* Most of this code is to handle references to COMMON.  And so
9129          far that is useful only for calling library functions, since
9130          external (user) functions might reference common areas.  But
9131          even calling an external function, it's worthwhile to decode
9132          COMMON references because if not storing into COMMON, we don't
9133          want COMMON-based arguments to gratuitously force use of a
9134          temporary.  */
9135
9136       *size = TYPE_SIZE (TREE_TYPE (t));
9137
9138       ffecom_tree_canonize_ptr_ (decl, offset,
9139                                  TREE_OPERAND (t, 0));
9140
9141       return;
9142
9143     case CONVERT_EXPR:
9144     case NOP_EXPR:
9145     case MODIFY_EXPR:
9146     case NON_LVALUE_EXPR:
9147     case RESULT_DECL:
9148     case FIELD_DECL:
9149     case COND_EXPR:             /* More cases than we can handle. */
9150     case SAVE_EXPR:
9151     case REFERENCE_EXPR:
9152     case PREDECREMENT_EXPR:
9153     case PREINCREMENT_EXPR:
9154     case POSTDECREMENT_EXPR:
9155     case POSTINCREMENT_EXPR:
9156     case CALL_EXPR:
9157     default:
9158       *decl = error_mark_node;
9159       return;
9160     }
9161 }
9162 #endif
9163
9164 /* Do divide operation appropriate to type of operands.  */
9165
9166 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9167 static tree
9168 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9169                      tree dest_tree, ffebld dest, bool *dest_used,
9170                      tree hook)
9171 {
9172   if ((left == error_mark_node)
9173       || (right == error_mark_node))
9174     return error_mark_node;
9175
9176   switch (TREE_CODE (tree_type))
9177     {
9178     case INTEGER_TYPE:
9179       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9180                        left,
9181                        right);
9182
9183     case COMPLEX_TYPE:
9184       if (! optimize_size)
9185         return ffecom_2 (RDIV_EXPR, tree_type,
9186                          left,
9187                          right);
9188       {
9189         ffecomGfrt ix;
9190
9191         if (TREE_TYPE (tree_type)
9192             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9193           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9194         else
9195           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9196
9197         left = ffecom_1 (ADDR_EXPR,
9198                          build_pointer_type (TREE_TYPE (left)),
9199                          left);
9200         left = build_tree_list (NULL_TREE, left);
9201         right = ffecom_1 (ADDR_EXPR,
9202                           build_pointer_type (TREE_TYPE (right)),
9203                           right);
9204         right = build_tree_list (NULL_TREE, right);
9205         TREE_CHAIN (left) = right;
9206
9207         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9208                              ffecom_gfrt_kindtype (ix),
9209                              ffe_is_f2c_library (),
9210                              tree_type,
9211                              left,
9212                              dest_tree, dest, dest_used,
9213                              NULL_TREE, TRUE, hook);
9214       }
9215       break;
9216
9217     case RECORD_TYPE:
9218       {
9219         ffecomGfrt ix;
9220
9221         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9222             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9223           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9224         else
9225           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9226
9227         left = ffecom_1 (ADDR_EXPR,
9228                          build_pointer_type (TREE_TYPE (left)),
9229                          left);
9230         left = build_tree_list (NULL_TREE, left);
9231         right = ffecom_1 (ADDR_EXPR,
9232                           build_pointer_type (TREE_TYPE (right)),
9233                           right);
9234         right = build_tree_list (NULL_TREE, right);
9235         TREE_CHAIN (left) = right;
9236
9237         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9238                              ffecom_gfrt_kindtype (ix),
9239                              ffe_is_f2c_library (),
9240                              tree_type,
9241                              left,
9242                              dest_tree, dest, dest_used,
9243                              NULL_TREE, TRUE, hook);
9244       }
9245       break;
9246
9247     default:
9248       return ffecom_2 (RDIV_EXPR, tree_type,
9249                        left,
9250                        right);
9251     }
9252 }
9253
9254 #endif
9255 /* Build type info for non-dummy variable.  */
9256
9257 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9258 static tree
9259 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9260                        ffeinfoKindtype kt)
9261 {
9262   tree type;
9263   ffebld dl;
9264   ffebld dim;
9265   tree lowt;
9266   tree hight;
9267
9268   type = ffecom_tree_type[bt][kt];
9269   if (bt == FFEINFO_basictypeCHARACTER)
9270     {
9271       hight = build_int_2 (ffesymbol_size (s), 0);
9272       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9273
9274       type
9275         = build_array_type
9276           (type,
9277            build_range_type (ffecom_f2c_ftnlen_type_node,
9278                              ffecom_f2c_ftnlen_one_node,
9279                              hight));
9280       type = ffecom_check_size_overflow_ (s, type, FALSE);
9281     }
9282
9283   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9284     {
9285       if (type == error_mark_node)
9286         break;
9287
9288       dim = ffebld_head (dl);
9289       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9290
9291       if (ffebld_left (dim) == NULL)
9292         lowt = integer_one_node;
9293       else
9294         lowt = ffecom_expr (ffebld_left (dim));
9295
9296       if (TREE_CODE (lowt) != INTEGER_CST)
9297         lowt = variable_size (lowt);
9298
9299       assert (ffebld_right (dim) != NULL);
9300       hight = ffecom_expr (ffebld_right (dim));
9301
9302       if (TREE_CODE (hight) != INTEGER_CST)
9303         hight = variable_size (hight);
9304
9305       type = build_array_type (type,
9306                                build_range_type (ffecom_integer_type_node,
9307                                                  lowt, hight));
9308       type = ffecom_check_size_overflow_ (s, type, FALSE);
9309     }
9310
9311   return type;
9312 }
9313
9314 #endif
9315 /* Build Namelist type.  */
9316
9317 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9318 static tree
9319 ffecom_type_namelist_ ()
9320 {
9321   static tree type = NULL_TREE;
9322
9323   if (type == NULL_TREE)
9324     {
9325       static tree namefield, varsfield, nvarsfield;
9326       tree vardesctype;
9327
9328       vardesctype = ffecom_type_vardesc_ ();
9329
9330       type = make_node (RECORD_TYPE);
9331
9332       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9333
9334       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9335                                      string_type_node);
9336       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9337       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9338                                       integer_type_node);
9339
9340       TYPE_FIELDS (type) = namefield;
9341       layout_type (type);
9342
9343       ggc_add_tree_root (&type, 1);
9344     }
9345
9346   return type;
9347 }
9348
9349 #endif
9350
9351 /* Build Vardesc type.  */
9352
9353 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9354 static tree
9355 ffecom_type_vardesc_ ()
9356 {
9357   static tree type = NULL_TREE;
9358   static tree namefield, addrfield, dimsfield, typefield;
9359
9360   if (type == NULL_TREE)
9361     {
9362       type = make_node (RECORD_TYPE);
9363
9364       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9365                                      string_type_node);
9366       addrfield = ffecom_decl_field (type, namefield, "addr",
9367                                      string_type_node);
9368       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9369                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9370       typefield = ffecom_decl_field (type, dimsfield, "type",
9371                                      integer_type_node);
9372
9373       TYPE_FIELDS (type) = namefield;
9374       layout_type (type);
9375
9376       ggc_add_tree_root (&type, 1);
9377     }
9378
9379   return type;
9380 }
9381
9382 #endif
9383
9384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9385 static tree
9386 ffecom_vardesc_ (ffebld expr)
9387 {
9388   ffesymbol s;
9389
9390   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9391   s = ffebld_symter (expr);
9392
9393   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9394     {
9395       int i;
9396       tree vardesctype = ffecom_type_vardesc_ ();
9397       tree var;
9398       tree nameinit;
9399       tree dimsinit;
9400       tree addrinit;
9401       tree typeinit;
9402       tree field;
9403       tree varinits;
9404       static int mynumber = 0;
9405
9406       var = build_decl (VAR_DECL,
9407                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9408                                                         mynumber++),
9409                         vardesctype);
9410       TREE_STATIC (var) = 1;
9411       DECL_INITIAL (var) = error_mark_node;
9412
9413       var = start_decl (var, FALSE);
9414
9415       /* Process inits.  */
9416
9417       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9418                                            + 1,
9419                                            ffesymbol_text (s));
9420       TREE_TYPE (nameinit)
9421         = build_type_variant
9422         (build_array_type
9423          (char_type_node,
9424           build_range_type (integer_type_node,
9425                             integer_one_node,
9426                             build_int_2 (i, 0))),
9427          1, 0);
9428       TREE_CONSTANT (nameinit) = 1;
9429       TREE_STATIC (nameinit) = 1;
9430       nameinit = ffecom_1 (ADDR_EXPR,
9431                            build_pointer_type (TREE_TYPE (nameinit)),
9432                            nameinit);
9433
9434       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9435
9436       dimsinit = ffecom_vardesc_dims_ (s);
9437
9438       if (typeinit == NULL_TREE)
9439         {
9440           ffeinfoBasictype bt = ffesymbol_basictype (s);
9441           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9442           int tc = ffecom_f2c_typecode (bt, kt);
9443
9444           assert (tc != -1);
9445           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9446         }
9447       else
9448         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9449
9450       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9451                                   nameinit);
9452       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9453                                                addrinit);
9454       TREE_CHAIN (TREE_CHAIN (varinits))
9455         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9456       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9457         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9458
9459       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9460       TREE_CONSTANT (varinits) = 1;
9461       TREE_STATIC (varinits) = 1;
9462
9463       finish_decl (var, varinits, FALSE);
9464
9465       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9466
9467       ffesymbol_hook (s).vardesc_tree = var;
9468     }
9469
9470   return ffesymbol_hook (s).vardesc_tree;
9471 }
9472
9473 #endif
9474 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9475 static tree
9476 ffecom_vardesc_array_ (ffesymbol s)
9477 {
9478   ffebld b;
9479   tree list;
9480   tree item = NULL_TREE;
9481   tree var;
9482   int i;
9483   static int mynumber = 0;
9484
9485   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9486        b != NULL;
9487        b = ffebld_trail (b), ++i)
9488     {
9489       tree t;
9490
9491       t = ffecom_vardesc_ (ffebld_head (b));
9492
9493       if (list == NULL_TREE)
9494         list = item = build_tree_list (NULL_TREE, t);
9495       else
9496         {
9497           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9498           item = TREE_CHAIN (item);
9499         }
9500     }
9501
9502   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9503                            build_range_type (integer_type_node,
9504                                              integer_one_node,
9505                                              build_int_2 (i, 0)));
9506   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9507   TREE_CONSTANT (list) = 1;
9508   TREE_STATIC (list) = 1;
9509
9510   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9511   var = build_decl (VAR_DECL, var, item);
9512   TREE_STATIC (var) = 1;
9513   DECL_INITIAL (var) = error_mark_node;
9514   var = start_decl (var, FALSE);
9515   finish_decl (var, list, FALSE);
9516
9517   return var;
9518 }
9519
9520 #endif
9521 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9522 static tree
9523 ffecom_vardesc_dims_ (ffesymbol s)
9524 {
9525   if (ffesymbol_dims (s) == NULL)
9526     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9527                     integer_zero_node);
9528
9529   {
9530     ffebld b;
9531     ffebld e;
9532     tree list;
9533     tree backlist;
9534     tree item = NULL_TREE;
9535     tree var;
9536     tree numdim;
9537     tree numelem;
9538     tree baseoff = NULL_TREE;
9539     static int mynumber = 0;
9540
9541     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9542     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9543
9544     numelem = ffecom_expr (ffesymbol_arraysize (s));
9545     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9546
9547     list = NULL_TREE;
9548     backlist = NULL_TREE;
9549     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9550          b != NULL;
9551          b = ffebld_trail (b), e = ffebld_trail (e))
9552       {
9553         tree t;
9554         tree low;
9555         tree back;
9556
9557         if (ffebld_trail (b) == NULL)
9558           t = NULL_TREE;
9559         else
9560           {
9561             t = convert (ffecom_f2c_ftnlen_type_node,
9562                          ffecom_expr (ffebld_head (e)));
9563
9564             if (list == NULL_TREE)
9565               list = item = build_tree_list (NULL_TREE, t);
9566             else
9567               {
9568                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9569                 item = TREE_CHAIN (item);
9570               }
9571           }
9572
9573         if (ffebld_left (ffebld_head (b)) == NULL)
9574           low = ffecom_integer_one_node;
9575         else
9576           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9577         low = convert (ffecom_f2c_ftnlen_type_node, low);
9578
9579         back = build_tree_list (low, t);
9580         TREE_CHAIN (back) = backlist;
9581         backlist = back;
9582       }
9583
9584     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9585       {
9586         if (TREE_VALUE (item) == NULL_TREE)
9587           baseoff = TREE_PURPOSE (item);
9588         else
9589           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9590                               TREE_PURPOSE (item),
9591                               ffecom_2 (MULT_EXPR,
9592                                         ffecom_f2c_ftnlen_type_node,
9593                                         TREE_VALUE (item),
9594                                         baseoff));
9595       }
9596
9597     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9598
9599     baseoff = build_tree_list (NULL_TREE, baseoff);
9600     TREE_CHAIN (baseoff) = list;
9601
9602     numelem = build_tree_list (NULL_TREE, numelem);
9603     TREE_CHAIN (numelem) = baseoff;
9604
9605     numdim = build_tree_list (NULL_TREE, numdim);
9606     TREE_CHAIN (numdim) = numelem;
9607
9608     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9609                              build_range_type (integer_type_node,
9610                                                integer_zero_node,
9611                                                build_int_2
9612                                                ((int) ffesymbol_rank (s)
9613                                                 + 2, 0)));
9614     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9615     TREE_CONSTANT (list) = 1;
9616     TREE_STATIC (list) = 1;
9617
9618     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9619     var = build_decl (VAR_DECL, var, item);
9620     TREE_STATIC (var) = 1;
9621     DECL_INITIAL (var) = error_mark_node;
9622     var = start_decl (var, FALSE);
9623     finish_decl (var, list, FALSE);
9624
9625     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9626
9627     return var;
9628   }
9629 }
9630
9631 #endif
9632 /* Essentially does a "fold (build1 (code, type, node))" while checking
9633    for certain housekeeping things.
9634
9635    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9636    ffecom_1_fn instead.  */
9637
9638 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9639 tree
9640 ffecom_1 (enum tree_code code, tree type, tree node)
9641 {
9642   tree item;
9643
9644   if ((node == error_mark_node)
9645       || (type == error_mark_node))
9646     return error_mark_node;
9647
9648   if (code == ADDR_EXPR)
9649     {
9650       if (!mark_addressable (node))
9651         assert ("can't mark_addressable this node!" == NULL);
9652     }
9653
9654   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9655     {
9656       tree realtype;
9657
9658     case REALPART_EXPR:
9659       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9660       break;
9661
9662     case IMAGPART_EXPR:
9663       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9664       break;
9665
9666
9667     case NEGATE_EXPR:
9668       if (TREE_CODE (type) != RECORD_TYPE)
9669         {
9670           item = build1 (code, type, node);
9671           break;
9672         }
9673       node = ffecom_stabilize_aggregate_ (node);
9674       realtype = TREE_TYPE (TYPE_FIELDS (type));
9675       item =
9676         ffecom_2 (COMPLEX_EXPR, type,
9677                   ffecom_1 (NEGATE_EXPR, realtype,
9678                             ffecom_1 (REALPART_EXPR, realtype,
9679                                       node)),
9680                   ffecom_1 (NEGATE_EXPR, realtype,
9681                             ffecom_1 (IMAGPART_EXPR, realtype,
9682                                       node)));
9683       break;
9684
9685     default:
9686       item = build1 (code, type, node);
9687       break;
9688     }
9689
9690   if (TREE_SIDE_EFFECTS (node))
9691     TREE_SIDE_EFFECTS (item) = 1;
9692   if ((code == ADDR_EXPR) && staticp (node))
9693     TREE_CONSTANT (item) = 1;
9694   return fold (item);
9695 }
9696 #endif
9697
9698 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9699    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9700    does not set TREE_ADDRESSABLE (because calling an inline
9701    function does not mean the function needs to be separately
9702    compiled).  */
9703
9704 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9705 tree
9706 ffecom_1_fn (tree node)
9707 {
9708   tree item;
9709   tree type;
9710
9711   if (node == error_mark_node)
9712     return error_mark_node;
9713
9714   type = build_type_variant (TREE_TYPE (node),
9715                              TREE_READONLY (node),
9716                              TREE_THIS_VOLATILE (node));
9717   item = build1 (ADDR_EXPR,
9718                  build_pointer_type (type), node);
9719   if (TREE_SIDE_EFFECTS (node))
9720     TREE_SIDE_EFFECTS (item) = 1;
9721   if (staticp (node))
9722     TREE_CONSTANT (item) = 1;
9723   return fold (item);
9724 }
9725 #endif
9726
9727 /* Essentially does a "fold (build (code, type, node1, node2))" while
9728    checking for certain housekeeping things.  */
9729
9730 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9731 tree
9732 ffecom_2 (enum tree_code code, tree type, tree node1,
9733           tree node2)
9734 {
9735   tree item;
9736
9737   if ((node1 == error_mark_node)
9738       || (node2 == error_mark_node)
9739       || (type == error_mark_node))
9740     return error_mark_node;
9741
9742   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9743     {
9744       tree a, b, c, d, realtype;
9745
9746     case CONJ_EXPR:
9747       assert ("no CONJ_EXPR support yet" == NULL);
9748       return error_mark_node;
9749
9750     case COMPLEX_EXPR:
9751       item = build_tree_list (TYPE_FIELDS (type), node1);
9752       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9753       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9754       break;
9755
9756     case PLUS_EXPR:
9757       if (TREE_CODE (type) != RECORD_TYPE)
9758         {
9759           item = build (code, type, node1, node2);
9760           break;
9761         }
9762       node1 = ffecom_stabilize_aggregate_ (node1);
9763       node2 = ffecom_stabilize_aggregate_ (node2);
9764       realtype = TREE_TYPE (TYPE_FIELDS (type));
9765       item =
9766         ffecom_2 (COMPLEX_EXPR, type,
9767                   ffecom_2 (PLUS_EXPR, realtype,
9768                             ffecom_1 (REALPART_EXPR, realtype,
9769                                       node1),
9770                             ffecom_1 (REALPART_EXPR, realtype,
9771                                       node2)),
9772                   ffecom_2 (PLUS_EXPR, realtype,
9773                             ffecom_1 (IMAGPART_EXPR, realtype,
9774                                       node1),
9775                             ffecom_1 (IMAGPART_EXPR, realtype,
9776                                       node2)));
9777       break;
9778
9779     case MINUS_EXPR:
9780       if (TREE_CODE (type) != RECORD_TYPE)
9781         {
9782           item = build (code, type, node1, node2);
9783           break;
9784         }
9785       node1 = ffecom_stabilize_aggregate_ (node1);
9786       node2 = ffecom_stabilize_aggregate_ (node2);
9787       realtype = TREE_TYPE (TYPE_FIELDS (type));
9788       item =
9789         ffecom_2 (COMPLEX_EXPR, type,
9790                   ffecom_2 (MINUS_EXPR, realtype,
9791                             ffecom_1 (REALPART_EXPR, realtype,
9792                                       node1),
9793                             ffecom_1 (REALPART_EXPR, realtype,
9794                                       node2)),
9795                   ffecom_2 (MINUS_EXPR, realtype,
9796                             ffecom_1 (IMAGPART_EXPR, realtype,
9797                                       node1),
9798                             ffecom_1 (IMAGPART_EXPR, realtype,
9799                                       node2)));
9800       break;
9801
9802     case MULT_EXPR:
9803       if (TREE_CODE (type) != RECORD_TYPE)
9804         {
9805           item = build (code, type, node1, node2);
9806           break;
9807         }
9808       node1 = ffecom_stabilize_aggregate_ (node1);
9809       node2 = ffecom_stabilize_aggregate_ (node2);
9810       realtype = TREE_TYPE (TYPE_FIELDS (type));
9811       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9812                                node1));
9813       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9814                                node1));
9815       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9816                                node2));
9817       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9818                                node2));
9819       item =
9820         ffecom_2 (COMPLEX_EXPR, type,
9821                   ffecom_2 (MINUS_EXPR, realtype,
9822                             ffecom_2 (MULT_EXPR, realtype,
9823                                       a,
9824                                       c),
9825                             ffecom_2 (MULT_EXPR, realtype,
9826                                       b,
9827                                       d)),
9828                   ffecom_2 (PLUS_EXPR, realtype,
9829                             ffecom_2 (MULT_EXPR, realtype,
9830                                       a,
9831                                       d),
9832                             ffecom_2 (MULT_EXPR, realtype,
9833                                       c,
9834                                       b)));
9835       break;
9836
9837     case EQ_EXPR:
9838       if ((TREE_CODE (node1) != RECORD_TYPE)
9839           && (TREE_CODE (node2) != RECORD_TYPE))
9840         {
9841           item = build (code, type, node1, node2);
9842           break;
9843         }
9844       assert (TREE_CODE (node1) == RECORD_TYPE);
9845       assert (TREE_CODE (node2) == RECORD_TYPE);
9846       node1 = ffecom_stabilize_aggregate_ (node1);
9847       node2 = ffecom_stabilize_aggregate_ (node2);
9848       realtype = TREE_TYPE (TYPE_FIELDS (type));
9849       item =
9850         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9851                   ffecom_2 (code, type,
9852                             ffecom_1 (REALPART_EXPR, realtype,
9853                                       node1),
9854                             ffecom_1 (REALPART_EXPR, realtype,
9855                                       node2)),
9856                   ffecom_2 (code, type,
9857                             ffecom_1 (IMAGPART_EXPR, realtype,
9858                                       node1),
9859                             ffecom_1 (IMAGPART_EXPR, realtype,
9860                                       node2)));
9861       break;
9862
9863     case NE_EXPR:
9864       if ((TREE_CODE (node1) != RECORD_TYPE)
9865           && (TREE_CODE (node2) != RECORD_TYPE))
9866         {
9867           item = build (code, type, node1, node2);
9868           break;
9869         }
9870       assert (TREE_CODE (node1) == RECORD_TYPE);
9871       assert (TREE_CODE (node2) == RECORD_TYPE);
9872       node1 = ffecom_stabilize_aggregate_ (node1);
9873       node2 = ffecom_stabilize_aggregate_ (node2);
9874       realtype = TREE_TYPE (TYPE_FIELDS (type));
9875       item =
9876         ffecom_2 (TRUTH_ORIF_EXPR, type,
9877                   ffecom_2 (code, type,
9878                             ffecom_1 (REALPART_EXPR, realtype,
9879                                       node1),
9880                             ffecom_1 (REALPART_EXPR, realtype,
9881                                       node2)),
9882                   ffecom_2 (code, type,
9883                             ffecom_1 (IMAGPART_EXPR, realtype,
9884                                       node1),
9885                             ffecom_1 (IMAGPART_EXPR, realtype,
9886                                       node2)));
9887       break;
9888
9889     default:
9890       item = build (code, type, node1, node2);
9891       break;
9892     }
9893
9894   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9895     TREE_SIDE_EFFECTS (item) = 1;
9896   return fold (item);
9897 }
9898
9899 #endif
9900 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9901
9902    ffesymbol s;  // the ENTRY point itself
9903    if (ffecom_2pass_advise_entrypoint(s))
9904        // the ENTRY point has been accepted
9905
9906    Does whatever compiler needs to do when it learns about the entrypoint,
9907    like determine the return type of the master function, count the
9908    number of entrypoints, etc.  Returns FALSE if the return type is
9909    not compatible with the return type(s) of other entrypoint(s).
9910
9911    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9912    later (after _finish_progunit) be called with the same entrypoint(s)
9913    as passed to this fn for which TRUE was returned.
9914
9915    03-Jan-92  JCB  2.0
9916       Return FALSE if the return type conflicts with previous entrypoints.  */
9917
9918 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9919 bool
9920 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9921 {
9922   ffebld list;                  /* opITEM. */
9923   ffebld mlist;                 /* opITEM. */
9924   ffebld plist;                 /* opITEM. */
9925   ffebld arg;                   /* ffebld_head(opITEM). */
9926   ffebld item;                  /* opITEM. */
9927   ffesymbol s;                  /* ffebld_symter(arg). */
9928   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9929   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9930   ffetargetCharacterSize size = ffesymbol_size (entry);
9931   bool ok;
9932
9933   if (ffecom_num_entrypoints_ == 0)
9934     {                           /* First entrypoint, make list of main
9935                                    arglist's dummies. */
9936       assert (ffecom_primary_entry_ != NULL);
9937
9938       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9939       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9940       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9941
9942       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9943            list != NULL;
9944            list = ffebld_trail (list))
9945         {
9946           arg = ffebld_head (list);
9947           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9948             continue;           /* Alternate return or some such thing. */
9949           item = ffebld_new_item (arg, NULL);
9950           if (plist == NULL)
9951             ffecom_master_arglist_ = item;
9952           else
9953             ffebld_set_trail (plist, item);
9954           plist = item;
9955         }
9956     }
9957
9958   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9959      apparently redundantly (it's done below to UNIONize the arglists) so
9960      that we don't complain about RETURN 1 if an offending ENTRY is the only
9961      one with an alternate return.  */
9962
9963   if (!ffecom_is_altreturning_)
9964     {
9965       for (list = ffesymbol_dummyargs (entry);
9966            list != NULL;
9967            list = ffebld_trail (list))
9968         {
9969           arg = ffebld_head (list);
9970           if (ffebld_op (arg) == FFEBLD_opSTAR)
9971             {
9972               ffecom_is_altreturning_ = TRUE;
9973               break;
9974             }
9975         }
9976     }
9977
9978   /* Now check type compatibility. */
9979
9980   switch (ffecom_master_bt_)
9981     {
9982     case FFEINFO_basictypeNONE:
9983       ok = (bt != FFEINFO_basictypeCHARACTER);
9984       break;
9985
9986     case FFEINFO_basictypeCHARACTER:
9987       ok
9988         = (bt == FFEINFO_basictypeCHARACTER)
9989         && (kt == ffecom_master_kt_)
9990         && (size == ffecom_master_size_);
9991       break;
9992
9993     case FFEINFO_basictypeANY:
9994       return FALSE;             /* Just don't bother. */
9995
9996     default:
9997       if (bt == FFEINFO_basictypeCHARACTER)
9998         {
9999           ok = FALSE;
10000           break;
10001         }
10002       ok = TRUE;
10003       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10004         {
10005           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10006           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10007         }
10008       break;
10009     }
10010
10011   if (!ok)
10012     {
10013       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10014       ffest_ffebad_here_current_stmt (0);
10015       ffebad_finish ();
10016       return FALSE;             /* Can't handle entrypoint. */
10017     }
10018
10019   /* Entrypoint type compatible with previous types. */
10020
10021   ++ffecom_num_entrypoints_;
10022
10023   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10024
10025   for (list = ffesymbol_dummyargs (entry);
10026        list != NULL;
10027        list = ffebld_trail (list))
10028     {
10029       arg = ffebld_head (list);
10030       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10031         continue;               /* Alternate return or some such thing. */
10032       s = ffebld_symter (arg);
10033       for (plist = NULL, mlist = ffecom_master_arglist_;
10034            mlist != NULL;
10035            plist = mlist, mlist = ffebld_trail (mlist))
10036         {                       /* plist points to previous item for easy
10037                                    appending of arg. */
10038           if (ffebld_symter (ffebld_head (mlist)) == s)
10039             break;              /* Already have this arg in the master list. */
10040         }
10041       if (mlist != NULL)
10042         continue;               /* Already have this arg in the master list. */
10043
10044       /* Append this arg to the master list. */
10045
10046       item = ffebld_new_item (arg, NULL);
10047       if (plist == NULL)
10048         ffecom_master_arglist_ = item;
10049       else
10050         ffebld_set_trail (plist, item);
10051     }
10052
10053   return TRUE;
10054 }
10055
10056 #endif
10057 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10058
10059    ffesymbol s;  // the ENTRY point itself
10060    ffecom_2pass_do_entrypoint(s);
10061
10062    Does whatever compiler needs to do to make the entrypoint actually
10063    happen.  Must be called for each entrypoint after
10064    ffecom_finish_progunit is called.  */
10065
10066 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10067 void
10068 ffecom_2pass_do_entrypoint (ffesymbol entry)
10069 {
10070   static int mfn_num = 0;
10071   static int ent_num;
10072
10073   if (mfn_num != ffecom_num_fns_)
10074     {                           /* First entrypoint for this program unit. */
10075       ent_num = 1;
10076       mfn_num = ffecom_num_fns_;
10077       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10078     }
10079   else
10080     ++ent_num;
10081
10082   --ffecom_num_entrypoints_;
10083
10084   ffecom_do_entry_ (entry, ent_num);
10085 }
10086
10087 #endif
10088
10089 /* Essentially does a "fold (build (code, type, node1, node2))" while
10090    checking for certain housekeeping things.  Always sets
10091    TREE_SIDE_EFFECTS.  */
10092
10093 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10094 tree
10095 ffecom_2s (enum tree_code code, tree type, tree node1,
10096            tree node2)
10097 {
10098   tree item;
10099
10100   if ((node1 == error_mark_node)
10101       || (node2 == error_mark_node)
10102       || (type == error_mark_node))
10103     return error_mark_node;
10104
10105   item = build (code, type, node1, node2);
10106   TREE_SIDE_EFFECTS (item) = 1;
10107   return fold (item);
10108 }
10109
10110 #endif
10111 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10112    checking for certain housekeeping things.  */
10113
10114 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10115 tree
10116 ffecom_3 (enum tree_code code, tree type, tree node1,
10117           tree node2, tree node3)
10118 {
10119   tree item;
10120
10121   if ((node1 == error_mark_node)
10122       || (node2 == error_mark_node)
10123       || (node3 == error_mark_node)
10124       || (type == error_mark_node))
10125     return error_mark_node;
10126
10127   item = build (code, type, node1, node2, node3);
10128   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10129       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10130     TREE_SIDE_EFFECTS (item) = 1;
10131   return fold (item);
10132 }
10133
10134 #endif
10135 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10136    checking for certain housekeeping things.  Always sets
10137    TREE_SIDE_EFFECTS.  */
10138
10139 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10140 tree
10141 ffecom_3s (enum tree_code code, tree type, tree node1,
10142            tree node2, tree node3)
10143 {
10144   tree item;
10145
10146   if ((node1 == error_mark_node)
10147       || (node2 == error_mark_node)
10148       || (node3 == error_mark_node)
10149       || (type == error_mark_node))
10150     return error_mark_node;
10151
10152   item = build (code, type, node1, node2, node3);
10153   TREE_SIDE_EFFECTS (item) = 1;
10154   return fold (item);
10155 }
10156
10157 #endif
10158
10159 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10160
10161    See use by ffecom_list_expr.
10162
10163    If expression is NULL, returns an integer zero tree.  If it is not
10164    a CHARACTER expression, returns whatever ffecom_expr
10165    returns and sets the length return value to NULL_TREE.  Otherwise
10166    generates code to evaluate the character expression, returns the proper
10167    pointer to the result, but does NOT set the length return value to a tree
10168    that specifies the length of the result.  (In other words, the length
10169    variable is always set to NULL_TREE, because a length is never passed.)
10170
10171    21-Dec-91  JCB  1.1
10172       Don't set returned length, since nobody needs it (yet; someday if
10173       we allow CHARACTER*(*) dummies to statement functions, we'll need
10174       it).  */
10175
10176 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10177 tree
10178 ffecom_arg_expr (ffebld expr, tree *length)
10179 {
10180   tree ign;
10181
10182   *length = NULL_TREE;
10183
10184   if (expr == NULL)
10185     return integer_zero_node;
10186
10187   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10188     return ffecom_expr (expr);
10189
10190   return ffecom_arg_ptr_to_expr (expr, &ign);
10191 }
10192
10193 #endif
10194 /* Transform expression into constant argument-pointer-to-expression tree.
10195
10196    If the expression can be transformed into a argument-pointer-to-expression
10197    tree that is constant, that is done, and the tree returned.  Else
10198    NULL_TREE is returned.
10199
10200    That way, a caller can attempt to provide compile-time initialization
10201    of a variable and, if that fails, *then* choose to start a new block
10202    and resort to using temporaries, as appropriate.  */
10203
10204 tree
10205 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10206 {
10207   if (! expr)
10208     return integer_zero_node;
10209
10210   if (ffebld_op (expr) == FFEBLD_opANY)
10211     {
10212       if (length)
10213         *length = error_mark_node;
10214       return error_mark_node;
10215     }
10216
10217   if (ffebld_arity (expr) == 0
10218       && (ffebld_op (expr) != FFEBLD_opSYMTER
10219           || ffebld_where (expr) == FFEINFO_whereCOMMON
10220           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10221           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10222     {
10223       tree t;
10224
10225       t = ffecom_arg_ptr_to_expr (expr, length);
10226       assert (TREE_CONSTANT (t));
10227       assert (! length || TREE_CONSTANT (*length));
10228       return t;
10229     }
10230
10231   if (length
10232       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10233     *length = build_int_2 (ffebld_size (expr), 0);
10234   else if (length)
10235     *length = NULL_TREE;
10236   return NULL_TREE;
10237 }
10238
10239 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10240
10241    See use by ffecom_list_ptr_to_expr.
10242
10243    If expression is NULL, returns an integer zero tree.  If it is not
10244    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10245    returns and sets the length return value to NULL_TREE.  Otherwise
10246    generates code to evaluate the character expression, returns the proper
10247    pointer to the result, AND sets the length return value to a tree that
10248    specifies the length of the result.
10249
10250    If the length argument is NULL, this is a slightly special
10251    case of building a FORMAT expression, that is, an expression that
10252    will be used at run time without regard to length.  For the current
10253    implementation, which uses the libf2c library, this means it is nice
10254    to append a null byte to the end of the expression, where feasible,
10255    to make sure any diagnostic about the FORMAT string terminates at
10256    some useful point.
10257
10258    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10259    length argument.  This might even be seen as a feature, if a null
10260    byte can always be appended.  */
10261
10262 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10263 tree
10264 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10265 {
10266   tree item;
10267   tree ign_length;
10268   ffecomConcatList_ catlist;
10269
10270   if (length != NULL)
10271     *length = NULL_TREE;
10272
10273   if (expr == NULL)
10274     return integer_zero_node;
10275
10276   switch (ffebld_op (expr))
10277     {
10278     case FFEBLD_opPERCENT_VAL:
10279       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10280         return ffecom_expr (ffebld_left (expr));
10281       {
10282         tree temp_exp;
10283         tree temp_length;
10284
10285         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10286         if (temp_exp == error_mark_node)
10287           return error_mark_node;
10288
10289         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10290                          temp_exp);
10291       }
10292
10293     case FFEBLD_opPERCENT_REF:
10294       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10295         return ffecom_ptr_to_expr (ffebld_left (expr));
10296       if (length != NULL)
10297         {
10298           ign_length = NULL_TREE;
10299           length = &ign_length;
10300         }
10301       expr = ffebld_left (expr);
10302       break;
10303
10304     case FFEBLD_opPERCENT_DESCR:
10305       switch (ffeinfo_basictype (ffebld_info (expr)))
10306         {
10307 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10308         case FFEINFO_basictypeHOLLERITH:
10309 #endif
10310         case FFEINFO_basictypeCHARACTER:
10311           break;                /* Passed by descriptor anyway. */
10312
10313         default:
10314           item = ffecom_ptr_to_expr (expr);
10315           if (item != error_mark_node)
10316             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10317           break;
10318         }
10319       break;
10320
10321     default:
10322       break;
10323     }
10324
10325 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10326   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10327       && (length != NULL))
10328     {                           /* Pass Hollerith by descriptor. */
10329       ffetargetHollerith h;
10330
10331       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10332       h = ffebld_cu_val_hollerith (ffebld_constant_union
10333                                    (ffebld_conter (expr)));
10334       *length
10335         = build_int_2 (h.length, 0);
10336       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10337     }
10338 #endif
10339
10340   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10341     return ffecom_ptr_to_expr (expr);
10342
10343   assert (ffeinfo_kindtype (ffebld_info (expr))
10344           == FFEINFO_kindtypeCHARACTER1);
10345
10346   while (ffebld_op (expr) == FFEBLD_opPAREN)
10347     expr = ffebld_left (expr);
10348
10349   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10350   switch (ffecom_concat_list_count_ (catlist))
10351     {
10352     case 0:                     /* Shouldn't happen, but in case it does... */
10353       if (length != NULL)
10354         {
10355           *length = ffecom_f2c_ftnlen_zero_node;
10356           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10357         }
10358       ffecom_concat_list_kill_ (catlist);
10359       return null_pointer_node;
10360
10361     case 1:                     /* The (fairly) easy case. */
10362       if (length == NULL)
10363         ffecom_char_args_with_null_ (&item, &ign_length,
10364                                      ffecom_concat_list_expr_ (catlist, 0));
10365       else
10366         ffecom_char_args_ (&item, length,
10367                            ffecom_concat_list_expr_ (catlist, 0));
10368       ffecom_concat_list_kill_ (catlist);
10369       assert (item != NULL_TREE);
10370       return item;
10371
10372     default:                    /* Must actually concatenate things. */
10373       break;
10374     }
10375
10376   {
10377     int count = ffecom_concat_list_count_ (catlist);
10378     int i;
10379     tree lengths;
10380     tree items;
10381     tree length_array;
10382     tree item_array;
10383     tree citem;
10384     tree clength;
10385     tree temporary;
10386     tree num;
10387     tree known_length;
10388     ffetargetCharacterSize sz;
10389
10390     sz = ffecom_concat_list_maxlen_ (catlist);
10391     /* ~~Kludge! */
10392     assert (sz != FFETARGET_charactersizeNONE);
10393
10394 #ifdef HOHO
10395     length_array
10396       = lengths
10397       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10398                              FFETARGET_charactersizeNONE, count, TRUE);
10399     item_array
10400       = items
10401       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10402                              FFETARGET_charactersizeNONE, count, TRUE);
10403     temporary = ffecom_push_tempvar (char_type_node,
10404                                      sz, -1, TRUE);
10405 #else
10406     {
10407       tree hook;
10408
10409       hook = ffebld_nonter_hook (expr);
10410       assert (hook);
10411       assert (TREE_CODE (hook) == TREE_VEC);
10412       assert (TREE_VEC_LENGTH (hook) == 3);
10413       length_array = lengths = TREE_VEC_ELT (hook, 0);
10414       item_array = items = TREE_VEC_ELT (hook, 1);
10415       temporary = TREE_VEC_ELT (hook, 2);
10416     }
10417 #endif
10418
10419     known_length = ffecom_f2c_ftnlen_zero_node;
10420
10421     for (i = 0; i < count; ++i)
10422       {
10423         if ((i == count)
10424             && (length == NULL))
10425           ffecom_char_args_with_null_ (&citem, &clength,
10426                                        ffecom_concat_list_expr_ (catlist, i));
10427         else
10428           ffecom_char_args_ (&citem, &clength,
10429                              ffecom_concat_list_expr_ (catlist, i));
10430         if ((citem == error_mark_node)
10431             || (clength == error_mark_node))
10432           {
10433             ffecom_concat_list_kill_ (catlist);
10434             *length = error_mark_node;
10435             return error_mark_node;
10436           }
10437
10438         items
10439           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10440                       ffecom_modify (void_type_node,
10441                                      ffecom_2 (ARRAY_REF,
10442                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10443                                                item_array,
10444                                                build_int_2 (i, 0)),
10445                                      citem),
10446                       items);
10447         clength = ffecom_save_tree (clength);
10448         if (length != NULL)
10449           known_length
10450             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10451                         known_length,
10452                         clength);
10453         lengths
10454           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10455                       ffecom_modify (void_type_node,
10456                                      ffecom_2 (ARRAY_REF,
10457                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10458                                                length_array,
10459                                                build_int_2 (i, 0)),
10460                                      clength),
10461                       lengths);
10462       }
10463
10464     temporary = ffecom_1 (ADDR_EXPR,
10465                           build_pointer_type (TREE_TYPE (temporary)),
10466                           temporary);
10467
10468     item = build_tree_list (NULL_TREE, temporary);
10469     TREE_CHAIN (item)
10470       = build_tree_list (NULL_TREE,
10471                          ffecom_1 (ADDR_EXPR,
10472                                    build_pointer_type (TREE_TYPE (items)),
10473                                    items));
10474     TREE_CHAIN (TREE_CHAIN (item))
10475       = build_tree_list (NULL_TREE,
10476                          ffecom_1 (ADDR_EXPR,
10477                                    build_pointer_type (TREE_TYPE (lengths)),
10478                                    lengths));
10479     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10480       = build_tree_list
10481         (NULL_TREE,
10482          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10483                    convert (ffecom_f2c_ftnlen_type_node,
10484                             build_int_2 (count, 0))));
10485     num = build_int_2 (sz, 0);
10486     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10487     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10488       = build_tree_list (NULL_TREE, num);
10489
10490     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10491     TREE_SIDE_EFFECTS (item) = 1;
10492     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10493                      item,
10494                      temporary);
10495
10496     if (length != NULL)
10497       *length = known_length;
10498   }
10499
10500   ffecom_concat_list_kill_ (catlist);
10501   assert (item != NULL_TREE);
10502   return item;
10503 }
10504
10505 #endif
10506 /* Generate call to run-time function.
10507
10508    The first arg is the GNU Fortran Run-Time function index, the second
10509    arg is the list of arguments to pass to it.  Returned is the expression
10510    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10511    result (which may be void).  */
10512
10513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10514 tree
10515 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10516 {
10517   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10518                        ffecom_gfrt_kindtype (ix),
10519                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10520                        NULL_TREE, args, NULL_TREE, NULL,
10521                        NULL, NULL_TREE, TRUE, hook);
10522 }
10523 #endif
10524
10525 /* Transform constant-union to tree.  */
10526
10527 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10528 tree
10529 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10530                       ffeinfoKindtype kt, tree tree_type)
10531 {
10532   tree item;
10533
10534   switch (bt)
10535     {
10536     case FFEINFO_basictypeINTEGER:
10537       {
10538         int val;
10539
10540         switch (kt)
10541           {
10542 #if FFETARGET_okINTEGER1
10543           case FFEINFO_kindtypeINTEGER1:
10544             val = ffebld_cu_val_integer1 (*cu);
10545             break;
10546 #endif
10547
10548 #if FFETARGET_okINTEGER2
10549           case FFEINFO_kindtypeINTEGER2:
10550             val = ffebld_cu_val_integer2 (*cu);
10551             break;
10552 #endif
10553
10554 #if FFETARGET_okINTEGER3
10555           case FFEINFO_kindtypeINTEGER3:
10556             val = ffebld_cu_val_integer3 (*cu);
10557             break;
10558 #endif
10559
10560 #if FFETARGET_okINTEGER4
10561           case FFEINFO_kindtypeINTEGER4:
10562             val = ffebld_cu_val_integer4 (*cu);
10563             break;
10564 #endif
10565
10566           default:
10567             assert ("bad INTEGER constant kind type" == NULL);
10568             /* Fall through. */
10569           case FFEINFO_kindtypeANY:
10570             return error_mark_node;
10571           }
10572         item = build_int_2 (val, (val < 0) ? -1 : 0);
10573         TREE_TYPE (item) = tree_type;
10574       }
10575       break;
10576
10577     case FFEINFO_basictypeLOGICAL:
10578       {
10579         int val;
10580
10581         switch (kt)
10582           {
10583 #if FFETARGET_okLOGICAL1
10584           case FFEINFO_kindtypeLOGICAL1:
10585             val = ffebld_cu_val_logical1 (*cu);
10586             break;
10587 #endif
10588
10589 #if FFETARGET_okLOGICAL2
10590           case FFEINFO_kindtypeLOGICAL2:
10591             val = ffebld_cu_val_logical2 (*cu);
10592             break;
10593 #endif
10594
10595 #if FFETARGET_okLOGICAL3
10596           case FFEINFO_kindtypeLOGICAL3:
10597             val = ffebld_cu_val_logical3 (*cu);
10598             break;
10599 #endif
10600
10601 #if FFETARGET_okLOGICAL4
10602           case FFEINFO_kindtypeLOGICAL4:
10603             val = ffebld_cu_val_logical4 (*cu);
10604             break;
10605 #endif
10606
10607           default:
10608             assert ("bad LOGICAL constant kind type" == NULL);
10609             /* Fall through. */
10610           case FFEINFO_kindtypeANY:
10611             return error_mark_node;
10612           }
10613         item = build_int_2 (val, (val < 0) ? -1 : 0);
10614         TREE_TYPE (item) = tree_type;
10615       }
10616       break;
10617
10618     case FFEINFO_basictypeREAL:
10619       {
10620         REAL_VALUE_TYPE val;
10621
10622         switch (kt)
10623           {
10624 #if FFETARGET_okREAL1
10625           case FFEINFO_kindtypeREAL1:
10626             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10627             break;
10628 #endif
10629
10630 #if FFETARGET_okREAL2
10631           case FFEINFO_kindtypeREAL2:
10632             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10633             break;
10634 #endif
10635
10636 #if FFETARGET_okREAL3
10637           case FFEINFO_kindtypeREAL3:
10638             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10639             break;
10640 #endif
10641
10642 #if FFETARGET_okREAL4
10643           case FFEINFO_kindtypeREAL4:
10644             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10645             break;
10646 #endif
10647
10648           default:
10649             assert ("bad REAL constant kind type" == NULL);
10650             /* Fall through. */
10651           case FFEINFO_kindtypeANY:
10652             return error_mark_node;
10653           }
10654         item = build_real (tree_type, val);
10655       }
10656       break;
10657
10658     case FFEINFO_basictypeCOMPLEX:
10659       {
10660         REAL_VALUE_TYPE real;
10661         REAL_VALUE_TYPE imag;
10662         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10663
10664         switch (kt)
10665           {
10666 #if FFETARGET_okCOMPLEX1
10667           case FFEINFO_kindtypeREAL1:
10668             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10669             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10670             break;
10671 #endif
10672
10673 #if FFETARGET_okCOMPLEX2
10674           case FFEINFO_kindtypeREAL2:
10675             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10676             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10677             break;
10678 #endif
10679
10680 #if FFETARGET_okCOMPLEX3
10681           case FFEINFO_kindtypeREAL3:
10682             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10683             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10684             break;
10685 #endif
10686
10687 #if FFETARGET_okCOMPLEX4
10688           case FFEINFO_kindtypeREAL4:
10689             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10690             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10691             break;
10692 #endif
10693
10694           default:
10695             assert ("bad REAL constant kind type" == NULL);
10696             /* Fall through. */
10697           case FFEINFO_kindtypeANY:
10698             return error_mark_node;
10699           }
10700         item = ffecom_build_complex_constant_ (tree_type,
10701                                                build_real (el_type, real),
10702                                                build_real (el_type, imag));
10703       }
10704       break;
10705
10706     case FFEINFO_basictypeCHARACTER:
10707       {                         /* Happens only in DATA and similar contexts. */
10708         ffetargetCharacter1 val;
10709
10710         switch (kt)
10711           {
10712 #if FFETARGET_okCHARACTER1
10713           case FFEINFO_kindtypeLOGICAL1:
10714             val = ffebld_cu_val_character1 (*cu);
10715             break;
10716 #endif
10717
10718           default:
10719             assert ("bad CHARACTER constant kind type" == NULL);
10720             /* Fall through. */
10721           case FFEINFO_kindtypeANY:
10722             return error_mark_node;
10723           }
10724         item = build_string (ffetarget_length_character1 (val),
10725                              ffetarget_text_character1 (val));
10726         TREE_TYPE (item)
10727           = build_type_variant (build_array_type (char_type_node,
10728                                                   build_range_type
10729                                                   (integer_type_node,
10730                                                    integer_one_node,
10731                                                    build_int_2
10732                                                 (ffetarget_length_character1
10733                                                  (val), 0))),
10734                                 1, 0);
10735       }
10736       break;
10737
10738     case FFEINFO_basictypeHOLLERITH:
10739       {
10740         ffetargetHollerith h;
10741
10742         h = ffebld_cu_val_hollerith (*cu);
10743
10744         /* If not at least as wide as default INTEGER, widen it.  */
10745         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10746           item = build_string (h.length, h.text);
10747         else
10748           {
10749             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10750
10751             memcpy (str, h.text, h.length);
10752             memset (&str[h.length], ' ',
10753                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10754                     - h.length);
10755             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10756                                  str);
10757           }
10758         TREE_TYPE (item)
10759           = build_type_variant (build_array_type (char_type_node,
10760                                                   build_range_type
10761                                                   (integer_type_node,
10762                                                    integer_one_node,
10763                                                    build_int_2
10764                                                    (h.length, 0))),
10765                                 1, 0);
10766       }
10767       break;
10768
10769     case FFEINFO_basictypeTYPELESS:
10770       {
10771         ffetargetInteger1 ival;
10772         ffetargetTypeless tless;
10773         ffebad error;
10774
10775         tless = ffebld_cu_val_typeless (*cu);
10776         error = ffetarget_convert_integer1_typeless (&ival, tless);
10777         assert (error == FFEBAD);
10778
10779         item = build_int_2 ((int) ival, 0);
10780       }
10781       break;
10782
10783     default:
10784       assert ("not yet on constant type" == NULL);
10785       /* Fall through. */
10786     case FFEINFO_basictypeANY:
10787       return error_mark_node;
10788     }
10789
10790   TREE_CONSTANT (item) = 1;
10791
10792   return item;
10793 }
10794
10795 #endif
10796
10797 /* Transform expression into constant tree.
10798
10799    If the expression can be transformed into a tree that is constant,
10800    that is done, and the tree returned.  Else NULL_TREE is returned.
10801
10802    That way, a caller can attempt to provide compile-time initialization
10803    of a variable and, if that fails, *then* choose to start a new block
10804    and resort to using temporaries, as appropriate.  */
10805
10806 tree
10807 ffecom_const_expr (ffebld expr)
10808 {
10809   if (! expr)
10810     return integer_zero_node;
10811
10812   if (ffebld_op (expr) == FFEBLD_opANY)
10813     return error_mark_node;
10814
10815   if (ffebld_arity (expr) == 0
10816       && (ffebld_op (expr) != FFEBLD_opSYMTER
10817 #if NEWCOMMON
10818           /* ~~Enable once common/equivalence is handled properly?  */
10819           || ffebld_where (expr) == FFEINFO_whereCOMMON
10820 #endif
10821           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10822           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10823     {
10824       tree t;
10825
10826       t = ffecom_expr (expr);
10827       assert (TREE_CONSTANT (t));
10828       return t;
10829     }
10830
10831   return NULL_TREE;
10832 }
10833
10834 /* Handy way to make a field in a struct/union.  */
10835
10836 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10837 tree
10838 ffecom_decl_field (tree context, tree prevfield,
10839                    const char *name, tree type)
10840 {
10841   tree field;
10842
10843   field = build_decl (FIELD_DECL, get_identifier (name), type);
10844   DECL_CONTEXT (field) = context;
10845   DECL_ALIGN (field) = 0;
10846   DECL_USER_ALIGN (field) = 0;
10847   if (prevfield != NULL_TREE)
10848     TREE_CHAIN (prevfield) = field;
10849
10850   return field;
10851 }
10852
10853 #endif
10854
10855 void
10856 ffecom_close_include (FILE *f)
10857 {
10858 #if FFECOM_GCC_INCLUDE
10859   ffecom_close_include_ (f);
10860 #endif
10861 }
10862
10863 int
10864 ffecom_decode_include_option (char *spec)
10865 {
10866 #if FFECOM_GCC_INCLUDE
10867   return ffecom_decode_include_option_ (spec);
10868 #else
10869   return 1;
10870 #endif
10871 }
10872
10873 /* End a compound statement (block).  */
10874
10875 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10876 tree
10877 ffecom_end_compstmt (void)
10878 {
10879   return bison_rule_compstmt_ ();
10880 }
10881 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10882
10883 /* ffecom_end_transition -- Perform end transition on all symbols
10884
10885    ffecom_end_transition();
10886
10887    Calls ffecom_sym_end_transition for each global and local symbol.  */
10888
10889 void
10890 ffecom_end_transition ()
10891 {
10892 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10893   ffebld item;
10894 #endif
10895
10896   if (ffe_is_ffedebug ())
10897     fprintf (dmpout, "; end_stmt_transition\n");
10898
10899 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10900   ffecom_list_blockdata_ = NULL;
10901   ffecom_list_common_ = NULL;
10902 #endif
10903
10904   ffesymbol_drive (ffecom_sym_end_transition);
10905   if (ffe_is_ffedebug ())
10906     {
10907       ffestorag_report ();
10908 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10909       ffesymbol_report_all ();
10910 #endif
10911     }
10912
10913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10914   ffecom_start_progunit_ ();
10915
10916   for (item = ffecom_list_blockdata_;
10917        item != NULL;
10918        item = ffebld_trail (item))
10919     {
10920       ffebld callee;
10921       ffesymbol s;
10922       tree dt;
10923       tree t;
10924       tree var;
10925       static int number = 0;
10926
10927       callee = ffebld_head (item);
10928       s = ffebld_symter (callee);
10929       t = ffesymbol_hook (s).decl_tree;
10930       if (t == NULL_TREE)
10931         {
10932           s = ffecom_sym_transform_ (s);
10933           t = ffesymbol_hook (s).decl_tree;
10934         }
10935
10936       dt = build_pointer_type (TREE_TYPE (t));
10937
10938       var = build_decl (VAR_DECL,
10939                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10940                                                         number++),
10941                         dt);
10942       DECL_EXTERNAL (var) = 0;
10943       TREE_STATIC (var) = 1;
10944       TREE_PUBLIC (var) = 0;
10945       DECL_INITIAL (var) = error_mark_node;
10946       TREE_USED (var) = 1;
10947
10948       var = start_decl (var, FALSE);
10949
10950       t = ffecom_1 (ADDR_EXPR, dt, t);
10951
10952       finish_decl (var, t, FALSE);
10953     }
10954
10955   /* This handles any COMMON areas that weren't referenced but have, for
10956      example, important initial data.  */
10957
10958   for (item = ffecom_list_common_;
10959        item != NULL;
10960        item = ffebld_trail (item))
10961     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10962
10963   ffecom_list_common_ = NULL;
10964 #endif
10965 }
10966
10967 /* ffecom_exec_transition -- Perform exec transition on all symbols
10968
10969    ffecom_exec_transition();
10970
10971    Calls ffecom_sym_exec_transition for each global and local symbol.
10972    Make sure error updating not inhibited.  */
10973
10974 void
10975 ffecom_exec_transition ()
10976 {
10977   bool inhibited;
10978
10979   if (ffe_is_ffedebug ())
10980     fprintf (dmpout, "; exec_stmt_transition\n");
10981
10982   inhibited = ffebad_inhibit ();
10983   ffebad_set_inhibit (FALSE);
10984
10985   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10986   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10987   if (ffe_is_ffedebug ())
10988     {
10989       ffestorag_report ();
10990 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10991       ffesymbol_report_all ();
10992 #endif
10993     }
10994
10995   if (inhibited)
10996     ffebad_set_inhibit (TRUE);
10997 }
10998
10999 /* Handle assignment statement.
11000
11001    Convert dest and source using ffecom_expr, then join them
11002    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11003
11004 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11005 void
11006 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11007 {
11008   tree dest_tree;
11009   tree dest_length;
11010   tree source_tree;
11011   tree expr_tree;
11012
11013   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11014     {
11015       bool dest_used;
11016       tree assign_temp;
11017
11018       /* This attempts to replicate the test below, but must not be
11019          true when the test below is false.  (Always err on the side
11020          of creating unused temporaries, to avoid ICEs.)  */
11021       if (ffebld_op (dest) != FFEBLD_opSYMTER
11022           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11023               && (TREE_CODE (dest_tree) != VAR_DECL
11024                   || TREE_ADDRESSABLE (dest_tree))))
11025         {
11026           ffecom_prepare_expr_ (source, dest);
11027           dest_used = TRUE;
11028         }
11029       else
11030         {
11031           ffecom_prepare_expr_ (source, NULL);
11032           dest_used = FALSE;
11033         }
11034
11035       ffecom_prepare_expr_w (NULL_TREE, dest);
11036
11037       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11038          create a temporary through which the assignment is to take place,
11039          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11040       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11041           && ffecom_possible_partial_overlap_ (dest, source))
11042         {
11043           assign_temp = ffecom_make_tempvar ("complex_let",
11044                                              ffecom_tree_type
11045                                              [ffebld_basictype (dest)]
11046                                              [ffebld_kindtype (dest)],
11047                                              FFETARGET_charactersizeNONE,
11048                                              -1);
11049         }
11050       else
11051         assign_temp = NULL_TREE;
11052
11053       ffecom_prepare_end ();
11054
11055       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11056       if (dest_tree == error_mark_node)
11057         return;
11058
11059       if ((TREE_CODE (dest_tree) != VAR_DECL)
11060           || TREE_ADDRESSABLE (dest_tree))
11061         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11062                                     FALSE, FALSE);
11063       else
11064         {
11065           assert (! dest_used);
11066           dest_used = FALSE;
11067           source_tree = ffecom_expr (source);
11068         }
11069       if (source_tree == error_mark_node)
11070         return;
11071
11072       if (dest_used)
11073         expr_tree = source_tree;
11074       else if (assign_temp)
11075         {
11076 #ifdef MOVE_EXPR
11077           /* The back end understands a conceptual move (evaluate source;
11078              store into dest), so use that, in case it can determine
11079              that it is going to use, say, two registers as temporaries
11080              anyway.  So don't use the temp (and someday avoid generating
11081              it, once this code starts triggering regularly).  */
11082           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11083                                  dest_tree,
11084                                  source_tree);
11085 #else
11086           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11087                                  assign_temp,
11088                                  source_tree);
11089           expand_expr_stmt (expr_tree);
11090           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11091                                  dest_tree,
11092                                  assign_temp);
11093 #endif
11094         }
11095       else
11096         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11097                                dest_tree,
11098                                source_tree);
11099
11100       expand_expr_stmt (expr_tree);
11101       return;
11102     }
11103
11104   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11105   ffecom_prepare_expr_w (NULL_TREE, dest);
11106
11107   ffecom_prepare_end ();
11108
11109   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11110   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11111                     source);
11112 }
11113
11114 #endif
11115 /* ffecom_expr -- Transform expr into gcc tree
11116
11117    tree t;
11118    ffebld expr;  // FFE expression.
11119    tree = ffecom_expr(expr);
11120
11121    Recursive descent on expr while making corresponding tree nodes and
11122    attaching type info and such.  */
11123
11124 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11125 tree
11126 ffecom_expr (ffebld expr)
11127 {
11128   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11129 }
11130
11131 #endif
11132 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11133
11134 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11135 tree
11136 ffecom_expr_assign (ffebld expr)
11137 {
11138   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11139 }
11140
11141 #endif
11142 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11143
11144 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11145 tree
11146 ffecom_expr_assign_w (ffebld expr)
11147 {
11148   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11149 }
11150
11151 #endif
11152 /* Transform expr for use as into read/write tree and stabilize the
11153    reference.  Not for use on CHARACTER expressions.
11154
11155    Recursive descent on expr while making corresponding tree nodes and
11156    attaching type info and such.  */
11157
11158 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11159 tree
11160 ffecom_expr_rw (tree type, ffebld expr)
11161 {
11162   assert (expr != NULL);
11163   /* Different target types not yet supported.  */
11164   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11165
11166   return stabilize_reference (ffecom_expr (expr));
11167 }
11168
11169 #endif
11170 /* Transform expr for use as into write tree and stabilize the
11171    reference.  Not for use on CHARACTER expressions.
11172
11173    Recursive descent on expr while making corresponding tree nodes and
11174    attaching type info and such.  */
11175
11176 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11177 tree
11178 ffecom_expr_w (tree type, ffebld expr)
11179 {
11180   assert (expr != NULL);
11181   /* Different target types not yet supported.  */
11182   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11183
11184   return stabilize_reference (ffecom_expr (expr));
11185 }
11186
11187 #endif
11188 /* Do global stuff.  */
11189
11190 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11191 void
11192 ffecom_finish_compile ()
11193 {
11194   assert (ffecom_outer_function_decl_ == NULL_TREE);
11195   assert (current_function_decl == NULL_TREE);
11196
11197   ffeglobal_drive (ffecom_finish_global_);
11198 }
11199
11200 #endif
11201 /* Public entry point for front end to access finish_decl.  */
11202
11203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11204 void
11205 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11206 {
11207   assert (!is_top_level);
11208   finish_decl (decl, init, FALSE);
11209 }
11210
11211 #endif
11212 /* Finish a program unit.  */
11213
11214 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11215 void
11216 ffecom_finish_progunit ()
11217 {
11218   ffecom_end_compstmt ();
11219
11220   ffecom_previous_function_decl_ = current_function_decl;
11221   ffecom_which_entrypoint_decl_ = NULL_TREE;
11222
11223   finish_function (0);
11224 }
11225
11226 #endif
11227
11228 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11229
11230 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11231 tree
11232 ffecom_get_invented_identifier (const char *pattern, ...)
11233 {
11234   tree decl;
11235   char *nam;
11236   va_list ap;
11237
11238   va_start (ap, pattern);
11239   if (vasprintf (&nam, pattern, ap) == 0)
11240     abort ();
11241   va_end (ap);
11242   decl = get_identifier (nam);
11243   free (nam);
11244   IDENTIFIER_INVENTED (decl) = 1;
11245   return decl;
11246 }
11247
11248 ffeinfoBasictype
11249 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11250 {
11251   assert (gfrt < FFECOM_gfrt);
11252
11253   switch (ffecom_gfrt_type_[gfrt])
11254     {
11255     case FFECOM_rttypeVOID_:
11256     case FFECOM_rttypeVOIDSTAR_:
11257       return FFEINFO_basictypeNONE;
11258
11259     case FFECOM_rttypeFTNINT_:
11260       return FFEINFO_basictypeINTEGER;
11261
11262     case FFECOM_rttypeINTEGER_:
11263       return FFEINFO_basictypeINTEGER;
11264
11265     case FFECOM_rttypeLONGINT_:
11266       return FFEINFO_basictypeINTEGER;
11267
11268     case FFECOM_rttypeLOGICAL_:
11269       return FFEINFO_basictypeLOGICAL;
11270
11271     case FFECOM_rttypeREAL_F2C_:
11272     case FFECOM_rttypeREAL_GNU_:
11273       return FFEINFO_basictypeREAL;
11274
11275     case FFECOM_rttypeCOMPLEX_F2C_:
11276     case FFECOM_rttypeCOMPLEX_GNU_:
11277       return FFEINFO_basictypeCOMPLEX;
11278
11279     case FFECOM_rttypeDOUBLE_:
11280     case FFECOM_rttypeDOUBLEREAL_:
11281       return FFEINFO_basictypeREAL;
11282
11283     case FFECOM_rttypeDBLCMPLX_F2C_:
11284     case FFECOM_rttypeDBLCMPLX_GNU_:
11285       return FFEINFO_basictypeCOMPLEX;
11286
11287     case FFECOM_rttypeCHARACTER_:
11288       return FFEINFO_basictypeCHARACTER;
11289
11290     default:
11291       return FFEINFO_basictypeANY;
11292     }
11293 }
11294
11295 ffeinfoKindtype
11296 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11297 {
11298   assert (gfrt < FFECOM_gfrt);
11299
11300   switch (ffecom_gfrt_type_[gfrt])
11301     {
11302     case FFECOM_rttypeVOID_:
11303     case FFECOM_rttypeVOIDSTAR_:
11304       return FFEINFO_kindtypeNONE;
11305
11306     case FFECOM_rttypeFTNINT_:
11307       return FFEINFO_kindtypeINTEGER1;
11308
11309     case FFECOM_rttypeINTEGER_:
11310       return FFEINFO_kindtypeINTEGER1;
11311
11312     case FFECOM_rttypeLONGINT_:
11313       return FFEINFO_kindtypeINTEGER4;
11314
11315     case FFECOM_rttypeLOGICAL_:
11316       return FFEINFO_kindtypeLOGICAL1;
11317
11318     case FFECOM_rttypeREAL_F2C_:
11319     case FFECOM_rttypeREAL_GNU_:
11320       return FFEINFO_kindtypeREAL1;
11321
11322     case FFECOM_rttypeCOMPLEX_F2C_:
11323     case FFECOM_rttypeCOMPLEX_GNU_:
11324       return FFEINFO_kindtypeREAL1;
11325
11326     case FFECOM_rttypeDOUBLE_:
11327     case FFECOM_rttypeDOUBLEREAL_:
11328       return FFEINFO_kindtypeREAL2;
11329
11330     case FFECOM_rttypeDBLCMPLX_F2C_:
11331     case FFECOM_rttypeDBLCMPLX_GNU_:
11332       return FFEINFO_kindtypeREAL2;
11333
11334     case FFECOM_rttypeCHARACTER_:
11335       return FFEINFO_kindtypeCHARACTER1;
11336
11337     default:
11338       return FFEINFO_kindtypeANY;
11339     }
11340 }
11341
11342 void
11343 ffecom_init_0 ()
11344 {
11345   tree endlink;
11346   int i;
11347   int j;
11348   tree t;
11349   tree field;
11350   ffetype type;
11351   ffetype base_type;
11352   tree double_ftype_double;
11353   tree float_ftype_float;
11354   tree ldouble_ftype_ldouble;
11355   tree ffecom_tree_ptr_to_fun_type_void;
11356
11357   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11358      whether the compiler environment is buggy in known ways, some of which
11359      would, if not explicitly checked here, result in subtle bugs in g77.  */
11360
11361   if (ffe_is_do_internal_checks ())
11362     {
11363       static char names[][12]
11364         =
11365       {"bar", "bletch", "foo", "foobar"};
11366       char *name;
11367       unsigned long ul;
11368       double fl;
11369
11370       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11371                       (int (*)(const void *, const void *)) strcmp);
11372       if (name != (char *) &names[2])
11373         {
11374           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11375                   == NULL);
11376           abort ();
11377         }
11378
11379       ul = strtoul ("123456789", NULL, 10);
11380       if (ul != 123456789L)
11381         {
11382           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11383  in proj.h" == NULL);
11384           abort ();
11385         }
11386
11387       fl = atof ("56.789");
11388       if ((fl < 56.788) || (fl > 56.79))
11389         {
11390           assert ("atof not type double, fix your #include <stdio.h>"
11391                   == NULL);
11392           abort ();
11393         }
11394     }
11395
11396 #if FFECOM_GCC_INCLUDE
11397   ffecom_initialize_char_syntax_ ();
11398 #endif
11399
11400   ffecom_outer_function_decl_ = NULL_TREE;
11401   current_function_decl = NULL_TREE;
11402   named_labels = NULL_TREE;
11403   current_binding_level = NULL_BINDING_LEVEL;
11404   free_binding_level = NULL_BINDING_LEVEL;
11405   /* Make the binding_level structure for global names.  */
11406   pushlevel (0);
11407   global_binding_level = current_binding_level;
11408   current_binding_level->prep_state = 2;
11409
11410   build_common_tree_nodes (1);
11411
11412   /* Define `int' and `char' first so that dbx will output them first.  */
11413   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11414                         integer_type_node));
11415   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11416   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11417   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11418                         char_type_node));
11419   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11420                         long_integer_type_node));
11421   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11422                         unsigned_type_node));
11423   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11424                         long_unsigned_type_node));
11425   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11426                         long_long_integer_type_node));
11427   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11428                         long_long_unsigned_type_node));
11429   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11430                         short_integer_type_node));
11431   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11432                         short_unsigned_type_node));
11433
11434   /* Set the sizetype before we make other types.  This *should* be the
11435      first type we create.  */
11436
11437   set_sizetype
11438     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11439   ffecom_typesize_pointer_
11440     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11441
11442   build_common_tree_nodes_2 (0);
11443
11444   /* Define both `signed char' and `unsigned char'.  */
11445   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11446                         signed_char_type_node));
11447
11448   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11449                         unsigned_char_type_node));
11450
11451   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11452                         float_type_node));
11453   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11454                         double_type_node));
11455   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11456                         long_double_type_node));
11457
11458   /* For now, override what build_common_tree_nodes has done.  */
11459   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11460   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11461   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11462   complex_long_double_type_node
11463     = ffecom_make_complex_type_ (long_double_type_node);
11464
11465   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11466                         complex_integer_type_node));
11467   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11468                         complex_float_type_node));
11469   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11470                         complex_double_type_node));
11471   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11472                         complex_long_double_type_node));
11473
11474   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11475                         void_type_node));
11476   /* We are not going to have real types in C with less than byte alignment,
11477      so we might as well not have any types that claim to have it.  */
11478   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11479   TYPE_USER_ALIGN (void_type_node) = 0;
11480
11481   string_type_node = build_pointer_type (char_type_node);
11482
11483   ffecom_tree_fun_type_void
11484     = build_function_type (void_type_node, NULL_TREE);
11485
11486   ffecom_tree_ptr_to_fun_type_void
11487     = build_pointer_type (ffecom_tree_fun_type_void);
11488
11489   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11490
11491   float_ftype_float
11492     = build_function_type (float_type_node,
11493                            tree_cons (NULL_TREE, float_type_node, endlink));
11494
11495   double_ftype_double
11496     = build_function_type (double_type_node,
11497                            tree_cons (NULL_TREE, double_type_node, endlink));
11498
11499   ldouble_ftype_ldouble
11500     = build_function_type (long_double_type_node,
11501                            tree_cons (NULL_TREE, long_double_type_node,
11502                                       endlink));
11503
11504   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11505     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11506       {
11507         ffecom_tree_type[i][j] = NULL_TREE;
11508         ffecom_tree_fun_type[i][j] = NULL_TREE;
11509         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11510         ffecom_f2c_typecode_[i][j] = -1;
11511       }
11512
11513   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11514      to size FLOAT_TYPE_SIZE because they have to be the same size as
11515      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11516      Compiler options and other such stuff that change the ways these
11517      types are set should not affect this particular setup.  */
11518
11519   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11520     = t = make_signed_type (FLOAT_TYPE_SIZE);
11521   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11522                         t));
11523   type = ffetype_new ();
11524   base_type = type;
11525   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11526                     type);
11527   ffetype_set_ams (type,
11528                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11529                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11530   ffetype_set_star (base_type,
11531                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11532                     type);
11533   ffetype_set_kind (base_type, 1, type);
11534   ffecom_typesize_integer1_ = ffetype_size (type);
11535   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11536
11537   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11538     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11539   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11540                         t));
11541
11542   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11543     = t = make_signed_type (CHAR_TYPE_SIZE);
11544   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11545                         t));
11546   type = ffetype_new ();
11547   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11548                     type);
11549   ffetype_set_ams (type,
11550                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11551                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11552   ffetype_set_star (base_type,
11553                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11554                     type);
11555   ffetype_set_kind (base_type, 3, type);
11556   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11557
11558   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11559     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11560   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11561                         t));
11562
11563   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11564     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11565   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11566                         t));
11567   type = ffetype_new ();
11568   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11569                     type);
11570   ffetype_set_ams (type,
11571                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11572                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11573   ffetype_set_star (base_type,
11574                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11575                     type);
11576   ffetype_set_kind (base_type, 6, type);
11577   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11578
11579   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11580     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11581   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11582                         t));
11583
11584   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11585     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11586   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11587                         t));
11588   type = ffetype_new ();
11589   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11590                     type);
11591   ffetype_set_ams (type,
11592                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11593                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11594   ffetype_set_star (base_type,
11595                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11596                     type);
11597   ffetype_set_kind (base_type, 2, type);
11598   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11599
11600   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11601     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11602   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11603                         t));
11604
11605 #if 0
11606   if (ffe_is_do_internal_checks ()
11607       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11608       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11609       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11610       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11611     {
11612       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11613                LONG_TYPE_SIZE);
11614     }
11615 #endif
11616
11617   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11618     = t = make_signed_type (FLOAT_TYPE_SIZE);
11619   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11620                         t));
11621   type = ffetype_new ();
11622   base_type = type;
11623   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11624                     type);
11625   ffetype_set_ams (type,
11626                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11627                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11628   ffetype_set_star (base_type,
11629                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11630                     type);
11631   ffetype_set_kind (base_type, 1, type);
11632   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11633
11634   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11635     = t = make_signed_type (CHAR_TYPE_SIZE);
11636   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11637                         t));
11638   type = ffetype_new ();
11639   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11640                     type);
11641   ffetype_set_ams (type,
11642                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11643                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11644   ffetype_set_star (base_type,
11645                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11646                     type);
11647   ffetype_set_kind (base_type, 3, type);
11648   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11649
11650   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11651     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11652   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11653                         t));
11654   type = ffetype_new ();
11655   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11656                     type);
11657   ffetype_set_ams (type,
11658                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11659                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11660   ffetype_set_star (base_type,
11661                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11662                     type);
11663   ffetype_set_kind (base_type, 6, type);
11664   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11665
11666   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11667     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11668   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11669                         t));
11670   type = ffetype_new ();
11671   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11672                     type);
11673   ffetype_set_ams (type,
11674                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11675                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11676   ffetype_set_star (base_type,
11677                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11678                     type);
11679   ffetype_set_kind (base_type, 2, type);
11680   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11681
11682   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11683     = t = make_node (REAL_TYPE);
11684   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11685   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11686                         t));
11687   layout_type (t);
11688   type = ffetype_new ();
11689   base_type = type;
11690   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11691                     type);
11692   ffetype_set_ams (type,
11693                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11694                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11695   ffetype_set_star (base_type,
11696                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11697                     type);
11698   ffetype_set_kind (base_type, 1, type);
11699   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11700     = FFETARGET_f2cTYREAL;
11701   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11702
11703   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11704     = t = make_node (REAL_TYPE);
11705   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11706   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11707                         t));
11708   layout_type (t);
11709   type = ffetype_new ();
11710   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11711                     type);
11712   ffetype_set_ams (type,
11713                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11714                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11715   ffetype_set_star (base_type,
11716                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11717                     type);
11718   ffetype_set_kind (base_type, 2, type);
11719   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11720     = FFETARGET_f2cTYDREAL;
11721   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11722
11723   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11724     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11725   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11726                         t));
11727   type = ffetype_new ();
11728   base_type = type;
11729   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11730                     type);
11731   ffetype_set_ams (type,
11732                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11733                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11734   ffetype_set_star (base_type,
11735                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11736                     type);
11737   ffetype_set_kind (base_type, 1, type);
11738   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11739     = FFETARGET_f2cTYCOMPLEX;
11740   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11741
11742   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11743     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11744   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11745                         t));
11746   type = ffetype_new ();
11747   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11748                     type);
11749   ffetype_set_ams (type,
11750                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11751                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11752   ffetype_set_star (base_type,
11753                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11754                     type);
11755   ffetype_set_kind (base_type, 2,
11756                     type);
11757   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11758     = FFETARGET_f2cTYDCOMPLEX;
11759   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11760
11761   /* Make function and ptr-to-function types for non-CHARACTER types. */
11762
11763   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11764     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11765       {
11766         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11767           {
11768             if (i == FFEINFO_basictypeINTEGER)
11769               {
11770                 /* Figure out the smallest INTEGER type that can hold
11771                    a pointer on this machine. */
11772                 if (GET_MODE_SIZE (TYPE_MODE (t))
11773                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11774                   {
11775                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11776                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11777                             > GET_MODE_SIZE (TYPE_MODE (t))))
11778                       ffecom_pointer_kind_ = j;
11779                   }
11780               }
11781             else if (i == FFEINFO_basictypeCOMPLEX)
11782               t = void_type_node;
11783             /* For f2c compatibility, REAL functions are really
11784                implemented as DOUBLE PRECISION.  */
11785             else if ((i == FFEINFO_basictypeREAL)
11786                      && (j == FFEINFO_kindtypeREAL1))
11787               t = ffecom_tree_type
11788                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11789
11790             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11791                                                                   NULL_TREE);
11792             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11793           }
11794       }
11795
11796   /* Set up pointer types.  */
11797
11798   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11799     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11800   else if (0 && ffe_is_do_internal_checks ())
11801     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11802   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11803                                   FFEINFO_kindtypeINTEGERDEFAULT),
11804                     7,
11805                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11806                                   ffecom_pointer_kind_));
11807
11808   if (ffe_is_ugly_assign ())
11809     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11810   else
11811     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11812   if (0 && ffe_is_do_internal_checks ())
11813     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11814
11815   ffecom_integer_type_node
11816     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11817   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11818                                       integer_zero_node);
11819   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11820                                      integer_one_node);
11821
11822   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11823      Turns out that by TYLONG, runtime/libI77/lio.h really means
11824      "whatever size an ftnint is".  For consistency and sanity,
11825      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11826      all are INTEGER, which we also make out of whatever back-end
11827      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11828      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11829      accommodate machines like the Alpha.  Note that this suggests
11830      f2c and libf2c are missing a distinction perhaps needed on
11831      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11832
11833   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11834                             FFETARGET_f2cTYLONG);
11835   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11836                             FFETARGET_f2cTYSHORT);
11837   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11838                             FFETARGET_f2cTYINT1);
11839   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11840                             FFETARGET_f2cTYQUAD);
11841   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11842                             FFETARGET_f2cTYLOGICAL);
11843   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11844                             FFETARGET_f2cTYLOGICAL2);
11845   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11846                             FFETARGET_f2cTYLOGICAL1);
11847   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11848   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11849                             FFETARGET_f2cTYQUAD);
11850
11851   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11852      loop.  CHARACTER items are built as arrays of unsigned char.  */
11853
11854   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11855     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11856   type = ffetype_new ();
11857   base_type = type;
11858   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11859                     FFEINFO_kindtypeCHARACTER1,
11860                     type);
11861   ffetype_set_ams (type,
11862                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11863                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11864   ffetype_set_kind (base_type, 1, type);
11865   assert (ffetype_size (type)
11866           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11867
11868   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11869     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11870   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11871     [FFEINFO_kindtypeCHARACTER1]
11872     = ffecom_tree_ptr_to_fun_type_void;
11873   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11874     = FFETARGET_f2cTYCHAR;
11875
11876   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11877     = 0;
11878
11879   /* Make multi-return-value type and fields. */
11880
11881   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11882
11883   field = NULL_TREE;
11884
11885   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11886     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11887       {
11888         char name[30];
11889
11890         if (ffecom_tree_type[i][j] == NULL_TREE)
11891           continue;             /* Not supported. */
11892         sprintf (&name[0], "bt_%s_kt_%s",
11893                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11894                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11895         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11896                                                  get_identifier (name),
11897                                                  ffecom_tree_type[i][j]);
11898         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11899           = ffecom_multi_type_node_;
11900         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11901         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11902         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11903         field = ffecom_multi_fields_[i][j];
11904       }
11905
11906   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11907   layout_type (ffecom_multi_type_node_);
11908
11909   /* Subroutines usually return integer because they might have alternate
11910      returns. */
11911
11912   ffecom_tree_subr_type
11913     = build_function_type (integer_type_node, NULL_TREE);
11914   ffecom_tree_ptr_to_subr_type
11915     = build_pointer_type (ffecom_tree_subr_type);
11916   ffecom_tree_blockdata_type
11917     = build_function_type (void_type_node, NULL_TREE);
11918
11919   builtin_function ("__builtin_sqrtf", float_ftype_float,
11920                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11921   builtin_function ("__builtin_fsqrt", double_ftype_double,
11922                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11923   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11924                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11925   builtin_function ("__builtin_sinf", float_ftype_float,
11926                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11927   builtin_function ("__builtin_sin", double_ftype_double,
11928                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11929   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11930                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11931   builtin_function ("__builtin_cosf", float_ftype_float,
11932                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11933   builtin_function ("__builtin_cos", double_ftype_double,
11934                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11935   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11936                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11937
11938 #if BUILT_FOR_270
11939   pedantic_lvalues = FALSE;
11940 #endif
11941
11942   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11943                          FFECOM_f2cINTEGER,
11944                          "integer");
11945   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11946                          FFECOM_f2cADDRESS,
11947                          "address");
11948   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11949                          FFECOM_f2cREAL,
11950                          "real");
11951   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11952                          FFECOM_f2cDOUBLEREAL,
11953                          "doublereal");
11954   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11955                          FFECOM_f2cCOMPLEX,
11956                          "complex");
11957   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11958                          FFECOM_f2cDOUBLECOMPLEX,
11959                          "doublecomplex");
11960   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11961                          FFECOM_f2cLONGINT,
11962                          "longint");
11963   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11964                          FFECOM_f2cLOGICAL,
11965                          "logical");
11966   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11967                          FFECOM_f2cFLAG,
11968                          "flag");
11969   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11970                          FFECOM_f2cFTNLEN,
11971                          "ftnlen");
11972   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11973                          FFECOM_f2cFTNINT,
11974                          "ftnint");
11975
11976   ffecom_f2c_ftnlen_zero_node
11977     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11978
11979   ffecom_f2c_ftnlen_one_node
11980     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11981
11982   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11983   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11984
11985   ffecom_f2c_ptr_to_ftnlen_type_node
11986     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11987
11988   ffecom_f2c_ptr_to_ftnint_type_node
11989     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11990
11991   ffecom_f2c_ptr_to_integer_type_node
11992     = build_pointer_type (ffecom_f2c_integer_type_node);
11993
11994   ffecom_f2c_ptr_to_real_type_node
11995     = build_pointer_type (ffecom_f2c_real_type_node);
11996
11997   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11998   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11999   {
12000     REAL_VALUE_TYPE point_5;
12001
12002 #ifdef REAL_ARITHMETIC
12003     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12004 #else
12005     point_5 = .5;
12006 #endif
12007     ffecom_float_half_ = build_real (float_type_node, point_5);
12008     ffecom_double_half_ = build_real (double_type_node, point_5);
12009   }
12010
12011   /* Do "extern int xargc;".  */
12012
12013   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12014                                    get_identifier ("f__xargc"),
12015                                    integer_type_node);
12016   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12017   TREE_STATIC (ffecom_tree_xargc_) = 1;
12018   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12019   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12020   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12021
12022 #if 0   /* This is being fixed, and seems to be working now. */
12023   if ((FLOAT_TYPE_SIZE != 32)
12024       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12025     {
12026       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12027                (int) FLOAT_TYPE_SIZE);
12028       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12029           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12030       warning ("properly unless they all are 32 bits wide.");
12031       warning ("Please keep this in mind before you report bugs.  g77 should");
12032       warning ("support non-32-bit machines better as of version 0.6.");
12033     }
12034 #endif
12035
12036 #if 0   /* Code in ste.c that would crash has been commented out. */
12037   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12038       < TYPE_PRECISION (string_type_node))
12039     /* I/O will probably crash.  */
12040     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12041              TYPE_PRECISION (string_type_node),
12042              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12043 #endif
12044
12045 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12046   if (TYPE_PRECISION (ffecom_integer_type_node)
12047       < TYPE_PRECISION (string_type_node))
12048     /* ASSIGN 10 TO I will crash.  */
12049     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12050  ASSIGN statement might fail",
12051              TYPE_PRECISION (string_type_node),
12052              TYPE_PRECISION (ffecom_integer_type_node));
12053 #endif
12054 }
12055
12056 #endif
12057 /* ffecom_init_2 -- Initialize
12058
12059    ffecom_init_2();  */
12060
12061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12062 void
12063 ffecom_init_2 ()
12064 {
12065   assert (ffecom_outer_function_decl_ == NULL_TREE);
12066   assert (current_function_decl == NULL_TREE);
12067   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12068
12069   ffecom_master_arglist_ = NULL;
12070   ++ffecom_num_fns_;
12071   ffecom_primary_entry_ = NULL;
12072   ffecom_is_altreturning_ = FALSE;
12073   ffecom_func_result_ = NULL_TREE;
12074   ffecom_multi_retval_ = NULL_TREE;
12075 }
12076
12077 #endif
12078 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12079
12080    tree t;
12081    ffebld expr;  // FFE opITEM list.
12082    tree = ffecom_list_expr(expr);
12083
12084    List of actual args is transformed into corresponding gcc backend list.  */
12085
12086 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12087 tree
12088 ffecom_list_expr (ffebld expr)
12089 {
12090   tree list;
12091   tree *plist = &list;
12092   tree trail = NULL_TREE;       /* Append char length args here. */
12093   tree *ptrail = &trail;
12094   tree length;
12095
12096   while (expr != NULL)
12097     {
12098       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12099
12100       if (texpr == error_mark_node)
12101         return error_mark_node;
12102
12103       *plist = build_tree_list (NULL_TREE, texpr);
12104       plist = &TREE_CHAIN (*plist);
12105       expr = ffebld_trail (expr);
12106       if (length != NULL_TREE)
12107         {
12108           *ptrail = build_tree_list (NULL_TREE, length);
12109           ptrail = &TREE_CHAIN (*ptrail);
12110         }
12111     }
12112
12113   *plist = trail;
12114
12115   return list;
12116 }
12117
12118 #endif
12119 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12120
12121    tree t;
12122    ffebld expr;  // FFE opITEM list.
12123    tree = ffecom_list_ptr_to_expr(expr);
12124
12125    List of actual args is transformed into corresponding gcc backend list for
12126    use in calling an external procedure (vs. a statement function).  */
12127
12128 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12129 tree
12130 ffecom_list_ptr_to_expr (ffebld expr)
12131 {
12132   tree list;
12133   tree *plist = &list;
12134   tree trail = NULL_TREE;       /* Append char length args here. */
12135   tree *ptrail = &trail;
12136   tree length;
12137
12138   while (expr != NULL)
12139     {
12140       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12141
12142       if (texpr == error_mark_node)
12143         return error_mark_node;
12144
12145       *plist = build_tree_list (NULL_TREE, texpr);
12146       plist = &TREE_CHAIN (*plist);
12147       expr = ffebld_trail (expr);
12148       if (length != NULL_TREE)
12149         {
12150           *ptrail = build_tree_list (NULL_TREE, length);
12151           ptrail = &TREE_CHAIN (*ptrail);
12152         }
12153     }
12154
12155   *plist = trail;
12156
12157   return list;
12158 }
12159
12160 #endif
12161 /* Obtain gcc's LABEL_DECL tree for label.  */
12162
12163 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12164 tree
12165 ffecom_lookup_label (ffelab label)
12166 {
12167   tree glabel;
12168
12169   if (ffelab_hook (label) == NULL_TREE)
12170     {
12171       char labelname[16];
12172
12173       switch (ffelab_type (label))
12174         {
12175         case FFELAB_typeLOOPEND:
12176         case FFELAB_typeNOTLOOP:
12177         case FFELAB_typeENDIF:
12178           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12179           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12180                                void_type_node);
12181           DECL_CONTEXT (glabel) = current_function_decl;
12182           DECL_MODE (glabel) = VOIDmode;
12183           break;
12184
12185         case FFELAB_typeFORMAT:
12186           glabel = build_decl (VAR_DECL,
12187                                ffecom_get_invented_identifier
12188                                ("__g77_format_%d", (int) ffelab_value (label)),
12189                                build_type_variant (build_array_type
12190                                                    (char_type_node,
12191                                                     NULL_TREE),
12192                                                    1, 0));
12193           TREE_CONSTANT (glabel) = 1;
12194           TREE_STATIC (glabel) = 1;
12195           DECL_CONTEXT (glabel) = current_function_decl;
12196           DECL_INITIAL (glabel) = NULL;
12197           make_decl_rtl (glabel, NULL);
12198           expand_decl (glabel);
12199
12200           ffecom_save_tree_forever (glabel);
12201
12202           break;
12203
12204         case FFELAB_typeANY:
12205           glabel = error_mark_node;
12206           break;
12207
12208         default:
12209           assert ("bad label type" == NULL);
12210           glabel = NULL;
12211           break;
12212         }
12213       ffelab_set_hook (label, glabel);
12214     }
12215   else
12216     {
12217       glabel = ffelab_hook (label);
12218     }
12219
12220   return glabel;
12221 }
12222
12223 #endif
12224 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12225    a single source specification (as in the fourth argument of MVBITS).
12226    If the type is NULL_TREE, the type of lhs is used to make the type of
12227    the MODIFY_EXPR.  */
12228
12229 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12230 tree
12231 ffecom_modify (tree newtype, tree lhs,
12232                tree rhs)
12233 {
12234   if (lhs == error_mark_node || rhs == error_mark_node)
12235     return error_mark_node;
12236
12237   if (newtype == NULL_TREE)
12238     newtype = TREE_TYPE (lhs);
12239
12240   if (TREE_SIDE_EFFECTS (lhs))
12241     lhs = stabilize_reference (lhs);
12242
12243   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12244 }
12245
12246 #endif
12247
12248 /* Register source file name.  */
12249
12250 void
12251 ffecom_file (const char *name)
12252 {
12253 #if FFECOM_GCC_INCLUDE
12254   ffecom_file_ (name);
12255 #endif
12256 }
12257
12258 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12259
12260    ffestorag st;
12261    ffecom_notify_init_storage(st);
12262
12263    Gets called when all possible units in an aggregate storage area (a LOCAL
12264    with equivalences or a COMMON) have been initialized.  The initialization
12265    info either is in ffestorag_init or, if that is NULL,
12266    ffestorag_accretion:
12267
12268    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12269    even for an array if the array is one element in length!
12270
12271    ffestorag_accretion will contain an opACCTER.  It is much like an
12272    opARRTER except it has an ffebit object in it instead of just a size.
12273    The back end can use the info in the ffebit object, if it wants, to
12274    reduce the amount of actual initialization, but in any case it should
12275    kill the ffebit object when done.  Also, set accretion to NULL but
12276    init to a non-NULL value.
12277
12278    After performing initialization, DO NOT set init to NULL, because that'll
12279    tell the front end it is ok for more initialization to happen.  Instead,
12280    set init to an opANY expression or some such thing that you can use to
12281    tell that you've already initialized the object.
12282
12283    27-Oct-91  JCB  1.1
12284       Support two-pass FFE.  */
12285
12286 void
12287 ffecom_notify_init_storage (ffestorag st)
12288 {
12289   ffebld init;                  /* The initialization expression. */
12290 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12291   ffetargetOffset size;         /* The size of the entity. */
12292   ffetargetAlign pad;           /* Its initial padding. */
12293 #endif
12294
12295   if (ffestorag_init (st) == NULL)
12296     {
12297       init = ffestorag_accretion (st);
12298       assert (init != NULL);
12299       ffestorag_set_accretion (st, NULL);
12300       ffestorag_set_accretes (st, 0);
12301
12302 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12303       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12304       size = ffebld_accter_size (init);
12305       pad = ffebld_accter_pad (init);
12306       ffebit_kill (ffebld_accter_bits (init));
12307       ffebld_set_op (init, FFEBLD_opARRTER);
12308       ffebld_set_arrter (init, ffebld_accter (init));
12309       ffebld_arrter_set_size (init, size);
12310       ffebld_arrter_set_pad (init, size);
12311 #endif
12312
12313 #if FFECOM_TWOPASS
12314       ffestorag_set_init (st, init);
12315 #endif
12316     }
12317 #if FFECOM_ONEPASS
12318   else
12319     init = ffestorag_init (st);
12320 #endif
12321
12322 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12323   ffestorag_set_init (st, ffebld_new_any ());
12324
12325   if (ffebld_op (init) == FFEBLD_opANY)
12326     return;                     /* Oh, we already did this! */
12327
12328 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12329   {
12330     ffesymbol s;
12331
12332     if (ffestorag_symbol (st) != NULL)
12333       s = ffestorag_symbol (st);
12334     else
12335       s = ffestorag_typesymbol (st);
12336
12337     fprintf (dmpout, "= initialize_storage \"%s\" ",
12338              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12339     ffebld_dump (init);
12340     fputc ('\n', dmpout);
12341   }
12342 #endif
12343
12344 #endif /* if FFECOM_ONEPASS */
12345 }
12346
12347 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12348
12349    ffesymbol s;
12350    ffecom_notify_init_symbol(s);
12351
12352    Gets called when all possible units in a symbol (not placed in COMMON
12353    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12354    have been initialized.  The initialization info either is in
12355    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12356
12357    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12358    even for an array if the array is one element in length!
12359
12360    ffesymbol_accretion will contain an opACCTER.  It is much like an
12361    opARRTER except it has an ffebit object in it instead of just a size.
12362    The back end can use the info in the ffebit object, if it wants, to
12363    reduce the amount of actual initialization, but in any case it should
12364    kill the ffebit object when done.  Also, set accretion to NULL but
12365    init to a non-NULL value.
12366
12367    After performing initialization, DO NOT set init to NULL, because that'll
12368    tell the front end it is ok for more initialization to happen.  Instead,
12369    set init to an opANY expression or some such thing that you can use to
12370    tell that you've already initialized the object.
12371
12372    27-Oct-91  JCB  1.1
12373       Support two-pass FFE.  */
12374
12375 void
12376 ffecom_notify_init_symbol (ffesymbol s)
12377 {
12378   ffebld init;                  /* The initialization expression. */
12379 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12380   ffetargetOffset size;         /* The size of the entity. */
12381   ffetargetAlign pad;           /* Its initial padding. */
12382 #endif
12383
12384   if (ffesymbol_storage (s) == NULL)
12385     return;                     /* Do nothing until COMMON/EQUIVALENCE
12386                                    possibilities checked. */
12387
12388   if ((ffesymbol_init (s) == NULL)
12389       && ((init = ffesymbol_accretion (s)) != NULL))
12390     {
12391       ffesymbol_set_accretion (s, NULL);
12392       ffesymbol_set_accretes (s, 0);
12393
12394 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12395       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12396       size = ffebld_accter_size (init);
12397       pad = ffebld_accter_pad (init);
12398       ffebit_kill (ffebld_accter_bits (init));
12399       ffebld_set_op (init, FFEBLD_opARRTER);
12400       ffebld_set_arrter (init, ffebld_accter (init));
12401       ffebld_arrter_set_size (init, size);
12402       ffebld_arrter_set_pad (init, size);
12403 #endif
12404
12405 #if FFECOM_TWOPASS
12406       ffesymbol_set_init (s, init);
12407 #endif
12408     }
12409 #if FFECOM_ONEPASS
12410   else
12411     init = ffesymbol_init (s);
12412 #endif
12413
12414 #if FFECOM_ONEPASS
12415   ffesymbol_set_init (s, ffebld_new_any ());
12416
12417   if (ffebld_op (init) == FFEBLD_opANY)
12418     return;                     /* Oh, we already did this! */
12419
12420 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12421   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12422   ffebld_dump (init);
12423   fputc ('\n', dmpout);
12424 #endif
12425
12426 #endif /* if FFECOM_ONEPASS */
12427 }
12428
12429 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12430
12431    ffesymbol s;
12432    ffecom_notify_primary_entry(s);
12433
12434    Gets called when implicit or explicit PROGRAM statement seen or when
12435    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12436    global symbol that serves as the entry point.  */
12437
12438 void
12439 ffecom_notify_primary_entry (ffesymbol s)
12440 {
12441   ffecom_primary_entry_ = s;
12442   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12443
12444   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12445       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12446     ffecom_primary_entry_is_proc_ = TRUE;
12447   else
12448     ffecom_primary_entry_is_proc_ = FALSE;
12449
12450   if (!ffe_is_silent ())
12451     {
12452       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12453         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12454       else
12455         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12456     }
12457
12458 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12459   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12460     {
12461       ffebld list;
12462       ffebld arg;
12463
12464       for (list = ffesymbol_dummyargs (s);
12465            list != NULL;
12466            list = ffebld_trail (list))
12467         {
12468           arg = ffebld_head (list);
12469           if (ffebld_op (arg) == FFEBLD_opSTAR)
12470             {
12471               ffecom_is_altreturning_ = TRUE;
12472               break;
12473             }
12474         }
12475     }
12476 #endif
12477 }
12478
12479 FILE *
12480 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12481 {
12482 #if FFECOM_GCC_INCLUDE
12483   return ffecom_open_include_ (name, l, c);
12484 #else
12485   return fopen (name, "r");
12486 #endif
12487 }
12488
12489 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12490
12491    tree t;
12492    ffebld expr;  // FFE expression.
12493    tree = ffecom_ptr_to_expr(expr);
12494
12495    Like ffecom_expr, but sticks address-of in front of most things.  */
12496
12497 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12498 tree
12499 ffecom_ptr_to_expr (ffebld expr)
12500 {
12501   tree item;
12502   ffeinfoBasictype bt;
12503   ffeinfoKindtype kt;
12504   ffesymbol s;
12505
12506   assert (expr != NULL);
12507
12508   switch (ffebld_op (expr))
12509     {
12510     case FFEBLD_opSYMTER:
12511       s = ffebld_symter (expr);
12512       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12513         {
12514           ffecomGfrt ix;
12515
12516           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12517           assert (ix != FFECOM_gfrt);
12518           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12519             {
12520               ffecom_make_gfrt_ (ix);
12521               item = ffecom_gfrt_[ix];
12522             }
12523         }
12524       else
12525         {
12526           item = ffesymbol_hook (s).decl_tree;
12527           if (item == NULL_TREE)
12528             {
12529               s = ffecom_sym_transform_ (s);
12530               item = ffesymbol_hook (s).decl_tree;
12531             }
12532         }
12533       assert (item != NULL);
12534       if (item == error_mark_node)
12535         return item;
12536       if (!ffesymbol_hook (s).addr)
12537         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12538                          item);
12539       return item;
12540
12541     case FFEBLD_opARRAYREF:
12542       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12543
12544     case FFEBLD_opCONTER:
12545
12546       bt = ffeinfo_basictype (ffebld_info (expr));
12547       kt = ffeinfo_kindtype (ffebld_info (expr));
12548
12549       item = ffecom_constantunion (&ffebld_constant_union
12550                                    (ffebld_conter (expr)), bt, kt,
12551                                    ffecom_tree_type[bt][kt]);
12552       if (item == error_mark_node)
12553         return error_mark_node;
12554       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12555                        item);
12556       return item;
12557
12558     case FFEBLD_opANY:
12559       return error_mark_node;
12560
12561     default:
12562       bt = ffeinfo_basictype (ffebld_info (expr));
12563       kt = ffeinfo_kindtype (ffebld_info (expr));
12564
12565       item = ffecom_expr (expr);
12566       if (item == error_mark_node)
12567         return error_mark_node;
12568
12569       /* The back end currently optimizes a bit too zealously for us, in that
12570          we fail JCB001 if the following block of code is omitted.  It checks
12571          to see if the transformed expression is a symbol or array reference,
12572          and encloses it in a SAVE_EXPR if that is the case.  */
12573
12574       STRIP_NOPS (item);
12575       if ((TREE_CODE (item) == VAR_DECL)
12576           || (TREE_CODE (item) == PARM_DECL)
12577           || (TREE_CODE (item) == RESULT_DECL)
12578           || (TREE_CODE (item) == INDIRECT_REF)
12579           || (TREE_CODE (item) == ARRAY_REF)
12580           || (TREE_CODE (item) == COMPONENT_REF)
12581 #ifdef OFFSET_REF
12582           || (TREE_CODE (item) == OFFSET_REF)
12583 #endif
12584           || (TREE_CODE (item) == BUFFER_REF)
12585           || (TREE_CODE (item) == REALPART_EXPR)
12586           || (TREE_CODE (item) == IMAGPART_EXPR))
12587         {
12588           item = ffecom_save_tree (item);
12589         }
12590
12591       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12592                        item);
12593       return item;
12594     }
12595
12596   assert ("fall-through error" == NULL);
12597   return error_mark_node;
12598 }
12599
12600 #endif
12601 /* Obtain a temp var with given data type.
12602
12603    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12604    or >= 0 for a CHARACTER type.
12605
12606    elements is -1 for a scalar or > 0 for an array of type.  */
12607
12608 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12609 tree
12610 ffecom_make_tempvar (const char *commentary, tree type,
12611                      ffetargetCharacterSize size, int elements)
12612 {
12613   tree t;
12614   static int mynumber;
12615
12616   assert (current_binding_level->prep_state < 2);
12617
12618   if (type == error_mark_node)
12619     return error_mark_node;
12620
12621   if (size != FFETARGET_charactersizeNONE)
12622     type = build_array_type (type,
12623                              build_range_type (ffecom_f2c_ftnlen_type_node,
12624                                                ffecom_f2c_ftnlen_one_node,
12625                                                build_int_2 (size, 0)));
12626   if (elements != -1)
12627     type = build_array_type (type,
12628                              build_range_type (integer_type_node,
12629                                                integer_zero_node,
12630                                                build_int_2 (elements - 1,
12631                                                             0)));
12632   t = build_decl (VAR_DECL,
12633                   ffecom_get_invented_identifier ("__g77_%s_%d",
12634                                                   commentary,
12635                                                   mynumber++),
12636                   type);
12637
12638   t = start_decl (t, FALSE);
12639   finish_decl (t, NULL_TREE, FALSE);
12640
12641   return t;
12642 }
12643 #endif
12644
12645 /* Prepare argument pointer to expression.
12646
12647    Like ffecom_prepare_expr, except for expressions to be evaluated
12648    via ffecom_arg_ptr_to_expr.  */
12649
12650 void
12651 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12652 {
12653   /* ~~For now, it seems to be the same thing.  */
12654   ffecom_prepare_expr (expr);
12655   return;
12656 }
12657
12658 /* End of preparations.  */
12659
12660 bool
12661 ffecom_prepare_end (void)
12662 {
12663   int prep_state = current_binding_level->prep_state;
12664
12665   assert (prep_state < 2);
12666   current_binding_level->prep_state = 2;
12667
12668   return (prep_state == 1) ? TRUE : FALSE;
12669 }
12670
12671 /* Prepare expression.
12672
12673    This is called before any code is generated for the current block.
12674    It scans the expression, declares any temporaries that might be needed
12675    during evaluation of the expression, and stores those temporaries in
12676    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12677    specifies the destination that ffecom_expr_ will see, in case that
12678    helps avoid generating unused temporaries.
12679
12680    ~~Improve to avoid allocating unused temporaries by taking `dest'
12681    into account vis-a-vis aliasing requirements of complex/character
12682    functions.  */
12683
12684 void
12685 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12686 {
12687   ffeinfoBasictype bt;
12688   ffeinfoKindtype kt;
12689   ffetargetCharacterSize sz;
12690   tree tempvar = NULL_TREE;
12691
12692   assert (current_binding_level->prep_state < 2);
12693
12694   if (! expr)
12695     return;
12696
12697   bt = ffeinfo_basictype (ffebld_info (expr));
12698   kt = ffeinfo_kindtype (ffebld_info (expr));
12699   sz = ffeinfo_size (ffebld_info (expr));
12700
12701   /* Generate whatever temporaries are needed to represent the result
12702      of the expression.  */
12703
12704   if (bt == FFEINFO_basictypeCHARACTER)
12705     {
12706       while (ffebld_op (expr) == FFEBLD_opPAREN)
12707         expr = ffebld_left (expr);
12708     }
12709
12710   switch (ffebld_op (expr))
12711     {
12712     default:
12713       /* Don't make temps for SYMTER, CONTER, etc.  */
12714       if (ffebld_arity (expr) == 0)
12715         break;
12716
12717       switch (bt)
12718         {
12719         case FFEINFO_basictypeCOMPLEX:
12720           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12721             {
12722               ffesymbol s;
12723
12724               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12725                 break;
12726
12727               s = ffebld_symter (ffebld_left (expr));
12728               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12729                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12730                       && ! ffesymbol_is_f2c (s))
12731                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12732                       && ! ffe_is_f2c_library ()))
12733                 break;
12734             }
12735           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12736             {
12737               /* Requires special treatment.  There's no POW_CC function
12738                  in libg2c, so POW_ZZ is used, which means we always
12739                  need a double-complex temp, not a single-complex.  */
12740               kt = FFEINFO_kindtypeREAL2;
12741             }
12742           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12743             /* The other ops don't need temps for complex operands.  */
12744             break;
12745
12746           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12747              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12748           tempvar = ffecom_make_tempvar ("complex",
12749                                          ffecom_tree_type
12750                                          [FFEINFO_basictypeCOMPLEX][kt],
12751                                          FFETARGET_charactersizeNONE,
12752                                          -1);
12753           break;
12754
12755         case FFEINFO_basictypeCHARACTER:
12756           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12757             break;
12758
12759           if (sz == FFETARGET_charactersizeNONE)
12760             /* ~~Kludge alert!  This should someday be fixed. */
12761             sz = 24;
12762
12763           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12764           break;
12765
12766         default:
12767           break;
12768         }
12769       break;
12770
12771 #ifdef HAHA
12772     case FFEBLD_opPOWER:
12773       {
12774         tree rtype, ltype;
12775         tree rtmp, ltmp, result;
12776
12777         ltype = ffecom_type_expr (ffebld_left (expr));
12778         rtype = ffecom_type_expr (ffebld_right (expr));
12779
12780         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12781         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12782         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12783
12784         tempvar = make_tree_vec (3);
12785         TREE_VEC_ELT (tempvar, 0) = rtmp;
12786         TREE_VEC_ELT (tempvar, 1) = ltmp;
12787         TREE_VEC_ELT (tempvar, 2) = result;
12788       }
12789       break;
12790 #endif  /* HAHA */
12791
12792     case FFEBLD_opCONCATENATE:
12793       {
12794         /* This gets special handling, because only one set of temps
12795            is needed for a tree of these -- the tree is treated as
12796            a flattened list of concatenations when generating code.  */
12797
12798         ffecomConcatList_ catlist;
12799         tree ltmp, itmp, result;
12800         int count;
12801         int i;
12802
12803         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12804         count = ffecom_concat_list_count_ (catlist);
12805
12806         if (count >= 2)
12807           {
12808             ltmp
12809               = ffecom_make_tempvar ("concat_len",
12810                                      ffecom_f2c_ftnlen_type_node,
12811                                      FFETARGET_charactersizeNONE, count);
12812             itmp
12813               = ffecom_make_tempvar ("concat_item",
12814                                      ffecom_f2c_address_type_node,
12815                                      FFETARGET_charactersizeNONE, count);
12816             result
12817               = ffecom_make_tempvar ("concat_res",
12818                                      char_type_node,
12819                                      ffecom_concat_list_maxlen_ (catlist),
12820                                      -1);
12821
12822             tempvar = make_tree_vec (3);
12823             TREE_VEC_ELT (tempvar, 0) = ltmp;
12824             TREE_VEC_ELT (tempvar, 1) = itmp;
12825             TREE_VEC_ELT (tempvar, 2) = result;
12826           }
12827
12828         for (i = 0; i < count; ++i)
12829           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12830                                                                     i));
12831
12832         ffecom_concat_list_kill_ (catlist);
12833
12834         if (tempvar)
12835           {
12836             ffebld_nonter_set_hook (expr, tempvar);
12837             current_binding_level->prep_state = 1;
12838           }
12839       }
12840       return;
12841
12842     case FFEBLD_opCONVERT:
12843       if (bt == FFEINFO_basictypeCHARACTER
12844           && ((ffebld_size_known (ffebld_left (expr))
12845                == FFETARGET_charactersizeNONE)
12846               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12847         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12848       break;
12849     }
12850
12851   if (tempvar)
12852     {
12853       ffebld_nonter_set_hook (expr, tempvar);
12854       current_binding_level->prep_state = 1;
12855     }
12856
12857   /* Prepare subexpressions for this expr.  */
12858
12859   switch (ffebld_op (expr))
12860     {
12861     case FFEBLD_opPERCENT_LOC:
12862       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12863       break;
12864
12865     case FFEBLD_opPERCENT_VAL:
12866     case FFEBLD_opPERCENT_REF:
12867       ffecom_prepare_expr (ffebld_left (expr));
12868       break;
12869
12870     case FFEBLD_opPERCENT_DESCR:
12871       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12872       break;
12873
12874     case FFEBLD_opITEM:
12875       {
12876         ffebld item;
12877
12878         for (item = expr;
12879              item != NULL;
12880              item = ffebld_trail (item))
12881           if (ffebld_head (item) != NULL)
12882             ffecom_prepare_expr (ffebld_head (item));
12883       }
12884       break;
12885
12886     default:
12887       /* Need to handle character conversion specially.  */
12888       switch (ffebld_arity (expr))
12889         {
12890         case 2:
12891           ffecom_prepare_expr (ffebld_left (expr));
12892           ffecom_prepare_expr (ffebld_right (expr));
12893           break;
12894
12895         case 1:
12896           ffecom_prepare_expr (ffebld_left (expr));
12897           break;
12898
12899         default:
12900           break;
12901         }
12902     }
12903
12904   return;
12905 }
12906
12907 /* Prepare expression for reading and writing.
12908
12909    Like ffecom_prepare_expr, except for expressions to be evaluated
12910    via ffecom_expr_rw.  */
12911
12912 void
12913 ffecom_prepare_expr_rw (tree type, ffebld expr)
12914 {
12915   /* This is all we support for now.  */
12916   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12917
12918   /* ~~For now, it seems to be the same thing.  */
12919   ffecom_prepare_expr (expr);
12920   return;
12921 }
12922
12923 /* Prepare expression for writing.
12924
12925    Like ffecom_prepare_expr, except for expressions to be evaluated
12926    via ffecom_expr_w.  */
12927
12928 void
12929 ffecom_prepare_expr_w (tree type, ffebld expr)
12930 {
12931   /* This is all we support for now.  */
12932   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12933
12934   /* ~~For now, it seems to be the same thing.  */
12935   ffecom_prepare_expr (expr);
12936   return;
12937 }
12938
12939 /* Prepare expression for returning.
12940
12941    Like ffecom_prepare_expr, except for expressions to be evaluated
12942    via ffecom_return_expr.  */
12943
12944 void
12945 ffecom_prepare_return_expr (ffebld expr)
12946 {
12947   assert (current_binding_level->prep_state < 2);
12948
12949   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12950       && ffecom_is_altreturning_
12951       && expr != NULL)
12952     ffecom_prepare_expr (expr);
12953 }
12954
12955 /* Prepare pointer to expression.
12956
12957    Like ffecom_prepare_expr, except for expressions to be evaluated
12958    via ffecom_ptr_to_expr.  */
12959
12960 void
12961 ffecom_prepare_ptr_to_expr (ffebld expr)
12962 {
12963   /* ~~For now, it seems to be the same thing.  */
12964   ffecom_prepare_expr (expr);
12965   return;
12966 }
12967
12968 /* Transform expression into constant pointer-to-expression tree.
12969
12970    If the expression can be transformed into a pointer-to-expression tree
12971    that is constant, that is done, and the tree returned.  Else NULL_TREE
12972    is returned.
12973
12974    That way, a caller can attempt to provide compile-time initialization
12975    of a variable and, if that fails, *then* choose to start a new block
12976    and resort to using temporaries, as appropriate.  */
12977
12978 tree
12979 ffecom_ptr_to_const_expr (ffebld expr)
12980 {
12981   if (! expr)
12982     return integer_zero_node;
12983
12984   if (ffebld_op (expr) == FFEBLD_opANY)
12985     return error_mark_node;
12986
12987   if (ffebld_arity (expr) == 0
12988       && (ffebld_op (expr) != FFEBLD_opSYMTER
12989           || ffebld_where (expr) == FFEINFO_whereCOMMON
12990           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12991           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12992     {
12993       tree t;
12994
12995       t = ffecom_ptr_to_expr (expr);
12996       assert (TREE_CONSTANT (t));
12997       return t;
12998     }
12999
13000   return NULL_TREE;
13001 }
13002
13003 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13004
13005    tree rtn;  // NULL_TREE means use expand_null_return()
13006    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13007    rtn = ffecom_return_expr(expr);
13008
13009    Based on the program unit type and other info (like return function
13010    type, return master function type when alternate ENTRY points,
13011    whether subroutine has any alternate RETURN points, etc), returns the
13012    appropriate expression to be returned to the caller, or NULL_TREE
13013    meaning no return value or the caller expects it to be returned somewhere
13014    else (which is handled by other parts of this module).  */
13015
13016 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13017 tree
13018 ffecom_return_expr (ffebld expr)
13019 {
13020   tree rtn;
13021
13022   switch (ffecom_primary_entry_kind_)
13023     {
13024     case FFEINFO_kindPROGRAM:
13025     case FFEINFO_kindBLOCKDATA:
13026       rtn = NULL_TREE;
13027       break;
13028
13029     case FFEINFO_kindSUBROUTINE:
13030       if (!ffecom_is_altreturning_)
13031         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13032       else if (expr == NULL)
13033         rtn = integer_zero_node;
13034       else
13035         rtn = ffecom_expr (expr);
13036       break;
13037
13038     case FFEINFO_kindFUNCTION:
13039       if ((ffecom_multi_retval_ != NULL_TREE)
13040           || (ffesymbol_basictype (ffecom_primary_entry_)
13041               == FFEINFO_basictypeCHARACTER)
13042           || ((ffesymbol_basictype (ffecom_primary_entry_)
13043                == FFEINFO_basictypeCOMPLEX)
13044               && (ffecom_num_entrypoints_ == 0)
13045               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13046         {                       /* Value is returned by direct assignment
13047                                    into (implicit) dummy. */
13048           rtn = NULL_TREE;
13049           break;
13050         }
13051       rtn = ffecom_func_result_;
13052 #if 0
13053       /* Spurious error if RETURN happens before first reference!  So elide
13054          this code.  In particular, for debugging registry, rtn should always
13055          be non-null after all, but TREE_USED won't be set until we encounter
13056          a reference in the code.  Perfectly okay (but weird) code that,
13057          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13058          this diagnostic for no reason.  Have people use -O -Wuninitialized
13059          and leave it to the back end to find obviously weird cases.  */
13060
13061       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13062          situation; if the return value has never been referenced, it won't
13063          have a tree under 2pass mode. */
13064       if ((rtn == NULL_TREE)
13065           || !TREE_USED (rtn))
13066         {
13067           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13068           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13069                        ffesymbol_where_column (ffecom_primary_entry_));
13070           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13071                                          (ffecom_primary_entry_)));
13072           ffebad_finish ();
13073         }
13074 #endif
13075       break;
13076
13077     default:
13078       assert ("bad unit kind" == NULL);
13079     case FFEINFO_kindANY:
13080       rtn = error_mark_node;
13081       break;
13082     }
13083
13084   return rtn;
13085 }
13086
13087 #endif
13088 /* Do save_expr only if tree is not error_mark_node.  */
13089
13090 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13091 tree
13092 ffecom_save_tree (tree t)
13093 {
13094   return save_expr (t);
13095 }
13096 #endif
13097
13098 /* Start a compound statement (block).  */
13099
13100 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13101 void
13102 ffecom_start_compstmt (void)
13103 {
13104   bison_rule_pushlevel_ ();
13105 }
13106 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13107
13108 /* Public entry point for front end to access start_decl.  */
13109
13110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13111 tree
13112 ffecom_start_decl (tree decl, bool is_initialized)
13113 {
13114   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13115   return start_decl (decl, FALSE);
13116 }
13117
13118 #endif
13119 /* ffecom_sym_commit -- Symbol's state being committed to reality
13120
13121    ffesymbol s;
13122    ffecom_sym_commit(s);
13123
13124    Does whatever the backend needs when a symbol is committed after having
13125    been backtrackable for a period of time.  */
13126
13127 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13128 void
13129 ffecom_sym_commit (ffesymbol s UNUSED)
13130 {
13131   assert (!ffesymbol_retractable ());
13132 }
13133
13134 #endif
13135 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13136
13137    ffecom_sym_end_transition();
13138
13139    Does backend-specific stuff and also calls ffest_sym_end_transition
13140    to do the necessary FFE stuff.
13141
13142    Backtracking is never enabled when this fn is called, so don't worry
13143    about it.  */
13144
13145 ffesymbol
13146 ffecom_sym_end_transition (ffesymbol s)
13147 {
13148   ffestorag st;
13149
13150   assert (!ffesymbol_retractable ());
13151
13152   s = ffest_sym_end_transition (s);
13153
13154 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13155   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13156       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13157     {
13158       ffecom_list_blockdata_
13159         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13160                                               FFEINTRIN_specNONE,
13161                                               FFEINTRIN_impNONE),
13162                            ffecom_list_blockdata_);
13163     }
13164 #endif
13165
13166   /* This is where we finally notice that a symbol has partial initialization
13167      and finalize it. */
13168
13169   if (ffesymbol_accretion (s) != NULL)
13170     {
13171       assert (ffesymbol_init (s) == NULL);
13172       ffecom_notify_init_symbol (s);
13173     }
13174   else if (((st = ffesymbol_storage (s)) != NULL)
13175            && ((st = ffestorag_parent (st)) != NULL)
13176            && (ffestorag_accretion (st) != NULL))
13177     {
13178       assert (ffestorag_init (st) == NULL);
13179       ffecom_notify_init_storage (st);
13180     }
13181
13182 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13183   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13184       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13185       && (ffesymbol_storage (s) != NULL))
13186     {
13187       ffecom_list_common_
13188         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13189                                               FFEINTRIN_specNONE,
13190                                               FFEINTRIN_impNONE),
13191                            ffecom_list_common_);
13192     }
13193 #endif
13194
13195   return s;
13196 }
13197
13198 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13199
13200    ffecom_sym_exec_transition();
13201
13202    Does backend-specific stuff and also calls ffest_sym_exec_transition
13203    to do the necessary FFE stuff.
13204
13205    See the long-winded description in ffecom_sym_learned for info
13206    on handling the situation where backtracking is inhibited.  */
13207
13208 ffesymbol
13209 ffecom_sym_exec_transition (ffesymbol s)
13210 {
13211   s = ffest_sym_exec_transition (s);
13212
13213   return s;
13214 }
13215
13216 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13217
13218    ffesymbol s;
13219    s = ffecom_sym_learned(s);
13220
13221    Called when a new symbol is seen after the exec transition or when more
13222    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13223    it arrives here is that all its latest info is updated already, so its
13224    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13225    field filled in if its gone through here or exec_transition first, and
13226    so on.
13227
13228    The backend probably wants to check ffesymbol_retractable() to see if
13229    backtracking is in effect.  If so, the FFE's changes to the symbol may
13230    be retracted (undone) or committed (ratified), at which time the
13231    appropriate ffecom_sym_retract or _commit function will be called
13232    for that function.
13233
13234    If the backend has its own backtracking mechanism, great, use it so that
13235    committal is a simple operation.  Though it doesn't make much difference,
13236    I suppose: the reason for tentative symbol evolution in the FFE is to
13237    enable error detection in weird incorrect statements early and to disable
13238    incorrect error detection on a correct statement.  The backend is not
13239    likely to introduce any information that'll get involved in these
13240    considerations, so it is probably just fine that the implementation
13241    model for this fn and for _exec_transition is to not do anything
13242    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13243    and instead wait until ffecom_sym_commit is called (which it never
13244    will be as long as we're using ambiguity-detecting statement analysis in
13245    the FFE, which we are initially to shake out the code, but don't depend
13246    on this), otherwise go ahead and do whatever is needed.
13247
13248    In essence, then, when this fn and _exec_transition get called while
13249    backtracking is enabled, a general mechanism would be to flag which (or
13250    both) of these were called (and in what order? neat question as to what
13251    might happen that I'm too lame to think through right now) and then when
13252    _commit is called reproduce the original calling sequence, if any, for
13253    the two fns (at which point backtracking will, of course, be disabled).  */
13254
13255 ffesymbol
13256 ffecom_sym_learned (ffesymbol s)
13257 {
13258   ffestorag_exec_layout (s);
13259
13260   return s;
13261 }
13262
13263 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13264
13265    ffesymbol s;
13266    ffecom_sym_retract(s);
13267
13268    Does whatever the backend needs when a symbol is retracted after having
13269    been backtrackable for a period of time.  */
13270
13271 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13272 void
13273 ffecom_sym_retract (ffesymbol s UNUSED)
13274 {
13275   assert (!ffesymbol_retractable ());
13276
13277 #if 0                           /* GCC doesn't commit any backtrackable sins,
13278                                    so nothing needed here. */
13279   switch (ffesymbol_hook (s).state)
13280     {
13281     case 0:                     /* nothing happened yet. */
13282       break;
13283
13284     case 1:                     /* exec transition happened. */
13285       break;
13286
13287     case 2:                     /* learned happened. */
13288       break;
13289
13290     case 3:                     /* learned then exec. */
13291       break;
13292
13293     case 4:                     /* exec then learned. */
13294       break;
13295
13296     default:
13297       assert ("bad hook state" == NULL);
13298       break;
13299     }
13300 #endif
13301 }
13302
13303 #endif
13304 /* Create temporary gcc label.  */
13305
13306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13307 tree
13308 ffecom_temp_label ()
13309 {
13310   tree glabel;
13311   static int mynumber = 0;
13312
13313   glabel = build_decl (LABEL_DECL,
13314                        ffecom_get_invented_identifier ("__g77_label_%d",
13315                                                        mynumber++),
13316                        void_type_node);
13317   DECL_CONTEXT (glabel) = current_function_decl;
13318   DECL_MODE (glabel) = VOIDmode;
13319
13320   return glabel;
13321 }
13322
13323 #endif
13324 /* Return an expression that is usable as an arg in a conditional context
13325    (IF, DO WHILE, .NOT., and so on).
13326
13327    Use the one provided for the back end as of >2.6.0.  */
13328
13329 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13330 tree
13331 ffecom_truth_value (tree expr)
13332 {
13333   return truthvalue_conversion (expr);
13334 }
13335
13336 #endif
13337 /* Return the inversion of a truth value (the inversion of what
13338    ffecom_truth_value builds).
13339
13340    Apparently invert_truthvalue, which is properly in the back end, is
13341    enough for now, so just use it.  */
13342
13343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13344 tree
13345 ffecom_truth_value_invert (tree expr)
13346 {
13347   return invert_truthvalue (ffecom_truth_value (expr));
13348 }
13349
13350 #endif
13351
13352 /* Return the tree that is the type of the expression, as would be
13353    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13354    transforming the expression, generating temporaries, etc.  */
13355
13356 tree
13357 ffecom_type_expr (ffebld expr)
13358 {
13359   ffeinfoBasictype bt;
13360   ffeinfoKindtype kt;
13361   tree tree_type;
13362
13363   assert (expr != NULL);
13364
13365   bt = ffeinfo_basictype (ffebld_info (expr));
13366   kt = ffeinfo_kindtype (ffebld_info (expr));
13367   tree_type = ffecom_tree_type[bt][kt];
13368
13369   switch (ffebld_op (expr))
13370     {
13371     case FFEBLD_opCONTER:
13372     case FFEBLD_opSYMTER:
13373     case FFEBLD_opARRAYREF:
13374     case FFEBLD_opUPLUS:
13375     case FFEBLD_opPAREN:
13376     case FFEBLD_opUMINUS:
13377     case FFEBLD_opADD:
13378     case FFEBLD_opSUBTRACT:
13379     case FFEBLD_opMULTIPLY:
13380     case FFEBLD_opDIVIDE:
13381     case FFEBLD_opPOWER:
13382     case FFEBLD_opNOT:
13383     case FFEBLD_opFUNCREF:
13384     case FFEBLD_opSUBRREF:
13385     case FFEBLD_opAND:
13386     case FFEBLD_opOR:
13387     case FFEBLD_opXOR:
13388     case FFEBLD_opNEQV:
13389     case FFEBLD_opEQV:
13390     case FFEBLD_opCONVERT:
13391     case FFEBLD_opLT:
13392     case FFEBLD_opLE:
13393     case FFEBLD_opEQ:
13394     case FFEBLD_opNE:
13395     case FFEBLD_opGT:
13396     case FFEBLD_opGE:
13397     case FFEBLD_opPERCENT_LOC:
13398       return tree_type;
13399
13400     case FFEBLD_opACCTER:
13401     case FFEBLD_opARRTER:
13402     case FFEBLD_opITEM:
13403     case FFEBLD_opSTAR:
13404     case FFEBLD_opBOUNDS:
13405     case FFEBLD_opREPEAT:
13406     case FFEBLD_opLABTER:
13407     case FFEBLD_opLABTOK:
13408     case FFEBLD_opIMPDO:
13409     case FFEBLD_opCONCATENATE:
13410     case FFEBLD_opSUBSTR:
13411     default:
13412       assert ("bad op for ffecom_type_expr" == NULL);
13413       /* Fall through. */
13414     case FFEBLD_opANY:
13415       return error_mark_node;
13416     }
13417 }
13418
13419 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13420
13421    If the PARM_DECL already exists, return it, else create it.  It's an
13422    integer_type_node argument for the master function that implements a
13423    subroutine or function with more than one entrypoint and is bound at
13424    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13425    first ENTRY statement, and so on).  */
13426
13427 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13428 tree
13429 ffecom_which_entrypoint_decl ()
13430 {
13431   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13432
13433   return ffecom_which_entrypoint_decl_;
13434 }
13435
13436 #endif
13437 \f
13438 /* The following sections consists of private and public functions
13439    that have the same names and perform roughly the same functions
13440    as counterparts in the C front end.  Changes in the C front end
13441    might affect how things should be done here.  Only functions
13442    needed by the back end should be public here; the rest should
13443    be private (static in the C sense).  Functions needed by other
13444    g77 front-end modules should be accessed by them via public
13445    ffecom_* names, which should themselves call private versions
13446    in this section so the private versions are easy to recognize
13447    when upgrading to a new gcc and finding interesting changes
13448    in the front end.
13449
13450    Functions named after rule "foo:" in c-parse.y are named
13451    "bison_rule_foo_" so they are easy to find.  */
13452
13453 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13454
13455 static void
13456 bison_rule_pushlevel_ ()
13457 {
13458   emit_line_note (input_filename, lineno);
13459   pushlevel (0);
13460   clear_last_expr ();
13461   expand_start_bindings (0);
13462 }
13463
13464 static tree
13465 bison_rule_compstmt_ ()
13466 {
13467   tree t;
13468   int keep = kept_level_p ();
13469
13470   /* Make the temps go away.  */
13471   if (! keep)
13472     current_binding_level->names = NULL_TREE;
13473
13474   emit_line_note (input_filename, lineno);
13475   expand_end_bindings (getdecls (), keep, 0);
13476   t = poplevel (keep, 1, 0);
13477
13478   return t;
13479 }
13480
13481 /* Return a definition for a builtin function named NAME and whose data type
13482    is TYPE.  TYPE should be a function type with argument types.
13483    FUNCTION_CODE tells later passes how to compile calls to this function.
13484    See tree.h for its possible values.
13485
13486    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13487    the name to be called if we can't opencode the function.  */
13488
13489 tree
13490 builtin_function (const char *name, tree type, int function_code,
13491                   enum built_in_class class,
13492                   const char *library_name)
13493 {
13494   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13495   DECL_EXTERNAL (decl) = 1;
13496   TREE_PUBLIC (decl) = 1;
13497   if (library_name)
13498     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13499   make_decl_rtl (decl, NULL);
13500   pushdecl (decl);
13501   DECL_BUILT_IN_CLASS (decl) = class;
13502   DECL_FUNCTION_CODE (decl) = function_code;
13503
13504   return decl;
13505 }
13506
13507 /* Handle when a new declaration NEWDECL
13508    has the same name as an old one OLDDECL
13509    in the same binding contour.
13510    Prints an error message if appropriate.
13511
13512    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13513    Otherwise, return 0.  */
13514
13515 static int
13516 duplicate_decls (tree newdecl, tree olddecl)
13517 {
13518   int types_match = 1;
13519   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13520                            && DECL_INITIAL (newdecl) != 0);
13521   tree oldtype = TREE_TYPE (olddecl);
13522   tree newtype = TREE_TYPE (newdecl);
13523
13524   if (olddecl == newdecl)
13525     return 1;
13526
13527   if (TREE_CODE (newtype) == ERROR_MARK
13528       || TREE_CODE (oldtype) == ERROR_MARK)
13529     types_match = 0;
13530
13531   /* New decl is completely inconsistent with the old one =>
13532      tell caller to replace the old one.
13533      This is always an error except in the case of shadowing a builtin.  */
13534   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13535     return 0;
13536
13537   /* For real parm decl following a forward decl,
13538      return 1 so old decl will be reused.  */
13539   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13540       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13541     return 1;
13542
13543   /* The new declaration is the same kind of object as the old one.
13544      The declarations may partially match.  Print warnings if they don't
13545      match enough.  Ultimately, copy most of the information from the new
13546      decl to the old one, and keep using the old one.  */
13547
13548   if (TREE_CODE (olddecl) == FUNCTION_DECL
13549       && DECL_BUILT_IN (olddecl))
13550     {
13551       /* A function declaration for a built-in function.  */
13552       if (!TREE_PUBLIC (newdecl))
13553         return 0;
13554       else if (!types_match)
13555         {
13556           /* Accept the return type of the new declaration if same modes.  */
13557           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13558           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13559
13560           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13561             {
13562               /* Function types may be shared, so we can't just modify
13563                  the return type of olddecl's function type.  */
13564               tree newtype
13565                 = build_function_type (newreturntype,
13566                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13567
13568               types_match = 1;
13569               if (types_match)
13570                 TREE_TYPE (olddecl) = newtype;
13571             }
13572         }
13573       if (!types_match)
13574         return 0;
13575     }
13576   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13577            && DECL_SOURCE_LINE (olddecl) == 0)
13578     {
13579       /* A function declaration for a predeclared function
13580          that isn't actually built in.  */
13581       if (!TREE_PUBLIC (newdecl))
13582         return 0;
13583       else if (!types_match)
13584         {
13585           /* If the types don't match, preserve volatility indication.
13586              Later on, we will discard everything else about the
13587              default declaration.  */
13588           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13589         }
13590     }
13591
13592   /* Copy all the DECL_... slots specified in the new decl
13593      except for any that we copy here from the old type.
13594
13595      Past this point, we don't change OLDTYPE and NEWTYPE
13596      even if we change the types of NEWDECL and OLDDECL.  */
13597
13598   if (types_match)
13599     {
13600       /* Merge the data types specified in the two decls.  */
13601       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13602         TREE_TYPE (newdecl)
13603           = TREE_TYPE (olddecl)
13604             = TREE_TYPE (newdecl);
13605
13606       /* Lay the type out, unless already done.  */
13607       if (oldtype != TREE_TYPE (newdecl))
13608         {
13609           if (TREE_TYPE (newdecl) != error_mark_node)
13610             layout_type (TREE_TYPE (newdecl));
13611           if (TREE_CODE (newdecl) != FUNCTION_DECL
13612               && TREE_CODE (newdecl) != TYPE_DECL
13613               && TREE_CODE (newdecl) != CONST_DECL)
13614             layout_decl (newdecl, 0);
13615         }
13616       else
13617         {
13618           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13619           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13620           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13621           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13622             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13623               {
13624                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13625                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13626               }
13627         }
13628
13629       /* Keep the old rtl since we can safely use it.  */
13630       COPY_DECL_RTL (olddecl, newdecl);
13631
13632       /* Merge the type qualifiers.  */
13633       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13634           && !TREE_THIS_VOLATILE (newdecl))
13635         TREE_THIS_VOLATILE (olddecl) = 0;
13636       if (TREE_READONLY (newdecl))
13637         TREE_READONLY (olddecl) = 1;
13638       if (TREE_THIS_VOLATILE (newdecl))
13639         {
13640           TREE_THIS_VOLATILE (olddecl) = 1;
13641           if (TREE_CODE (newdecl) == VAR_DECL)
13642             make_var_volatile (newdecl);
13643         }
13644
13645       /* Keep source location of definition rather than declaration.
13646          Likewise, keep decl at outer scope.  */
13647       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13648           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13649         {
13650           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13651           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13652
13653           if (DECL_CONTEXT (olddecl) == 0
13654               && TREE_CODE (newdecl) != FUNCTION_DECL)
13655             DECL_CONTEXT (newdecl) = 0;
13656         }
13657
13658       /* Merge the unused-warning information.  */
13659       if (DECL_IN_SYSTEM_HEADER (olddecl))
13660         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13661       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13662         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13663
13664       /* Merge the initialization information.  */
13665       if (DECL_INITIAL (newdecl) == 0)
13666         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13667
13668       /* Merge the section attribute.
13669          We want to issue an error if the sections conflict but that must be
13670          done later in decl_attributes since we are called before attributes
13671          are assigned.  */
13672       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13673         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13674
13675 #if BUILT_FOR_270
13676       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13677         {
13678           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13679           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13680         }
13681 #endif
13682     }
13683   /* If cannot merge, then use the new type and qualifiers,
13684      and don't preserve the old rtl.  */
13685   else
13686     {
13687       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13688       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13689       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13690       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13691     }
13692
13693   /* Merge the storage class information.  */
13694   /* For functions, static overrides non-static.  */
13695   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13696     {
13697       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13698       /* This is since we don't automatically
13699          copy the attributes of NEWDECL into OLDDECL.  */
13700       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13701       /* If this clears `static', clear it in the identifier too.  */
13702       if (! TREE_PUBLIC (olddecl))
13703         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13704     }
13705   if (DECL_EXTERNAL (newdecl))
13706     {
13707       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13708       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13709       /* An extern decl does not override previous storage class.  */
13710       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13711     }
13712   else
13713     {
13714       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13715       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13716     }
13717
13718   /* If either decl says `inline', this fn is inline,
13719      unless its definition was passed already.  */
13720   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13721     DECL_INLINE (olddecl) = 1;
13722   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13723
13724   /* Get rid of any built-in function if new arg types don't match it
13725      or if we have a function definition.  */
13726   if (TREE_CODE (newdecl) == FUNCTION_DECL
13727       && DECL_BUILT_IN (olddecl)
13728       && (!types_match || new_is_definition))
13729     {
13730       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13731       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13732     }
13733
13734   /* If redeclaring a builtin function, and not a definition,
13735      it stays built in.
13736      Also preserve various other info from the definition.  */
13737   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13738     {
13739       if (DECL_BUILT_IN (olddecl))
13740         {
13741           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13742           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13743         }
13744
13745       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13746       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13747       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13748       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13749     }
13750
13751   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13752      But preserve olddecl's DECL_UID.  */
13753   {
13754     register unsigned olddecl_uid = DECL_UID (olddecl);
13755
13756     memcpy ((char *) olddecl + sizeof (struct tree_common),
13757             (char *) newdecl + sizeof (struct tree_common),
13758             sizeof (struct tree_decl) - sizeof (struct tree_common));
13759     DECL_UID (olddecl) = olddecl_uid;
13760   }
13761
13762   return 1;
13763 }
13764
13765 /* Finish processing of a declaration;
13766    install its initial value.
13767    If the length of an array type is not known before,
13768    it must be determined now, from the initial value, or it is an error.  */
13769
13770 static void
13771 finish_decl (tree decl, tree init, bool is_top_level)
13772 {
13773   register tree type = TREE_TYPE (decl);
13774   int was_incomplete = (DECL_SIZE (decl) == 0);
13775   bool at_top_level = (current_binding_level == global_binding_level);
13776   bool top_level = is_top_level || at_top_level;
13777
13778   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13779      level anyway.  */
13780   assert (!is_top_level || !at_top_level);
13781
13782   if (TREE_CODE (decl) == PARM_DECL)
13783     assert (init == NULL_TREE);
13784   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13785      overlaps DECL_ARG_TYPE.  */
13786   else if (init == NULL_TREE)
13787     assert (DECL_INITIAL (decl) == NULL_TREE);
13788   else
13789     assert (DECL_INITIAL (decl) == error_mark_node);
13790
13791   if (init != NULL_TREE)
13792     {
13793       if (TREE_CODE (decl) != TYPE_DECL)
13794         DECL_INITIAL (decl) = init;
13795       else
13796         {
13797           /* typedef foo = bar; store the type of bar as the type of foo.  */
13798           TREE_TYPE (decl) = TREE_TYPE (init);
13799           DECL_INITIAL (decl) = init = 0;
13800         }
13801     }
13802
13803   /* Deduce size of array from initialization, if not already known */
13804
13805   if (TREE_CODE (type) == ARRAY_TYPE
13806       && TYPE_DOMAIN (type) == 0
13807       && TREE_CODE (decl) != TYPE_DECL)
13808     {
13809       assert (top_level);
13810       assert (was_incomplete);
13811
13812       layout_decl (decl, 0);
13813     }
13814
13815   if (TREE_CODE (decl) == VAR_DECL)
13816     {
13817       if (DECL_SIZE (decl) == NULL_TREE
13818           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13819         layout_decl (decl, 0);
13820
13821       if (DECL_SIZE (decl) == NULL_TREE
13822           && (TREE_STATIC (decl)
13823               ?
13824       /* A static variable with an incomplete type is an error if it is
13825          initialized. Also if it is not file scope. Otherwise, let it
13826          through, but if it is not `extern' then it may cause an error
13827          message later.  */
13828               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13829               :
13830       /* An automatic variable with an incomplete type is an error.  */
13831               !DECL_EXTERNAL (decl)))
13832         {
13833           assert ("storage size not known" == NULL);
13834           abort ();
13835         }
13836
13837       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13838           && (DECL_SIZE (decl) != 0)
13839           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13840         {
13841           assert ("storage size not constant" == NULL);
13842           abort ();
13843         }
13844     }
13845
13846   /* Output the assembler code and/or RTL code for variables and functions,
13847      unless the type is an undefined structure or union. If not, it will get
13848      done when the type is completed.  */
13849
13850   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13851     {
13852       rest_of_decl_compilation (decl, NULL,
13853                                 DECL_CONTEXT (decl) == 0,
13854                                 0);
13855
13856       if (DECL_CONTEXT (decl) != 0)
13857         {
13858           /* Recompute the RTL of a local array now if it used to be an
13859              incomplete type.  */
13860           if (was_incomplete
13861               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13862             {
13863               /* If we used it already as memory, it must stay in memory.  */
13864               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13865               /* If it's still incomplete now, no init will save it.  */
13866               if (DECL_SIZE (decl) == 0)
13867                 DECL_INITIAL (decl) = 0;
13868               expand_decl (decl);
13869             }
13870           /* Compute and store the initial value.  */
13871           if (TREE_CODE (decl) != FUNCTION_DECL)
13872             expand_decl_init (decl);
13873         }
13874     }
13875   else if (TREE_CODE (decl) == TYPE_DECL)
13876     {
13877       rest_of_decl_compilation (decl, NULL,
13878                                 DECL_CONTEXT (decl) == 0,
13879                                 0);
13880     }
13881
13882   /* At the end of a declaration, throw away any variable type sizes of types
13883      defined inside that declaration.  There is no use computing them in the
13884      following function definition.  */
13885   if (current_binding_level == global_binding_level)
13886     get_pending_sizes ();
13887 }
13888
13889 /* Finish up a function declaration and compile that function
13890    all the way to assembler language output.  The free the storage
13891    for the function definition.
13892
13893    This is called after parsing the body of the function definition.
13894
13895    NESTED is nonzero if the function being finished is nested in another.  */
13896
13897 static void
13898 finish_function (int nested)
13899 {
13900   register tree fndecl = current_function_decl;
13901
13902   assert (fndecl != NULL_TREE);
13903   if (TREE_CODE (fndecl) != ERROR_MARK)
13904     {
13905       if (nested)
13906         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13907       else
13908         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13909     }
13910
13911 /*  TREE_READONLY (fndecl) = 1;
13912     This caused &foo to be of type ptr-to-const-function
13913     which then got a warning when stored in a ptr-to-function variable.  */
13914
13915   poplevel (1, 0, 1);
13916
13917   if (TREE_CODE (fndecl) != ERROR_MARK)
13918     {
13919       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13920
13921       /* Must mark the RESULT_DECL as being in this function.  */
13922
13923       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13924
13925       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13926       /* Generate rtl for function exit.  */
13927       expand_function_end (input_filename, lineno, 0);
13928
13929       /* If this is a nested function, protect the local variables in the stack
13930          above us from being collected while we're compiling this function.  */
13931       if (nested)
13932         ggc_push_context ();
13933
13934       /* Run the optimizers and output the assembler code for this function.  */
13935       rest_of_compilation (fndecl);
13936
13937       /* Undo the GC context switch.  */
13938       if (nested)
13939         ggc_pop_context ();
13940     }
13941
13942   if (TREE_CODE (fndecl) != ERROR_MARK
13943       && !nested
13944       && DECL_SAVED_INSNS (fndecl) == 0)
13945     {
13946       /* Stop pointing to the local nodes about to be freed.  */
13947       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13948          function definition.  */
13949       /* For a nested function, this is done in pop_f_function_context.  */
13950       /* If rest_of_compilation set this to 0, leave it 0.  */
13951       if (DECL_INITIAL (fndecl) != 0)
13952         DECL_INITIAL (fndecl) = error_mark_node;
13953       DECL_ARGUMENTS (fndecl) = 0;
13954     }
13955
13956   if (!nested)
13957     {
13958       /* Let the error reporting routines know that we're outside a function.
13959          For a nested function, this value is used in pop_c_function_context
13960          and then reset via pop_function_context.  */
13961       ffecom_outer_function_decl_ = current_function_decl = NULL;
13962     }
13963 }
13964
13965 /* Plug-in replacement for identifying the name of a decl and, for a
13966    function, what we call it in diagnostics.  For now, "program unit"
13967    should suffice, since it's a bit of a hassle to figure out which
13968    of several kinds of things it is.  Note that it could conceivably
13969    be a statement function, which probably isn't really a program unit
13970    per se, but if that comes up, it should be easy to check (being a
13971    nested function and all).  */
13972
13973 static const char *
13974 lang_printable_name (tree decl, int v)
13975 {
13976   /* Just to keep GCC quiet about the unused variable.
13977      In theory, differing values of V should produce different
13978      output.  */
13979   switch (v)
13980     {
13981     default:
13982       if (TREE_CODE (decl) == ERROR_MARK)
13983         return "erroneous code";
13984       return IDENTIFIER_POINTER (DECL_NAME (decl));
13985     }
13986 }
13987
13988 /* g77's function to print out name of current function that caused
13989    an error.  */
13990
13991 #if BUILT_FOR_270
13992 static void
13993 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13994                            const char *file)
13995 {
13996   static ffeglobal last_g = NULL;
13997   static ffesymbol last_s = NULL;
13998   ffeglobal g;
13999   ffesymbol s;
14000   const char *kind;
14001
14002   if ((ffecom_primary_entry_ == NULL)
14003       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14004     {
14005       g = NULL;
14006       s = NULL;
14007       kind = NULL;
14008     }
14009   else
14010     {
14011       g = ffesymbol_global (ffecom_primary_entry_);
14012       if (ffecom_nested_entry_ == NULL)
14013         {
14014           s = ffecom_primary_entry_;
14015           switch (ffesymbol_kind (s))
14016             {
14017             case FFEINFO_kindFUNCTION:
14018               kind = "function";
14019               break;
14020
14021             case FFEINFO_kindSUBROUTINE:
14022               kind = "subroutine";
14023               break;
14024
14025             case FFEINFO_kindPROGRAM:
14026               kind = "program";
14027               break;
14028
14029             case FFEINFO_kindBLOCKDATA:
14030               kind = "block-data";
14031               break;
14032
14033             default:
14034               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14035               break;
14036             }
14037         }
14038       else
14039         {
14040           s = ffecom_nested_entry_;
14041           kind = "statement function";
14042         }
14043     }
14044
14045   if ((last_g != g) || (last_s != s))
14046     {
14047       if (file)
14048         fprintf (stderr, "%s: ", file);
14049
14050       if (s == NULL)
14051         fprintf (stderr, "Outside of any program unit:\n");
14052       else
14053         {
14054           const char *name = ffesymbol_text (s);
14055
14056           fprintf (stderr, "In %s `%s':\n", kind, name);
14057         }
14058
14059       last_g = g;
14060       last_s = s;
14061     }
14062 }
14063 #endif
14064
14065 /* Similar to `lookup_name' but look only at current binding level.  */
14066
14067 static tree
14068 lookup_name_current_level (tree name)
14069 {
14070   register tree t;
14071
14072   if (current_binding_level == global_binding_level)
14073     return IDENTIFIER_GLOBAL_VALUE (name);
14074
14075   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14076     return 0;
14077
14078   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14079     if (DECL_NAME (t) == name)
14080       break;
14081
14082   return t;
14083 }
14084
14085 /* Create a new `struct binding_level'.  */
14086
14087 static struct binding_level *
14088 make_binding_level ()
14089 {
14090   /* NOSTRICT */
14091   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14092 }
14093
14094 /* Save and restore the variables in this file and elsewhere
14095    that keep track of the progress of compilation of the current function.
14096    Used for nested functions.  */
14097
14098 struct f_function
14099 {
14100   struct f_function *next;
14101   tree named_labels;
14102   tree shadowed_labels;
14103   struct binding_level *binding_level;
14104 };
14105
14106 struct f_function *f_function_chain;
14107
14108 /* Restore the variables used during compilation of a C function.  */
14109
14110 static void
14111 pop_f_function_context ()
14112 {
14113   struct f_function *p = f_function_chain;
14114   tree link;
14115
14116   /* Bring back all the labels that were shadowed.  */
14117   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14118     if (DECL_NAME (TREE_VALUE (link)) != 0)
14119       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14120         = TREE_VALUE (link);
14121
14122   if (current_function_decl != error_mark_node
14123       && DECL_SAVED_INSNS (current_function_decl) == 0)
14124     {
14125       /* Stop pointing to the local nodes about to be freed.  */
14126       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14127          function definition.  */
14128       DECL_INITIAL (current_function_decl) = error_mark_node;
14129       DECL_ARGUMENTS (current_function_decl) = 0;
14130     }
14131
14132   pop_function_context ();
14133
14134   f_function_chain = p->next;
14135
14136   named_labels = p->named_labels;
14137   shadowed_labels = p->shadowed_labels;
14138   current_binding_level = p->binding_level;
14139
14140   free (p);
14141 }
14142
14143 /* Save and reinitialize the variables
14144    used during compilation of a C function.  */
14145
14146 static void
14147 push_f_function_context ()
14148 {
14149   struct f_function *p
14150   = (struct f_function *) xmalloc (sizeof (struct f_function));
14151
14152   push_function_context ();
14153
14154   p->next = f_function_chain;
14155   f_function_chain = p;
14156
14157   p->named_labels = named_labels;
14158   p->shadowed_labels = shadowed_labels;
14159   p->binding_level = current_binding_level;
14160 }
14161
14162 static void
14163 push_parm_decl (tree parm)
14164 {
14165   int old_immediate_size_expand = immediate_size_expand;
14166
14167   /* Don't try computing parm sizes now -- wait till fn is called.  */
14168
14169   immediate_size_expand = 0;
14170
14171   /* Fill in arg stuff.  */
14172
14173   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14174   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14175   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14176
14177   parm = pushdecl (parm);
14178
14179   immediate_size_expand = old_immediate_size_expand;
14180
14181   finish_decl (parm, NULL_TREE, FALSE);
14182 }
14183
14184 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14185
14186 static tree
14187 pushdecl_top_level (x)
14188      tree x;
14189 {
14190   register tree t;
14191   register struct binding_level *b = current_binding_level;
14192   register tree f = current_function_decl;
14193
14194   current_binding_level = global_binding_level;
14195   current_function_decl = NULL_TREE;
14196   t = pushdecl (x);
14197   current_binding_level = b;
14198   current_function_decl = f;
14199   return t;
14200 }
14201
14202 /* Store the list of declarations of the current level.
14203    This is done for the parameter declarations of a function being defined,
14204    after they are modified in the light of any missing parameters.  */
14205
14206 static tree
14207 storedecls (decls)
14208      tree decls;
14209 {
14210   return current_binding_level->names = decls;
14211 }
14212
14213 /* Store the parameter declarations into the current function declaration.
14214    This is called after parsing the parameter declarations, before
14215    digesting the body of the function.
14216
14217    For an old-style definition, modify the function's type
14218    to specify at least the number of arguments.  */
14219
14220 static void
14221 store_parm_decls (int is_main_program UNUSED)
14222 {
14223   register tree fndecl = current_function_decl;
14224
14225   if (fndecl == error_mark_node)
14226     return;
14227
14228   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14229   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14230
14231   /* Initialize the RTL code for the function.  */
14232
14233   init_function_start (fndecl, input_filename, lineno);
14234
14235   /* Set up parameters and prepare for return, for the function.  */
14236
14237   expand_function_start (fndecl, 0);
14238 }
14239
14240 static tree
14241 start_decl (tree decl, bool is_top_level)
14242 {
14243   register tree tem;
14244   bool at_top_level = (current_binding_level == global_binding_level);
14245   bool top_level = is_top_level || at_top_level;
14246
14247   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14248      level anyway.  */
14249   assert (!is_top_level || !at_top_level);
14250
14251   if (DECL_INITIAL (decl) != NULL_TREE)
14252     {
14253       assert (DECL_INITIAL (decl) == error_mark_node);
14254       assert (!DECL_EXTERNAL (decl));
14255     }
14256   else if (top_level)
14257     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14258
14259   /* For Fortran, we by default put things in .common when possible.  */
14260   DECL_COMMON (decl) = 1;
14261
14262   /* Add this decl to the current binding level. TEM may equal DECL or it may
14263      be a previous decl of the same name.  */
14264   if (is_top_level)
14265     tem = pushdecl_top_level (decl);
14266   else
14267     tem = pushdecl (decl);
14268
14269   /* For a local variable, define the RTL now.  */
14270   if (!top_level
14271   /* But not if this is a duplicate decl and we preserved the rtl from the
14272      previous one (which may or may not happen).  */
14273       && !DECL_RTL_SET_P (tem))
14274     {
14275       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14276         expand_decl (tem);
14277       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14278                && DECL_INITIAL (tem) != 0)
14279         expand_decl (tem);
14280     }
14281
14282   return tem;
14283 }
14284
14285 /* Create the FUNCTION_DECL for a function definition.
14286    DECLSPECS and DECLARATOR are the parts of the declaration;
14287    they describe the function's name and the type it returns,
14288    but twisted together in a fashion that parallels the syntax of C.
14289
14290    This function creates a binding context for the function body
14291    as well as setting up the FUNCTION_DECL in current_function_decl.
14292
14293    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14294    (it defines a datum instead), we return 0, which tells
14295    yyparse to report a parse error.
14296
14297    NESTED is nonzero for a function nested within another function.  */
14298
14299 static void
14300 start_function (tree name, tree type, int nested, int public)
14301 {
14302   tree decl1;
14303   tree restype;
14304   int old_immediate_size_expand = immediate_size_expand;
14305
14306   named_labels = 0;
14307   shadowed_labels = 0;
14308
14309   /* Don't expand any sizes in the return type of the function.  */
14310   immediate_size_expand = 0;
14311
14312   if (nested)
14313     {
14314       assert (!public);
14315       assert (current_function_decl != NULL_TREE);
14316       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14317     }
14318   else
14319     {
14320       assert (current_function_decl == NULL_TREE);
14321     }
14322
14323   if (TREE_CODE (type) == ERROR_MARK)
14324     decl1 = current_function_decl = error_mark_node;
14325   else
14326     {
14327       decl1 = build_decl (FUNCTION_DECL,
14328                           name,
14329                           type);
14330       TREE_PUBLIC (decl1) = public ? 1 : 0;
14331       if (nested)
14332         DECL_INLINE (decl1) = 1;
14333       TREE_STATIC (decl1) = 1;
14334       DECL_EXTERNAL (decl1) = 0;
14335
14336       announce_function (decl1);
14337
14338       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14339          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14340       DECL_INITIAL (decl1) = error_mark_node;
14341
14342       /* Record the decl so that the function name is defined. If we already have
14343          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14344
14345       current_function_decl = pushdecl (decl1);
14346     }
14347
14348   if (!nested)
14349     ffecom_outer_function_decl_ = current_function_decl;
14350
14351   pushlevel (0);
14352   current_binding_level->prep_state = 2;
14353
14354   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14355     {
14356       make_decl_rtl (current_function_decl, NULL);
14357
14358       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14359       DECL_RESULT (current_function_decl)
14360         = build_decl (RESULT_DECL, NULL_TREE, restype);
14361     }
14362
14363   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14364     TREE_ADDRESSABLE (current_function_decl) = 1;
14365
14366   immediate_size_expand = old_immediate_size_expand;
14367 }
14368 \f
14369 /* Here are the public functions the GNU back end needs.  */
14370
14371 tree
14372 convert (type, expr)
14373      tree type, expr;
14374 {
14375   register tree e = expr;
14376   register enum tree_code code = TREE_CODE (type);
14377
14378   if (type == TREE_TYPE (e)
14379       || TREE_CODE (e) == ERROR_MARK)
14380     return e;
14381   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14382     return fold (build1 (NOP_EXPR, type, e));
14383   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14384       || code == ERROR_MARK)
14385     return error_mark_node;
14386   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14387     {
14388       assert ("void value not ignored as it ought to be" == NULL);
14389       return error_mark_node;
14390     }
14391   if (code == VOID_TYPE)
14392     return build1 (CONVERT_EXPR, type, e);
14393   if ((code != RECORD_TYPE)
14394       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14395     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14396                   e);
14397   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14398     return fold (convert_to_integer (type, e));
14399   if (code == POINTER_TYPE)
14400     return fold (convert_to_pointer (type, e));
14401   if (code == REAL_TYPE)
14402     return fold (convert_to_real (type, e));
14403   if (code == COMPLEX_TYPE)
14404     return fold (convert_to_complex (type, e));
14405   if (code == RECORD_TYPE)
14406     return fold (ffecom_convert_to_complex_ (type, e));
14407
14408   assert ("conversion to non-scalar type requested" == NULL);
14409   return error_mark_node;
14410 }
14411
14412 /* integrate_decl_tree calls this function, but since we don't use the
14413    DECL_LANG_SPECIFIC field, this is a no-op.  */
14414
14415 void
14416 copy_lang_decl (node)
14417      tree node UNUSED;
14418 {
14419 }
14420
14421 /* Return the list of declarations of the current level.
14422    Note that this list is in reverse order unless/until
14423    you nreverse it; and when you do nreverse it, you must
14424    store the result back using `storedecls' or you will lose.  */
14425
14426 tree
14427 getdecls ()
14428 {
14429   return current_binding_level->names;
14430 }
14431
14432 /* Nonzero if we are currently in the global binding level.  */
14433
14434 int
14435 global_bindings_p ()
14436 {
14437   return current_binding_level == global_binding_level;
14438 }
14439
14440 /* Print an error message for invalid use of an incomplete type.
14441    VALUE is the expression that was used (or 0 if that isn't known)
14442    and TYPE is the type that was invalid.  */
14443
14444 void
14445 incomplete_type_error (value, type)
14446      tree value UNUSED;
14447      tree type;
14448 {
14449   if (TREE_CODE (type) == ERROR_MARK)
14450     return;
14451
14452   assert ("incomplete type?!?" == NULL);
14453 }
14454
14455 /* Mark ARG for GC.  */
14456 static void
14457 mark_binding_level (void *arg)
14458 {
14459   struct binding_level *level = *(struct binding_level **) arg;
14460
14461   while (level)
14462     {
14463       ggc_mark_tree (level->names);
14464       ggc_mark_tree (level->blocks);
14465       ggc_mark_tree (level->this_block);
14466       level = level->level_chain;
14467     }
14468 }
14469
14470 void
14471 init_decl_processing ()
14472 {
14473   static tree *const tree_roots[] = {
14474     &current_function_decl,
14475     &string_type_node,
14476     &ffecom_tree_fun_type_void,
14477     &ffecom_integer_zero_node,
14478     &ffecom_integer_one_node,
14479     &ffecom_tree_subr_type,
14480     &ffecom_tree_ptr_to_subr_type,
14481     &ffecom_tree_blockdata_type,
14482     &ffecom_tree_xargc_,
14483     &ffecom_f2c_integer_type_node,
14484     &ffecom_f2c_ptr_to_integer_type_node,
14485     &ffecom_f2c_address_type_node,
14486     &ffecom_f2c_real_type_node,
14487     &ffecom_f2c_ptr_to_real_type_node,
14488     &ffecom_f2c_doublereal_type_node,
14489     &ffecom_f2c_complex_type_node,
14490     &ffecom_f2c_doublecomplex_type_node,
14491     &ffecom_f2c_longint_type_node,
14492     &ffecom_f2c_logical_type_node,
14493     &ffecom_f2c_flag_type_node,
14494     &ffecom_f2c_ftnlen_type_node,
14495     &ffecom_f2c_ftnlen_zero_node,
14496     &ffecom_f2c_ftnlen_one_node,
14497     &ffecom_f2c_ftnlen_two_node,
14498     &ffecom_f2c_ptr_to_ftnlen_type_node,
14499     &ffecom_f2c_ftnint_type_node,
14500     &ffecom_f2c_ptr_to_ftnint_type_node,
14501     &ffecom_outer_function_decl_,
14502     &ffecom_previous_function_decl_,
14503     &ffecom_which_entrypoint_decl_,
14504     &ffecom_float_zero_,
14505     &ffecom_float_half_,
14506     &ffecom_double_zero_,
14507     &ffecom_double_half_,
14508     &ffecom_func_result_,
14509     &ffecom_func_length_,
14510     &ffecom_multi_type_node_,
14511     &ffecom_multi_retval_,
14512     &named_labels,
14513     &shadowed_labels
14514   };
14515   size_t i;
14516
14517   malloc_init ();
14518
14519   /* Record our roots.  */
14520   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14521     ggc_add_tree_root (tree_roots[i], 1);
14522   ggc_add_tree_root (&ffecom_tree_type[0][0],
14523                      FFEINFO_basictype*FFEINFO_kindtype);
14524   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14525                      FFEINFO_basictype*FFEINFO_kindtype);
14526   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14527                      FFEINFO_basictype*FFEINFO_kindtype);
14528   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14529   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14530                 mark_binding_level);
14531   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14532                 mark_binding_level);
14533   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14534
14535   ffe_init_0 ();
14536 }
14537
14538 const char *
14539 init_parse (filename)
14540      const char *filename;
14541 {
14542   /* Open input file.  */
14543   if (filename == 0 || !strcmp (filename, "-"))
14544     {
14545       finput = stdin;
14546       filename = "stdin";
14547     }
14548   else
14549     finput = fopen (filename, "r");
14550   if (finput == 0)
14551     fatal_io_error ("can't open %s", filename);
14552
14553 #ifdef IO_BUFFER_SIZE
14554   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14555 #endif
14556
14557   /* Make identifier nodes long enough for the language-specific slots.  */
14558   set_identifier_size (sizeof (struct lang_identifier));
14559   decl_printable_name = lang_printable_name;
14560 #if BUILT_FOR_270
14561   print_error_function = lang_print_error_function;
14562 #endif
14563
14564   return filename;
14565 }
14566
14567 void
14568 finish_parse ()
14569 {
14570   fclose (finput);
14571 }
14572
14573 /* Delete the node BLOCK from the current binding level.
14574    This is used for the block inside a stmt expr ({...})
14575    so that the block can be reinserted where appropriate.  */
14576
14577 static void
14578 delete_block (block)
14579      tree block;
14580 {
14581   tree t;
14582   if (current_binding_level->blocks == block)
14583     current_binding_level->blocks = TREE_CHAIN (block);
14584   for (t = current_binding_level->blocks; t;)
14585     {
14586       if (TREE_CHAIN (t) == block)
14587         TREE_CHAIN (t) = TREE_CHAIN (block);
14588       else
14589         t = TREE_CHAIN (t);
14590     }
14591   TREE_CHAIN (block) = NULL;
14592   /* Clear TREE_USED which is always set by poplevel.
14593      The flag is set again if insert_block is called.  */
14594   TREE_USED (block) = 0;
14595 }
14596
14597 void
14598 insert_block (block)
14599      tree block;
14600 {
14601   TREE_USED (block) = 1;
14602   current_binding_level->blocks
14603     = chainon (current_binding_level->blocks, block);
14604 }
14605
14606 /* Each front end provides its own.  */
14607 static void ffe_init PARAMS ((void));
14608 static void ffe_finish PARAMS ((void));
14609 static void ffe_init_options PARAMS ((void));
14610
14611 struct lang_hooks lang_hooks = {ffe_init,
14612                                 ffe_finish,
14613                                 ffe_init_options,
14614                                 ffe_decode_option,
14615                                 NULL /* post_options */};
14616
14617 /* used by print-tree.c */
14618
14619 void
14620 lang_print_xnode (file, node, indent)
14621      FILE *file UNUSED;
14622      tree node UNUSED;
14623      int indent UNUSED;
14624 {
14625 }
14626
14627 static void
14628 ffe_finish ()
14629 {
14630   ffe_terminate_0 ();
14631
14632   if (ffe_is_ffedebug ())
14633     malloc_pool_display (malloc_pool_image ());
14634 }
14635
14636 const char *
14637 lang_identify ()
14638 {
14639   return "f77";
14640 }
14641
14642 /* Return the typed-based alias set for T, which may be an expression
14643    or a type.  Return -1 if we don't do anything special.  */
14644
14645 HOST_WIDE_INT
14646 lang_get_alias_set (t)
14647      tree t ATTRIBUTE_UNUSED;
14648 {
14649   /* We do not wish to use alias-set based aliasing at all.  Used in the
14650      extreme (every object with its own set, with equivalences recorded)
14651      it might be helpful, but there are problems when it comes to inlining.
14652      We get on ok with flag_argument_noalias, and alias-set aliasing does
14653      currently limit how stack slots can be reused, which is a lose.  */
14654   return 0;
14655 }
14656
14657 static void
14658 ffe_init_options ()
14659 {
14660   /* Set default options for Fortran.  */
14661   flag_move_all_movables = 1;
14662   flag_reduce_all_givs = 1;
14663   flag_argument_noalias = 2;
14664   flag_errno_math = 0;
14665   flag_complex_divide_method = 1;
14666 }
14667
14668 static void
14669 ffe_init ()
14670 {
14671   /* If the file is output from cpp, it should contain a first line
14672      `# 1 "real-filename"', and the current design of gcc (toplev.c
14673      in particular and the way it sets up information relied on by
14674      INCLUDE) requires that we read this now, and store the
14675      "real-filename" info in master_input_filename.  Ask the lexer
14676      to try doing this.  */
14677   ffelex_hash_kludge (finput);
14678 }
14679
14680 int
14681 mark_addressable (exp)
14682      tree exp;
14683 {
14684   register tree x = exp;
14685   while (1)
14686     switch (TREE_CODE (x))
14687       {
14688       case ADDR_EXPR:
14689       case COMPONENT_REF:
14690       case ARRAY_REF:
14691         x = TREE_OPERAND (x, 0);
14692         break;
14693
14694       case CONSTRUCTOR:
14695         TREE_ADDRESSABLE (x) = 1;
14696         return 1;
14697
14698       case VAR_DECL:
14699       case CONST_DECL:
14700       case PARM_DECL:
14701       case RESULT_DECL:
14702         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14703             && DECL_NONLOCAL (x))
14704           {
14705             if (TREE_PUBLIC (x))
14706               {
14707                 assert ("address of global register var requested" == NULL);
14708                 return 0;
14709               }
14710             assert ("address of register variable requested" == NULL);
14711           }
14712         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14713           {
14714             if (TREE_PUBLIC (x))
14715               {
14716                 assert ("address of global register var requested" == NULL);
14717                 return 0;
14718               }
14719             assert ("address of register var requested" == NULL);
14720           }
14721         put_var_into_stack (x);
14722
14723         /* drops in */
14724       case FUNCTION_DECL:
14725         TREE_ADDRESSABLE (x) = 1;
14726 #if 0                           /* poplevel deals with this now.  */
14727         if (DECL_CONTEXT (x) == 0)
14728           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14729 #endif
14730
14731       default:
14732         return 1;
14733       }
14734 }
14735
14736 /* If DECL has a cleanup, build and return that cleanup here.
14737    This is a callback called by expand_expr.  */
14738
14739 tree
14740 maybe_build_cleanup (decl)
14741      tree decl UNUSED;
14742 {
14743   /* There are no cleanups in Fortran.  */
14744   return NULL_TREE;
14745 }
14746
14747 /* Exit a binding level.
14748    Pop the level off, and restore the state of the identifier-decl mappings
14749    that were in effect when this level was entered.
14750
14751    If KEEP is nonzero, this level had explicit declarations, so
14752    and create a "block" (a BLOCK node) for the level
14753    to record its declarations and subblocks for symbol table output.
14754
14755    If FUNCTIONBODY is nonzero, this level is the body of a function,
14756    so create a block as if KEEP were set and also clear out all
14757    label names.
14758
14759    If REVERSE is nonzero, reverse the order of decls before putting
14760    them into the BLOCK.  */
14761
14762 tree
14763 poplevel (keep, reverse, functionbody)
14764      int keep;
14765      int reverse;
14766      int functionbody;
14767 {
14768   register tree link;
14769   /* The chain of decls was accumulated in reverse order.
14770      Put it into forward order, just for cleanliness.  */
14771   tree decls;
14772   tree subblocks = current_binding_level->blocks;
14773   tree block = 0;
14774   tree decl;
14775   int block_previously_created;
14776
14777   /* Get the decls in the order they were written.
14778      Usually current_binding_level->names is in reverse order.
14779      But parameter decls were previously put in forward order.  */
14780
14781   if (reverse)
14782     current_binding_level->names
14783       = decls = nreverse (current_binding_level->names);
14784   else
14785     decls = current_binding_level->names;
14786
14787   /* Output any nested inline functions within this block
14788      if they weren't already output.  */
14789
14790   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14791     if (TREE_CODE (decl) == FUNCTION_DECL
14792         && ! TREE_ASM_WRITTEN (decl)
14793         && DECL_INITIAL (decl) != 0
14794         && TREE_ADDRESSABLE (decl))
14795       {
14796         /* If this decl was copied from a file-scope decl
14797            on account of a block-scope extern decl,
14798            propagate TREE_ADDRESSABLE to the file-scope decl.
14799
14800            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14801            true, since then the decl goes through save_for_inline_copying.  */
14802         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14803             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14804           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14805         else if (DECL_SAVED_INSNS (decl) != 0)
14806           {
14807             push_function_context ();
14808             output_inline_function (decl);
14809             pop_function_context ();
14810           }
14811       }
14812
14813   /* If there were any declarations or structure tags in that level,
14814      or if this level is a function body,
14815      create a BLOCK to record them for the life of this function.  */
14816
14817   block = 0;
14818   block_previously_created = (current_binding_level->this_block != 0);
14819   if (block_previously_created)
14820     block = current_binding_level->this_block;
14821   else if (keep || functionbody)
14822     block = make_node (BLOCK);
14823   if (block != 0)
14824     {
14825       BLOCK_VARS (block) = decls;
14826       BLOCK_SUBBLOCKS (block) = subblocks;
14827     }
14828
14829   /* In each subblock, record that this is its superior.  */
14830
14831   for (link = subblocks; link; link = TREE_CHAIN (link))
14832     BLOCK_SUPERCONTEXT (link) = block;
14833
14834   /* Clear out the meanings of the local variables of this level.  */
14835
14836   for (link = decls; link; link = TREE_CHAIN (link))
14837     {
14838       if (DECL_NAME (link) != 0)
14839         {
14840           /* If the ident. was used or addressed via a local extern decl,
14841              don't forget that fact.  */
14842           if (DECL_EXTERNAL (link))
14843             {
14844               if (TREE_USED (link))
14845                 TREE_USED (DECL_NAME (link)) = 1;
14846               if (TREE_ADDRESSABLE (link))
14847                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14848             }
14849           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14850         }
14851     }
14852
14853   /* If the level being exited is the top level of a function,
14854      check over all the labels, and clear out the current
14855      (function local) meanings of their names.  */
14856
14857   if (functionbody)
14858     {
14859       /* If this is the top level block of a function,
14860          the vars are the function's parameters.
14861          Don't leave them in the BLOCK because they are
14862          found in the FUNCTION_DECL instead.  */
14863
14864       BLOCK_VARS (block) = 0;
14865     }
14866
14867   /* Pop the current level, and free the structure for reuse.  */
14868
14869   {
14870     register struct binding_level *level = current_binding_level;
14871     current_binding_level = current_binding_level->level_chain;
14872
14873     level->level_chain = free_binding_level;
14874     free_binding_level = level;
14875   }
14876
14877   /* Dispose of the block that we just made inside some higher level.  */
14878   if (functionbody
14879       && current_function_decl != error_mark_node)
14880     DECL_INITIAL (current_function_decl) = block;
14881   else if (block)
14882     {
14883       if (!block_previously_created)
14884         current_binding_level->blocks
14885           = chainon (current_binding_level->blocks, block);
14886     }
14887   /* If we did not make a block for the level just exited,
14888      any blocks made for inner levels
14889      (since they cannot be recorded as subblocks in that level)
14890      must be carried forward so they will later become subblocks
14891      of something else.  */
14892   else if (subblocks)
14893     current_binding_level->blocks
14894       = chainon (current_binding_level->blocks, subblocks);
14895
14896   if (block)
14897     TREE_USED (block) = 1;
14898   return block;
14899 }
14900
14901 void
14902 print_lang_decl (file, node, indent)
14903      FILE *file UNUSED;
14904      tree node UNUSED;
14905      int indent UNUSED;
14906 {
14907 }
14908
14909 void
14910 print_lang_identifier (file, node, indent)
14911      FILE *file;
14912      tree node;
14913      int indent;
14914 {
14915   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14916   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14917 }
14918
14919 void
14920 print_lang_statistics ()
14921 {
14922 }
14923
14924 void
14925 print_lang_type (file, node, indent)
14926      FILE *file UNUSED;
14927      tree node UNUSED;
14928      int indent UNUSED;
14929 {
14930 }
14931
14932 /* Record a decl-node X as belonging to the current lexical scope.
14933    Check for errors (such as an incompatible declaration for the same
14934    name already seen in the same scope).
14935
14936    Returns either X or an old decl for the same name.
14937    If an old decl is returned, it may have been smashed
14938    to agree with what X says.  */
14939
14940 tree
14941 pushdecl (x)
14942      tree x;
14943 {
14944   register tree t;
14945   register tree name = DECL_NAME (x);
14946   register struct binding_level *b = current_binding_level;
14947
14948   if ((TREE_CODE (x) == FUNCTION_DECL)
14949       && (DECL_INITIAL (x) == 0)
14950       && DECL_EXTERNAL (x))
14951     DECL_CONTEXT (x) = NULL_TREE;
14952   else
14953     DECL_CONTEXT (x) = current_function_decl;
14954
14955   if (name)
14956     {
14957       if (IDENTIFIER_INVENTED (name))
14958         {
14959 #if BUILT_FOR_270
14960           DECL_ARTIFICIAL (x) = 1;
14961 #endif
14962           DECL_IN_SYSTEM_HEADER (x) = 1;
14963         }
14964
14965       t = lookup_name_current_level (name);
14966
14967       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14968
14969       /* Don't push non-parms onto list for parms until we understand
14970          why we're doing this and whether it works.  */
14971
14972       assert ((b == global_binding_level)
14973               || !ffecom_transform_only_dummies_
14974               || TREE_CODE (x) == PARM_DECL);
14975
14976       if ((t != NULL_TREE) && duplicate_decls (x, t))
14977         return t;
14978
14979       /* If we are processing a typedef statement, generate a whole new
14980          ..._TYPE node (which will be just an variant of the existing
14981          ..._TYPE node with identical properties) and then install the
14982          TYPE_DECL node generated to represent the typedef name as the
14983          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14984
14985          The whole point here is to end up with a situation where each and every
14986          ..._TYPE node the compiler creates will be uniquely associated with
14987          AT MOST one node representing a typedef name. This way, even though
14988          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14989          (i.e. "typedef name") nodes very early on, later parts of the
14990          compiler can always do the reverse translation and get back the
14991          corresponding typedef name.  For example, given:
14992
14993          typedef struct S MY_TYPE; MY_TYPE object;
14994
14995          Later parts of the compiler might only know that `object' was of type
14996          `struct S' if it were not for code just below.  With this code
14997          however, later parts of the compiler see something like:
14998
14999          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15000
15001          And they can then deduce (from the node for type struct S') that the
15002          original object declaration was:
15003
15004          MY_TYPE object;
15005
15006          Being able to do this is important for proper support of protoize, and
15007          also for generating precise symbolic debugging information which
15008          takes full account of the programmer's (typedef) vocabulary.
15009
15010          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15011          TYPE_DECL node that we are now processing really represents a
15012          standard built-in type.
15013
15014          Since all standard types are effectively declared at line zero in the
15015          source file, we can easily check to see if we are working on a
15016          standard type by checking the current value of lineno.  */
15017
15018       if (TREE_CODE (x) == TYPE_DECL)
15019         {
15020           if (DECL_SOURCE_LINE (x) == 0)
15021             {
15022               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15023                 TYPE_NAME (TREE_TYPE (x)) = x;
15024             }
15025           else if (TREE_TYPE (x) != error_mark_node)
15026             {
15027               tree tt = TREE_TYPE (x);
15028
15029               tt = build_type_copy (tt);
15030               TYPE_NAME (tt) = x;
15031               TREE_TYPE (x) = tt;
15032             }
15033         }
15034
15035       /* This name is new in its binding level. Install the new declaration
15036          and return it.  */
15037       if (b == global_binding_level)
15038         IDENTIFIER_GLOBAL_VALUE (name) = x;
15039       else
15040         IDENTIFIER_LOCAL_VALUE (name) = x;
15041     }
15042
15043   /* Put decls on list in reverse order. We will reverse them later if
15044      necessary.  */
15045   TREE_CHAIN (x) = b->names;
15046   b->names = x;
15047
15048   return x;
15049 }
15050
15051 /* Nonzero if the current level needs to have a BLOCK made.  */
15052
15053 static int
15054 kept_level_p ()
15055 {
15056   tree decl;
15057
15058   for (decl = current_binding_level->names;
15059        decl;
15060        decl = TREE_CHAIN (decl))
15061     {
15062       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15063           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15064         /* Currently, there aren't supposed to be non-artificial names
15065            at other than the top block for a function -- they're
15066            believed to always be temps.  But it's wise to check anyway.  */
15067         return 1;
15068     }
15069   return 0;
15070 }
15071
15072 /* Enter a new binding level.
15073    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15074    not for that of tags.  */
15075
15076 void
15077 pushlevel (tag_transparent)
15078      int tag_transparent;
15079 {
15080   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15081
15082   assert (! tag_transparent);
15083
15084   if (current_binding_level == global_binding_level)
15085     {
15086       named_labels = 0;
15087     }
15088
15089   /* Reuse or create a struct for this binding level.  */
15090
15091   if (free_binding_level)
15092     {
15093       newlevel = free_binding_level;
15094       free_binding_level = free_binding_level->level_chain;
15095     }
15096   else
15097     {
15098       newlevel = make_binding_level ();
15099     }
15100
15101   /* Add this level to the front of the chain (stack) of levels that
15102      are active.  */
15103
15104   *newlevel = clear_binding_level;
15105   newlevel->level_chain = current_binding_level;
15106   current_binding_level = newlevel;
15107 }
15108
15109 /* Set the BLOCK node for the innermost scope
15110    (the one we are currently in).  */
15111
15112 void
15113 set_block (block)
15114      register tree block;
15115 {
15116   current_binding_level->this_block = block;
15117   current_binding_level->names = chainon (current_binding_level->names,
15118                                           BLOCK_VARS (block));
15119   current_binding_level->blocks = chainon (current_binding_level->blocks,
15120                                            BLOCK_SUBBLOCKS (block));
15121 }
15122
15123 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15124
15125 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15126
15127 void
15128 set_yydebug (value)
15129      int value;
15130 {
15131   if (value)
15132     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15133 }
15134
15135 tree
15136 signed_or_unsigned_type (unsignedp, type)
15137      int unsignedp;
15138      tree type;
15139 {
15140   tree type2;
15141
15142   if (! INTEGRAL_TYPE_P (type))
15143     return type;
15144   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15145     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15146   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15147     return unsignedp ? unsigned_type_node : integer_type_node;
15148   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15149     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15150   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15151     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15152   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15153     return (unsignedp ? long_long_unsigned_type_node
15154             : long_long_integer_type_node);
15155
15156   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15157   if (type2 == NULL_TREE)
15158     return type;
15159
15160   return type2;
15161 }
15162
15163 tree
15164 signed_type (type)
15165      tree type;
15166 {
15167   tree type1 = TYPE_MAIN_VARIANT (type);
15168   ffeinfoKindtype kt;
15169   tree type2;
15170
15171   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15172     return signed_char_type_node;
15173   if (type1 == unsigned_type_node)
15174     return integer_type_node;
15175   if (type1 == short_unsigned_type_node)
15176     return short_integer_type_node;
15177   if (type1 == long_unsigned_type_node)
15178     return long_integer_type_node;
15179   if (type1 == long_long_unsigned_type_node)
15180     return long_long_integer_type_node;
15181 #if 0   /* gcc/c-* files only */
15182   if (type1 == unsigned_intDI_type_node)
15183     return intDI_type_node;
15184   if (type1 == unsigned_intSI_type_node)
15185     return intSI_type_node;
15186   if (type1 == unsigned_intHI_type_node)
15187     return intHI_type_node;
15188   if (type1 == unsigned_intQI_type_node)
15189     return intQI_type_node;
15190 #endif
15191
15192   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15193   if (type2 != NULL_TREE)
15194     return type2;
15195
15196   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15197     {
15198       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15199
15200       if (type1 == type2)
15201         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15202     }
15203
15204   return type;
15205 }
15206
15207 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15208    or validate its data type for an `if' or `while' statement or ?..: exp.
15209
15210    This preparation consists of taking the ordinary
15211    representation of an expression expr and producing a valid tree
15212    boolean expression describing whether expr is nonzero.  We could
15213    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15214    but we optimize comparisons, &&, ||, and !.
15215
15216    The resulting type should always be `integer_type_node'.  */
15217
15218 tree
15219 truthvalue_conversion (expr)
15220      tree expr;
15221 {
15222   if (TREE_CODE (expr) == ERROR_MARK)
15223     return expr;
15224
15225 #if 0 /* This appears to be wrong for C++.  */
15226   /* These really should return error_mark_node after 2.4 is stable.
15227      But not all callers handle ERROR_MARK properly.  */
15228   switch (TREE_CODE (TREE_TYPE (expr)))
15229     {
15230     case RECORD_TYPE:
15231       error ("struct type value used where scalar is required");
15232       return integer_zero_node;
15233
15234     case UNION_TYPE:
15235       error ("union type value used where scalar is required");
15236       return integer_zero_node;
15237
15238     case ARRAY_TYPE:
15239       error ("array type value used where scalar is required");
15240       return integer_zero_node;
15241
15242     default:
15243       break;
15244     }
15245 #endif /* 0 */
15246
15247   switch (TREE_CODE (expr))
15248     {
15249       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15250          or comparison expressions as truth values at this level.  */
15251 #if 0
15252     case COMPONENT_REF:
15253       /* A one-bit unsigned bit-field is already acceptable.  */
15254       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15255           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15256         return expr;
15257       break;
15258 #endif
15259
15260     case EQ_EXPR:
15261       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15262          or comparison expressions as truth values at this level.  */
15263 #if 0
15264       if (integer_zerop (TREE_OPERAND (expr, 1)))
15265         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15266 #endif
15267     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15268     case TRUTH_ANDIF_EXPR:
15269     case TRUTH_ORIF_EXPR:
15270     case TRUTH_AND_EXPR:
15271     case TRUTH_OR_EXPR:
15272     case TRUTH_XOR_EXPR:
15273       TREE_TYPE (expr) = integer_type_node;
15274       return expr;
15275
15276     case ERROR_MARK:
15277       return expr;
15278
15279     case INTEGER_CST:
15280       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15281
15282     case REAL_CST:
15283       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15284
15285     case ADDR_EXPR:
15286       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15287         return build (COMPOUND_EXPR, integer_type_node,
15288                       TREE_OPERAND (expr, 0), integer_one_node);
15289       else
15290         return integer_one_node;
15291
15292     case COMPLEX_EXPR:
15293       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15294                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15295                        integer_type_node,
15296                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15297                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15298
15299     case NEGATE_EXPR:
15300     case ABS_EXPR:
15301     case FLOAT_EXPR:
15302     case FFS_EXPR:
15303       /* These don't change whether an object is non-zero or zero.  */
15304       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15305
15306     case LROTATE_EXPR:
15307     case RROTATE_EXPR:
15308       /* These don't change whether an object is zero or non-zero, but
15309          we can't ignore them if their second arg has side-effects.  */
15310       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15311         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15312                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15313       else
15314         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15315
15316     case COND_EXPR:
15317       /* Distribute the conversion into the arms of a COND_EXPR.  */
15318       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15319                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15320                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15321
15322     case CONVERT_EXPR:
15323       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15324          since that affects how `default_conversion' will behave.  */
15325       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15326           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15327         break;
15328       /* fall through... */
15329     case NOP_EXPR:
15330       /* If this is widening the argument, we can ignore it.  */
15331       if (TYPE_PRECISION (TREE_TYPE (expr))
15332           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15333         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15334       break;
15335
15336     case MINUS_EXPR:
15337       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15338          this case.  */
15339       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15340           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15341         break;
15342       /* fall through... */
15343     case BIT_XOR_EXPR:
15344       /* This and MINUS_EXPR can be changed into a comparison of the
15345          two objects.  */
15346       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15347           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15348         return ffecom_2 (NE_EXPR, integer_type_node,
15349                          TREE_OPERAND (expr, 0),
15350                          TREE_OPERAND (expr, 1));
15351       return ffecom_2 (NE_EXPR, integer_type_node,
15352                        TREE_OPERAND (expr, 0),
15353                        fold (build1 (NOP_EXPR,
15354                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15355                                      TREE_OPERAND (expr, 1))));
15356
15357     case BIT_AND_EXPR:
15358       if (integer_onep (TREE_OPERAND (expr, 1)))
15359         return expr;
15360       break;
15361
15362     case MODIFY_EXPR:
15363 #if 0                           /* No such thing in Fortran. */
15364       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15365         warning ("suggest parentheses around assignment used as truth value");
15366 #endif
15367       break;
15368
15369     default:
15370       break;
15371     }
15372
15373   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15374     return (ffecom_2
15375             ((TREE_SIDE_EFFECTS (expr)
15376               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15377              integer_type_node,
15378              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15379                                               TREE_TYPE (TREE_TYPE (expr)),
15380                                               expr)),
15381              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15382                                               TREE_TYPE (TREE_TYPE (expr)),
15383                                               expr))));
15384
15385   return ffecom_2 (NE_EXPR, integer_type_node,
15386                    expr,
15387                    convert (TREE_TYPE (expr), integer_zero_node));
15388 }
15389
15390 tree
15391 type_for_mode (mode, unsignedp)
15392      enum machine_mode mode;
15393      int unsignedp;
15394 {
15395   int i;
15396   int j;
15397   tree t;
15398
15399   if (mode == TYPE_MODE (integer_type_node))
15400     return unsignedp ? unsigned_type_node : integer_type_node;
15401
15402   if (mode == TYPE_MODE (signed_char_type_node))
15403     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15404
15405   if (mode == TYPE_MODE (short_integer_type_node))
15406     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15407
15408   if (mode == TYPE_MODE (long_integer_type_node))
15409     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15410
15411   if (mode == TYPE_MODE (long_long_integer_type_node))
15412     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15413
15414 #if HOST_BITS_PER_WIDE_INT >= 64
15415   if (mode == TYPE_MODE (intTI_type_node))
15416     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15417 #endif
15418
15419   if (mode == TYPE_MODE (float_type_node))
15420     return float_type_node;
15421
15422   if (mode == TYPE_MODE (double_type_node))
15423     return double_type_node;
15424
15425   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15426     return build_pointer_type (char_type_node);
15427
15428   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15429     return build_pointer_type (integer_type_node);
15430
15431   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15432     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15433       {
15434         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15435             && (mode == TYPE_MODE (t)))
15436           {
15437             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15438               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15439             else
15440               return t;
15441           }
15442       }
15443
15444   return 0;
15445 }
15446
15447 tree
15448 type_for_size (bits, unsignedp)
15449      unsigned bits;
15450      int unsignedp;
15451 {
15452   ffeinfoKindtype kt;
15453   tree type_node;
15454
15455   if (bits == TYPE_PRECISION (integer_type_node))
15456     return unsignedp ? unsigned_type_node : integer_type_node;
15457
15458   if (bits == TYPE_PRECISION (signed_char_type_node))
15459     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15460
15461   if (bits == TYPE_PRECISION (short_integer_type_node))
15462     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15463
15464   if (bits == TYPE_PRECISION (long_integer_type_node))
15465     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15466
15467   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15468     return (unsignedp ? long_long_unsigned_type_node
15469             : long_long_integer_type_node);
15470
15471   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15472     {
15473       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15474
15475       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15476         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15477           : type_node;
15478     }
15479
15480   return 0;
15481 }
15482
15483 tree
15484 unsigned_type (type)
15485      tree type;
15486 {
15487   tree type1 = TYPE_MAIN_VARIANT (type);
15488   ffeinfoKindtype kt;
15489   tree type2;
15490
15491   if (type1 == signed_char_type_node || type1 == char_type_node)
15492     return unsigned_char_type_node;
15493   if (type1 == integer_type_node)
15494     return unsigned_type_node;
15495   if (type1 == short_integer_type_node)
15496     return short_unsigned_type_node;
15497   if (type1 == long_integer_type_node)
15498     return long_unsigned_type_node;
15499   if (type1 == long_long_integer_type_node)
15500     return long_long_unsigned_type_node;
15501 #if 0   /* gcc/c-* files only */
15502   if (type1 == intDI_type_node)
15503     return unsigned_intDI_type_node;
15504   if (type1 == intSI_type_node)
15505     return unsigned_intSI_type_node;
15506   if (type1 == intHI_type_node)
15507     return unsigned_intHI_type_node;
15508   if (type1 == intQI_type_node)
15509     return unsigned_intQI_type_node;
15510 #endif
15511
15512   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15513   if (type2 != NULL_TREE)
15514     return type2;
15515
15516   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15517     {
15518       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15519
15520       if (type1 == type2)
15521         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15522     }
15523
15524   return type;
15525 }
15526
15527 void
15528 lang_mark_tree (t)
15529      union tree_node *t ATTRIBUTE_UNUSED;
15530 {
15531   if (TREE_CODE (t) == IDENTIFIER_NODE)
15532     {
15533       struct lang_identifier *i = (struct lang_identifier *) t;
15534       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15535       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15536       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15537     }
15538   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15539     ggc_mark (TYPE_LANG_SPECIFIC (t));
15540 }
15541
15542 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15543 \f
15544 #if FFECOM_GCC_INCLUDE
15545
15546 /* From gcc/cccp.c, the code to handle -I.  */
15547
15548 /* Skip leading "./" from a directory name.
15549    This may yield the empty string, which represents the current directory.  */
15550
15551 static const char *
15552 skip_redundant_dir_prefix (const char *dir)
15553 {
15554   while (dir[0] == '.' && dir[1] == '/')
15555     for (dir += 2; *dir == '/'; dir++)
15556       continue;
15557   if (dir[0] == '.' && !dir[1])
15558     dir++;
15559   return dir;
15560 }
15561
15562 /* The file_name_map structure holds a mapping of file names for a
15563    particular directory.  This mapping is read from the file named
15564    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15565    map filenames on a file system with severe filename restrictions,
15566    such as DOS.  The format of the file name map file is just a series
15567    of lines with two tokens on each line.  The first token is the name
15568    to map, and the second token is the actual name to use.  */
15569
15570 struct file_name_map
15571 {
15572   struct file_name_map *map_next;
15573   char *map_from;
15574   char *map_to;
15575 };
15576
15577 #define FILE_NAME_MAP_FILE "header.gcc"
15578
15579 /* Current maximum length of directory names in the search path
15580    for include files.  (Altered as we get more of them.)  */
15581
15582 static int max_include_len = 0;
15583
15584 struct file_name_list
15585   {
15586     struct file_name_list *next;
15587     char *fname;
15588     /* Mapping of file names for this directory.  */
15589     struct file_name_map *name_map;
15590     /* Non-zero if name_map is valid.  */
15591     int got_name_map;
15592   };
15593
15594 static struct file_name_list *include = NULL;   /* First dir to search */
15595 static struct file_name_list *last_include = NULL;      /* Last in chain */
15596
15597 /* I/O buffer structure.
15598    The `fname' field is nonzero for source files and #include files
15599    and for the dummy text used for -D and -U.
15600    It is zero for rescanning results of macro expansion
15601    and for expanding macro arguments.  */
15602 #define INPUT_STACK_MAX 400
15603 static struct file_buf {
15604   const char *fname;
15605   /* Filename specified with #line command.  */
15606   const char *nominal_fname;
15607   /* Record where in the search path this file was found.
15608      For #include_next.  */
15609   struct file_name_list *dir;
15610   ffewhereLine line;
15611   ffewhereColumn column;
15612 } instack[INPUT_STACK_MAX];
15613
15614 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15615 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15616
15617 /* Current nesting level of input sources.
15618    `instack[indepth]' is the level currently being read.  */
15619 static int indepth = -1;
15620
15621 typedef struct file_buf FILE_BUF;
15622
15623 typedef unsigned char U_CHAR;
15624
15625 /* table to tell if char can be part of a C identifier. */
15626 U_CHAR is_idchar[256];
15627 /* table to tell if char can be first char of a c identifier. */
15628 U_CHAR is_idstart[256];
15629 /* table to tell if c is horizontal space.  */
15630 U_CHAR is_hor_space[256];
15631 /* table to tell if c is horizontal or vertical space.  */
15632 static U_CHAR is_space[256];
15633
15634 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15635 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15636
15637 /* Nonzero means -I- has been seen,
15638    so don't look for #include "foo" the source-file directory.  */
15639 static int ignore_srcdir;
15640
15641 #ifndef INCLUDE_LEN_FUDGE
15642 #define INCLUDE_LEN_FUDGE 0
15643 #endif
15644
15645 static void append_include_chain (struct file_name_list *first,
15646                                   struct file_name_list *last);
15647 static FILE *open_include_file (char *filename,
15648                                 struct file_name_list *searchptr);
15649 static void print_containing_files (ffebadSeverity sev);
15650 static char *read_filename_string (int ch, FILE *f);
15651 static struct file_name_map *read_name_map (const char *dirname);
15652
15653 /* Append a chain of `struct file_name_list's
15654    to the end of the main include chain.
15655    FIRST is the beginning of the chain to append, and LAST is the end.  */
15656
15657 static void
15658 append_include_chain (first, last)
15659      struct file_name_list *first, *last;
15660 {
15661   struct file_name_list *dir;
15662
15663   if (!first || !last)
15664     return;
15665
15666   if (include == 0)
15667     include = first;
15668   else
15669     last_include->next = first;
15670
15671   for (dir = first; ; dir = dir->next) {
15672     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15673     if (len > max_include_len)
15674       max_include_len = len;
15675     if (dir == last)
15676       break;
15677   }
15678
15679   last->next = NULL;
15680   last_include = last;
15681 }
15682
15683 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15684    being tried from the include file search path.  This function maps
15685    filenames on file systems based on information read by
15686    read_name_map.  */
15687
15688 static FILE *
15689 open_include_file (filename, searchptr)
15690      char *filename;
15691      struct file_name_list *searchptr;
15692 {
15693   register struct file_name_map *map;
15694   register char *from;
15695   char *p, *dir;
15696
15697   if (searchptr && ! searchptr->got_name_map)
15698     {
15699       searchptr->name_map = read_name_map (searchptr->fname
15700                                            ? searchptr->fname : ".");
15701       searchptr->got_name_map = 1;
15702     }
15703
15704   /* First check the mapping for the directory we are using.  */
15705   if (searchptr && searchptr->name_map)
15706     {
15707       from = filename;
15708       if (searchptr->fname)
15709         from += strlen (searchptr->fname) + 1;
15710       for (map = searchptr->name_map; map; map = map->map_next)
15711         {
15712           if (! strcmp (map->map_from, from))
15713             {
15714               /* Found a match.  */
15715               return fopen (map->map_to, "r");
15716             }
15717         }
15718     }
15719
15720   /* Try to find a mapping file for the particular directory we are
15721      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15722      in /usr/include/header.gcc and look up types.h in
15723      /usr/include/sys/header.gcc.  */
15724   p = strrchr (filename, '/');
15725 #ifdef DIR_SEPARATOR
15726   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15727   else {
15728     char *tmp = strrchr (filename, DIR_SEPARATOR);
15729     if (tmp != NULL && tmp > p) p = tmp;
15730   }
15731 #endif
15732   if (! p)
15733     p = filename;
15734   if (searchptr
15735       && searchptr->fname
15736       && strlen (searchptr->fname) == (size_t) (p - filename)
15737       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15738     {
15739       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15740       return fopen (filename, "r");
15741     }
15742
15743   if (p == filename)
15744     {
15745       from = filename;
15746       map = read_name_map (".");
15747     }
15748   else
15749     {
15750       dir = (char *) xmalloc (p - filename + 1);
15751       memcpy (dir, filename, p - filename);
15752       dir[p - filename] = '\0';
15753       from = p + 1;
15754       map = read_name_map (dir);
15755       free (dir);
15756     }
15757   for (; map; map = map->map_next)
15758     if (! strcmp (map->map_from, from))
15759       return fopen (map->map_to, "r");
15760
15761   return fopen (filename, "r");
15762 }
15763
15764 /* Print the file names and line numbers of the #include
15765    commands which led to the current file.  */
15766
15767 static void
15768 print_containing_files (ffebadSeverity sev)
15769 {
15770   FILE_BUF *ip = NULL;
15771   int i;
15772   int first = 1;
15773   const char *str1;
15774   const char *str2;
15775
15776   /* If stack of files hasn't changed since we last printed
15777      this info, don't repeat it.  */
15778   if (last_error_tick == input_file_stack_tick)
15779     return;
15780
15781   for (i = indepth; i >= 0; i--)
15782     if (instack[i].fname != NULL) {
15783       ip = &instack[i];
15784       break;
15785     }
15786
15787   /* Give up if we don't find a source file.  */
15788   if (ip == NULL)
15789     return;
15790
15791   /* Find the other, outer source files.  */
15792   for (i--; i >= 0; i--)
15793     if (instack[i].fname != NULL)
15794       {
15795         ip = &instack[i];
15796         if (first)
15797           {
15798             first = 0;
15799             str1 = "In file included";
15800           }
15801         else
15802           {
15803             str1 = "...          ...";
15804           }
15805
15806         if (i == 1)
15807           str2 = ":";
15808         else
15809           str2 = "";
15810
15811         ffebad_start_msg ("%A from %B at %0%C", sev);
15812         ffebad_here (0, ip->line, ip->column);
15813         ffebad_string (str1);
15814         ffebad_string (ip->nominal_fname);
15815         ffebad_string (str2);
15816         ffebad_finish ();
15817       }
15818
15819   /* Record we have printed the status as of this time.  */
15820   last_error_tick = input_file_stack_tick;
15821 }
15822
15823 /* Read a space delimited string of unlimited length from a stdio
15824    file.  */
15825
15826 static char *
15827 read_filename_string (ch, f)
15828      int ch;
15829      FILE *f;
15830 {
15831   char *alloc, *set;
15832   int len;
15833
15834   len = 20;
15835   set = alloc = xmalloc (len + 1);
15836   if (! is_space[ch])
15837     {
15838       *set++ = ch;
15839       while ((ch = getc (f)) != EOF && ! is_space[ch])
15840         {
15841           if (set - alloc == len)
15842             {
15843               len *= 2;
15844               alloc = xrealloc (alloc, len + 1);
15845               set = alloc + len / 2;
15846             }
15847           *set++ = ch;
15848         }
15849     }
15850   *set = '\0';
15851   ungetc (ch, f);
15852   return alloc;
15853 }
15854
15855 /* Read the file name map file for DIRNAME.  */
15856
15857 static struct file_name_map *
15858 read_name_map (dirname)
15859      const char *dirname;
15860 {
15861   /* This structure holds a linked list of file name maps, one per
15862      directory.  */
15863   struct file_name_map_list
15864     {
15865       struct file_name_map_list *map_list_next;
15866       char *map_list_name;
15867       struct file_name_map *map_list_map;
15868     };
15869   static struct file_name_map_list *map_list;
15870   register struct file_name_map_list *map_list_ptr;
15871   char *name;
15872   FILE *f;
15873   size_t dirlen;
15874   int separator_needed;
15875
15876   dirname = skip_redundant_dir_prefix (dirname);
15877
15878   for (map_list_ptr = map_list; map_list_ptr;
15879        map_list_ptr = map_list_ptr->map_list_next)
15880     if (! strcmp (map_list_ptr->map_list_name, dirname))
15881       return map_list_ptr->map_list_map;
15882
15883   map_list_ptr = ((struct file_name_map_list *)
15884                   xmalloc (sizeof (struct file_name_map_list)));
15885   map_list_ptr->map_list_name = xstrdup (dirname);
15886   map_list_ptr->map_list_map = NULL;
15887
15888   dirlen = strlen (dirname);
15889   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15890   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15891   strcpy (name, dirname);
15892   name[dirlen] = '/';
15893   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15894   f = fopen (name, "r");
15895   free (name);
15896   if (!f)
15897     map_list_ptr->map_list_map = NULL;
15898   else
15899     {
15900       int ch;
15901
15902       while ((ch = getc (f)) != EOF)
15903         {
15904           char *from, *to;
15905           struct file_name_map *ptr;
15906
15907           if (is_space[ch])
15908             continue;
15909           from = read_filename_string (ch, f);
15910           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15911             ;
15912           to = read_filename_string (ch, f);
15913
15914           ptr = ((struct file_name_map *)
15915                  xmalloc (sizeof (struct file_name_map)));
15916           ptr->map_from = from;
15917
15918           /* Make the real filename absolute.  */
15919           if (*to == '/')
15920             ptr->map_to = to;
15921           else
15922             {
15923               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15924               strcpy (ptr->map_to, dirname);
15925               ptr->map_to[dirlen] = '/';
15926               strcpy (ptr->map_to + dirlen + separator_needed, to);
15927               free (to);
15928             }
15929
15930           ptr->map_next = map_list_ptr->map_list_map;
15931           map_list_ptr->map_list_map = ptr;
15932
15933           while ((ch = getc (f)) != '\n')
15934             if (ch == EOF)
15935               break;
15936         }
15937       fclose (f);
15938     }
15939
15940   map_list_ptr->map_list_next = map_list;
15941   map_list = map_list_ptr;
15942
15943   return map_list_ptr->map_list_map;
15944 }
15945
15946 static void
15947 ffecom_file_ (const char *name)
15948 {
15949   FILE_BUF *fp;
15950
15951   /* Do partial setup of input buffer for the sake of generating
15952      early #line directives (when -g is in effect).  */
15953
15954   fp = &instack[++indepth];
15955   memset ((char *) fp, 0, sizeof (FILE_BUF));
15956   if (name == NULL)
15957     name = "";
15958   fp->nominal_fname = fp->fname = name;
15959 }
15960
15961 /* Initialize syntactic classifications of characters.  */
15962
15963 static void
15964 ffecom_initialize_char_syntax_ ()
15965 {
15966   register int i;
15967
15968   /*
15969    * Set up is_idchar and is_idstart tables.  These should be
15970    * faster than saying (is_alpha (c) || c == '_'), etc.
15971    * Set up these things before calling any routines tthat
15972    * refer to them.
15973    */
15974   for (i = 'a'; i <= 'z'; i++) {
15975     is_idchar[i - 'a' + 'A'] = 1;
15976     is_idchar[i] = 1;
15977     is_idstart[i - 'a' + 'A'] = 1;
15978     is_idstart[i] = 1;
15979   }
15980   for (i = '0'; i <= '9'; i++)
15981     is_idchar[i] = 1;
15982   is_idchar['_'] = 1;
15983   is_idstart['_'] = 1;
15984
15985   /* horizontal space table */
15986   is_hor_space[' '] = 1;
15987   is_hor_space['\t'] = 1;
15988   is_hor_space['\v'] = 1;
15989   is_hor_space['\f'] = 1;
15990   is_hor_space['\r'] = 1;
15991
15992   is_space[' '] = 1;
15993   is_space['\t'] = 1;
15994   is_space['\v'] = 1;
15995   is_space['\f'] = 1;
15996   is_space['\n'] = 1;
15997   is_space['\r'] = 1;
15998 }
15999
16000 static void
16001 ffecom_close_include_ (FILE *f)
16002 {
16003   fclose (f);
16004
16005   indepth--;
16006   input_file_stack_tick++;
16007
16008   ffewhere_line_kill (instack[indepth].line);
16009   ffewhere_column_kill (instack[indepth].column);
16010 }
16011
16012 static int
16013 ffecom_decode_include_option_ (char *spec)
16014 {
16015   struct file_name_list *dirtmp;
16016
16017   if (! ignore_srcdir && !strcmp (spec, "-"))
16018     ignore_srcdir = 1;
16019   else
16020     {
16021       dirtmp = (struct file_name_list *)
16022         xmalloc (sizeof (struct file_name_list));
16023       dirtmp->next = 0;         /* New one goes on the end */
16024       dirtmp->fname = spec;
16025       dirtmp->got_name_map = 0;
16026       if (spec[0] == 0)
16027         error ("Directory name must immediately follow -I");
16028       else
16029         append_include_chain (dirtmp, dirtmp);
16030     }
16031   return 1;
16032 }
16033
16034 /* Open INCLUDEd file.  */
16035
16036 static FILE *
16037 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16038 {
16039   char *fbeg = name;
16040   size_t flen = strlen (fbeg);
16041   struct file_name_list *search_start = include; /* Chain of dirs to search */
16042   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16043   struct file_name_list *searchptr = 0;
16044   char *fname;          /* Dynamically allocated fname buffer */
16045   FILE *f;
16046   FILE_BUF *fp;
16047
16048   if (flen == 0)
16049     return NULL;
16050
16051   dsp[0].fname = NULL;
16052
16053   /* If -I- was specified, don't search current dir, only spec'd ones. */
16054   if (!ignore_srcdir)
16055     {
16056       for (fp = &instack[indepth]; fp >= instack; fp--)
16057         {
16058           int n;
16059           char *ep;
16060           const char *nam;
16061
16062           if ((nam = fp->nominal_fname) != NULL)
16063             {
16064               /* Found a named file.  Figure out dir of the file,
16065                  and put it in front of the search list.  */
16066               dsp[0].next = search_start;
16067               search_start = dsp;
16068 #ifndef VMS
16069               ep = strrchr (nam, '/');
16070 #ifdef DIR_SEPARATOR
16071             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16072             else {
16073               char *tmp = strrchr (nam, DIR_SEPARATOR);
16074               if (tmp != NULL && tmp > ep) ep = tmp;
16075             }
16076 #endif
16077 #else                           /* VMS */
16078               ep = strrchr (nam, ']');
16079               if (ep == NULL) ep = strrchr (nam, '>');
16080               if (ep == NULL) ep = strrchr (nam, ':');
16081               if (ep != NULL) ep++;
16082 #endif                          /* VMS */
16083               if (ep != NULL)
16084                 {
16085                   n = ep - nam;
16086                   dsp[0].fname = (char *) xmalloc (n + 1);
16087                   strncpy (dsp[0].fname, nam, n);
16088                   dsp[0].fname[n] = '\0';
16089                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16090                     max_include_len = n + INCLUDE_LEN_FUDGE;
16091                 }
16092               else
16093                 dsp[0].fname = NULL; /* Current directory */
16094               dsp[0].got_name_map = 0;
16095               break;
16096             }
16097         }
16098     }
16099
16100   /* Allocate this permanently, because it gets stored in the definitions
16101      of macros.  */
16102   fname = xmalloc (max_include_len + flen + 4);
16103   /* + 2 above for slash and terminating null.  */
16104   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16105      for g77 yet).  */
16106
16107   /* If specified file name is absolute, just open it.  */
16108
16109   if (*fbeg == '/'
16110 #ifdef DIR_SEPARATOR
16111       || *fbeg == DIR_SEPARATOR
16112 #endif
16113       )
16114     {
16115       strncpy (fname, (char *) fbeg, flen);
16116       fname[flen] = 0;
16117       f = open_include_file (fname, NULL);
16118     }
16119   else
16120     {
16121       f = NULL;
16122
16123       /* Search directory path, trying to open the file.
16124          Copy each filename tried into FNAME.  */
16125
16126       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16127         {
16128           if (searchptr->fname)
16129             {
16130               /* The empty string in a search path is ignored.
16131                  This makes it possible to turn off entirely
16132                  a standard piece of the list.  */
16133               if (searchptr->fname[0] == 0)
16134                 continue;
16135               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16136               if (fname[0] && fname[strlen (fname) - 1] != '/')
16137                 strcat (fname, "/");
16138               fname[strlen (fname) + flen] = 0;
16139             }
16140           else
16141             fname[0] = 0;
16142
16143           strncat (fname, fbeg, flen);
16144 #ifdef VMS
16145           /* Change this 1/2 Unix 1/2 VMS file specification into a
16146              full VMS file specification */
16147           if (searchptr->fname && (searchptr->fname[0] != 0))
16148             {
16149               /* Fix up the filename */
16150               hack_vms_include_specification (fname);
16151             }
16152           else
16153             {
16154               /* This is a normal VMS filespec, so use it unchanged.  */
16155               strncpy (fname, (char *) fbeg, flen);
16156               fname[flen] = 0;
16157 #if 0   /* Not for g77.  */
16158               /* if it's '#include filename', add the missing .h */
16159               if (strchr (fname, '.') == NULL)
16160                 strcat (fname, ".h");
16161 #endif
16162             }
16163 #endif /* VMS */
16164           f = open_include_file (fname, searchptr);
16165 #ifdef EACCES
16166           if (f == NULL && errno == EACCES)
16167             {
16168               print_containing_files (FFEBAD_severityWARNING);
16169               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16170                                 FFEBAD_severityWARNING);
16171               ffebad_string (fname);
16172               ffebad_here (0, l, c);
16173               ffebad_finish ();
16174             }
16175 #endif
16176           if (f != NULL)
16177             break;
16178         }
16179     }
16180
16181   if (f == NULL)
16182     {
16183       /* A file that was not found.  */
16184
16185       strncpy (fname, (char *) fbeg, flen);
16186       fname[flen] = 0;
16187       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16188       ffebad_start (FFEBAD_OPEN_INCLUDE);
16189       ffebad_here (0, l, c);
16190       ffebad_string (fname);
16191       ffebad_finish ();
16192     }
16193
16194   if (dsp[0].fname != NULL)
16195     free (dsp[0].fname);
16196
16197   if (f == NULL)
16198     return NULL;
16199
16200   if (indepth >= (INPUT_STACK_MAX - 1))
16201     {
16202       print_containing_files (FFEBAD_severityFATAL);
16203       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16204                         FFEBAD_severityFATAL);
16205       ffebad_string (fname);
16206       ffebad_here (0, l, c);
16207       ffebad_finish ();
16208       return NULL;
16209     }
16210
16211   instack[indepth].line = ffewhere_line_use (l);
16212   instack[indepth].column = ffewhere_column_use (c);
16213
16214   fp = &instack[indepth + 1];
16215   memset ((char *) fp, 0, sizeof (FILE_BUF));
16216   fp->nominal_fname = fp->fname = fname;
16217   fp->dir = searchptr;
16218
16219   indepth++;
16220   input_file_stack_tick++;
16221
16222   return f;
16223 }
16224 #endif  /* FFECOM_GCC_INCLUDE */
16225
16226 /**INDENT* (Do not reformat this comment even with -fca option.)
16227    Data-gathering files: Given the source file listed below, compiled with
16228    f2c I obtained the output file listed after that, and from the output
16229    file I derived the above code.
16230
16231 -------- (begin input file to f2c)
16232         implicit none
16233         character*10 A1,A2
16234         complex C1,C2
16235         integer I1,I2
16236         real R1,R2
16237         double precision D1,D2
16238 C
16239         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16240 c /
16241         call fooI(I1/I2)
16242         call fooR(R1/I1)
16243         call fooD(D1/I1)
16244         call fooC(C1/I1)
16245         call fooR(R1/R2)
16246         call fooD(R1/D1)
16247         call fooD(D1/D2)
16248         call fooD(D1/R1)
16249         call fooC(C1/C2)
16250         call fooC(C1/R1)
16251         call fooZ(C1/D1)
16252 c **
16253         call fooI(I1**I2)
16254         call fooR(R1**I1)
16255         call fooD(D1**I1)
16256         call fooC(C1**I1)
16257         call fooR(R1**R2)
16258         call fooD(R1**D1)
16259         call fooD(D1**D2)
16260         call fooD(D1**R1)
16261         call fooC(C1**C2)
16262         call fooC(C1**R1)
16263         call fooZ(C1**D1)
16264 c FFEINTRIN_impABS
16265         call fooR(ABS(R1))
16266 c FFEINTRIN_impACOS
16267         call fooR(ACOS(R1))
16268 c FFEINTRIN_impAIMAG
16269         call fooR(AIMAG(C1))
16270 c FFEINTRIN_impAINT
16271         call fooR(AINT(R1))
16272 c FFEINTRIN_impALOG
16273         call fooR(ALOG(R1))
16274 c FFEINTRIN_impALOG10
16275         call fooR(ALOG10(R1))
16276 c FFEINTRIN_impAMAX0
16277         call fooR(AMAX0(I1,I2))
16278 c FFEINTRIN_impAMAX1
16279         call fooR(AMAX1(R1,R2))
16280 c FFEINTRIN_impAMIN0
16281         call fooR(AMIN0(I1,I2))
16282 c FFEINTRIN_impAMIN1
16283         call fooR(AMIN1(R1,R2))
16284 c FFEINTRIN_impAMOD
16285         call fooR(AMOD(R1,R2))
16286 c FFEINTRIN_impANINT
16287         call fooR(ANINT(R1))
16288 c FFEINTRIN_impASIN
16289         call fooR(ASIN(R1))
16290 c FFEINTRIN_impATAN
16291         call fooR(ATAN(R1))
16292 c FFEINTRIN_impATAN2
16293         call fooR(ATAN2(R1,R2))
16294 c FFEINTRIN_impCABS
16295         call fooR(CABS(C1))
16296 c FFEINTRIN_impCCOS
16297         call fooC(CCOS(C1))
16298 c FFEINTRIN_impCEXP
16299         call fooC(CEXP(C1))
16300 c FFEINTRIN_impCHAR
16301         call fooA(CHAR(I1))
16302 c FFEINTRIN_impCLOG
16303         call fooC(CLOG(C1))
16304 c FFEINTRIN_impCONJG
16305         call fooC(CONJG(C1))
16306 c FFEINTRIN_impCOS
16307         call fooR(COS(R1))
16308 c FFEINTRIN_impCOSH
16309         call fooR(COSH(R1))
16310 c FFEINTRIN_impCSIN
16311         call fooC(CSIN(C1))
16312 c FFEINTRIN_impCSQRT
16313         call fooC(CSQRT(C1))
16314 c FFEINTRIN_impDABS
16315         call fooD(DABS(D1))
16316 c FFEINTRIN_impDACOS
16317         call fooD(DACOS(D1))
16318 c FFEINTRIN_impDASIN
16319         call fooD(DASIN(D1))
16320 c FFEINTRIN_impDATAN
16321         call fooD(DATAN(D1))
16322 c FFEINTRIN_impDATAN2
16323         call fooD(DATAN2(D1,D2))
16324 c FFEINTRIN_impDCOS
16325         call fooD(DCOS(D1))
16326 c FFEINTRIN_impDCOSH
16327         call fooD(DCOSH(D1))
16328 c FFEINTRIN_impDDIM
16329         call fooD(DDIM(D1,D2))
16330 c FFEINTRIN_impDEXP
16331         call fooD(DEXP(D1))
16332 c FFEINTRIN_impDIM
16333         call fooR(DIM(R1,R2))
16334 c FFEINTRIN_impDINT
16335         call fooD(DINT(D1))
16336 c FFEINTRIN_impDLOG
16337         call fooD(DLOG(D1))
16338 c FFEINTRIN_impDLOG10
16339         call fooD(DLOG10(D1))
16340 c FFEINTRIN_impDMAX1
16341         call fooD(DMAX1(D1,D2))
16342 c FFEINTRIN_impDMIN1
16343         call fooD(DMIN1(D1,D2))
16344 c FFEINTRIN_impDMOD
16345         call fooD(DMOD(D1,D2))
16346 c FFEINTRIN_impDNINT
16347         call fooD(DNINT(D1))
16348 c FFEINTRIN_impDPROD
16349         call fooD(DPROD(R1,R2))
16350 c FFEINTRIN_impDSIGN
16351         call fooD(DSIGN(D1,D2))
16352 c FFEINTRIN_impDSIN
16353         call fooD(DSIN(D1))
16354 c FFEINTRIN_impDSINH
16355         call fooD(DSINH(D1))
16356 c FFEINTRIN_impDSQRT
16357         call fooD(DSQRT(D1))
16358 c FFEINTRIN_impDTAN
16359         call fooD(DTAN(D1))
16360 c FFEINTRIN_impDTANH
16361         call fooD(DTANH(D1))
16362 c FFEINTRIN_impEXP
16363         call fooR(EXP(R1))
16364 c FFEINTRIN_impIABS
16365         call fooI(IABS(I1))
16366 c FFEINTRIN_impICHAR
16367         call fooI(ICHAR(A1))
16368 c FFEINTRIN_impIDIM
16369         call fooI(IDIM(I1,I2))
16370 c FFEINTRIN_impIDNINT
16371         call fooI(IDNINT(D1))
16372 c FFEINTRIN_impINDEX
16373         call fooI(INDEX(A1,A2))
16374 c FFEINTRIN_impISIGN
16375         call fooI(ISIGN(I1,I2))
16376 c FFEINTRIN_impLEN
16377         call fooI(LEN(A1))
16378 c FFEINTRIN_impLGE
16379         call fooL(LGE(A1,A2))
16380 c FFEINTRIN_impLGT
16381         call fooL(LGT(A1,A2))
16382 c FFEINTRIN_impLLE
16383         call fooL(LLE(A1,A2))
16384 c FFEINTRIN_impLLT
16385         call fooL(LLT(A1,A2))
16386 c FFEINTRIN_impMAX0
16387         call fooI(MAX0(I1,I2))
16388 c FFEINTRIN_impMAX1
16389         call fooI(MAX1(R1,R2))
16390 c FFEINTRIN_impMIN0
16391         call fooI(MIN0(I1,I2))
16392 c FFEINTRIN_impMIN1
16393         call fooI(MIN1(R1,R2))
16394 c FFEINTRIN_impMOD
16395         call fooI(MOD(I1,I2))
16396 c FFEINTRIN_impNINT
16397         call fooI(NINT(R1))
16398 c FFEINTRIN_impSIGN
16399         call fooR(SIGN(R1,R2))
16400 c FFEINTRIN_impSIN
16401         call fooR(SIN(R1))
16402 c FFEINTRIN_impSINH
16403         call fooR(SINH(R1))
16404 c FFEINTRIN_impSQRT
16405         call fooR(SQRT(R1))
16406 c FFEINTRIN_impTAN
16407         call fooR(TAN(R1))
16408 c FFEINTRIN_impTANH
16409         call fooR(TANH(R1))
16410 c FFEINTRIN_imp_CMPLX_C
16411         call fooC(cmplx(C1,C2))
16412 c FFEINTRIN_imp_CMPLX_D
16413         call fooZ(cmplx(D1,D2))
16414 c FFEINTRIN_imp_CMPLX_I
16415         call fooC(cmplx(I1,I2))
16416 c FFEINTRIN_imp_CMPLX_R
16417         call fooC(cmplx(R1,R2))
16418 c FFEINTRIN_imp_DBLE_C
16419         call fooD(dble(C1))
16420 c FFEINTRIN_imp_DBLE_D
16421         call fooD(dble(D1))
16422 c FFEINTRIN_imp_DBLE_I
16423         call fooD(dble(I1))
16424 c FFEINTRIN_imp_DBLE_R
16425         call fooD(dble(R1))
16426 c FFEINTRIN_imp_INT_C
16427         call fooI(int(C1))
16428 c FFEINTRIN_imp_INT_D
16429         call fooI(int(D1))
16430 c FFEINTRIN_imp_INT_I
16431         call fooI(int(I1))
16432 c FFEINTRIN_imp_INT_R
16433         call fooI(int(R1))
16434 c FFEINTRIN_imp_REAL_C
16435         call fooR(real(C1))
16436 c FFEINTRIN_imp_REAL_D
16437         call fooR(real(D1))
16438 c FFEINTRIN_imp_REAL_I
16439         call fooR(real(I1))
16440 c FFEINTRIN_imp_REAL_R
16441         call fooR(real(R1))
16442 c
16443 c FFEINTRIN_imp_INT_D:
16444 c
16445 c FFEINTRIN_specIDINT
16446         call fooI(IDINT(D1))
16447 c
16448 c FFEINTRIN_imp_INT_R:
16449 c
16450 c FFEINTRIN_specIFIX
16451         call fooI(IFIX(R1))
16452 c FFEINTRIN_specINT
16453         call fooI(INT(R1))
16454 c
16455 c FFEINTRIN_imp_REAL_D:
16456 c
16457 c FFEINTRIN_specSNGL
16458         call fooR(SNGL(D1))
16459 c
16460 c FFEINTRIN_imp_REAL_I:
16461 c
16462 c FFEINTRIN_specFLOAT
16463         call fooR(FLOAT(I1))
16464 c FFEINTRIN_specREAL
16465         call fooR(REAL(I1))
16466 c
16467         end
16468 -------- (end input file to f2c)
16469
16470 -------- (begin output from providing above input file as input to:
16471 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16472 --------     -e "s:^#.*$::g"')
16473
16474 //  -- translated by f2c (version 19950223).
16475    You must link the resulting object file with the libraries:
16476         -lf2c -lm   (in that order)
16477 //
16478
16479
16480 // f2c.h  --  Standard Fortran to C header file //
16481
16482 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16483
16484         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16485
16486
16487
16488
16489 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16490 // we assume short, float are OK //
16491 typedef long int // long int // integer;
16492 typedef char *address;
16493 typedef short int shortint;
16494 typedef float real;
16495 typedef double doublereal;
16496 typedef struct { real r, i; } complex;
16497 typedef struct { doublereal r, i; } doublecomplex;
16498 typedef long int // long int // logical;
16499 typedef short int shortlogical;
16500 typedef char logical1;
16501 typedef char integer1;
16502 // typedef long long longint; // // system-dependent //
16503
16504
16505
16506
16507 // Extern is for use with -E //
16508
16509
16510
16511
16512 // I/O stuff //
16513
16514
16515
16516
16517
16518
16519
16520
16521 typedef long int // int or long int // flag;
16522 typedef long int // int or long int // ftnlen;
16523 typedef long int // int or long int // ftnint;
16524
16525
16526 //external read, write//
16527 typedef struct
16528 {       flag cierr;
16529         ftnint ciunit;
16530         flag ciend;
16531         char *cifmt;
16532         ftnint cirec;
16533 } cilist;
16534
16535 //internal read, write//
16536 typedef struct
16537 {       flag icierr;
16538         char *iciunit;
16539         flag iciend;
16540         char *icifmt;
16541         ftnint icirlen;
16542         ftnint icirnum;
16543 } icilist;
16544
16545 //open//
16546 typedef struct
16547 {       flag oerr;
16548         ftnint ounit;
16549         char *ofnm;
16550         ftnlen ofnmlen;
16551         char *osta;
16552         char *oacc;
16553         char *ofm;
16554         ftnint orl;
16555         char *oblnk;
16556 } olist;
16557
16558 //close//
16559 typedef struct
16560 {       flag cerr;
16561         ftnint cunit;
16562         char *csta;
16563 } cllist;
16564
16565 //rewind, backspace, endfile//
16566 typedef struct
16567 {       flag aerr;
16568         ftnint aunit;
16569 } alist;
16570
16571 // inquire //
16572 typedef struct
16573 {       flag inerr;
16574         ftnint inunit;
16575         char *infile;
16576         ftnlen infilen;
16577         ftnint  *inex;  //parameters in standard's order//
16578         ftnint  *inopen;
16579         ftnint  *innum;
16580         ftnint  *innamed;
16581         char    *inname;
16582         ftnlen  innamlen;
16583         char    *inacc;
16584         ftnlen  inacclen;
16585         char    *inseq;
16586         ftnlen  inseqlen;
16587         char    *indir;
16588         ftnlen  indirlen;
16589         char    *infmt;
16590         ftnlen  infmtlen;
16591         char    *inform;
16592         ftnint  informlen;
16593         char    *inunf;
16594         ftnlen  inunflen;
16595         ftnint  *inrecl;
16596         ftnint  *innrec;
16597         char    *inblank;
16598         ftnlen  inblanklen;
16599 } inlist;
16600
16601
16602
16603 union Multitype {       // for multiple entry points //
16604         integer1 g;
16605         shortint h;
16606         integer i;
16607         // longint j; //
16608         real r;
16609         doublereal d;
16610         complex c;
16611         doublecomplex z;
16612         };
16613
16614 typedef union Multitype Multitype;
16615
16616 typedef long Long;      // No longer used; formerly in Namelist //
16617
16618 struct Vardesc {        // for Namelist //
16619         char *name;
16620         char *addr;
16621         ftnlen *dims;
16622         int  type;
16623         };
16624 typedef struct Vardesc Vardesc;
16625
16626 struct Namelist {
16627         char *name;
16628         Vardesc **vars;
16629         int nvars;
16630         };
16631 typedef struct Namelist Namelist;
16632
16633
16634
16635
16636
16637
16638
16639
16640 // procedure parameter types for -A and -C++ //
16641
16642
16643
16644
16645 typedef int // Unknown procedure type // (*U_fp)();
16646 typedef shortint (*J_fp)();
16647 typedef integer (*I_fp)();
16648 typedef real (*R_fp)();
16649 typedef doublereal (*D_fp)(), (*E_fp)();
16650 typedef // Complex // void  (*C_fp)();
16651 typedef // Double Complex // void  (*Z_fp)();
16652 typedef logical (*L_fp)();
16653 typedef shortlogical (*K_fp)();
16654 typedef // Character // void  (*H_fp)();
16655 typedef // Subroutine // int (*S_fp)();
16656
16657 // E_fp is for real functions when -R is not specified //
16658 typedef void  C_f;      // complex function //
16659 typedef void  H_f;      // character function //
16660 typedef void  Z_f;      // double complex function //
16661 typedef doublereal E_f; // real function with -R not specified //
16662
16663 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16664
16665
16666 // (No such symbols should be defined in a strict ANSI C compiler.
16667    We can avoid trouble with f2c-translated code by using
16668    gcc -ansi [-traditional].) //
16669
16670
16671
16672
16673
16674
16675
16676
16677
16678
16679
16680
16681
16682
16683
16684
16685
16686
16687
16688
16689
16690
16691
16692 // Main program // MAIN__()
16693 {
16694     // System generated locals //
16695     integer i__1;
16696     real r__1, r__2;
16697     doublereal d__1, d__2;
16698     complex q__1;
16699     doublecomplex z__1, z__2, z__3;
16700     logical L__1;
16701     char ch__1[1];
16702
16703     // Builtin functions //
16704     void c_div();
16705     integer pow_ii();
16706     double pow_ri(), pow_di();
16707     void pow_ci();
16708     double pow_dd();
16709     void pow_zz();
16710     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16711             asin(), atan(), atan2(), c_abs();
16712     void c_cos(), c_exp(), c_log(), r_cnjg();
16713     double cos(), cosh();
16714     void c_sin(), c_sqrt();
16715     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16716             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16717     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16718     logical l_ge(), l_gt(), l_le(), l_lt();
16719     integer i_nint();
16720     double r_sign();
16721
16722     // Local variables //
16723     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16724             fool_(), fooz_(), getem_();
16725     static char a1[10], a2[10];
16726     static complex c1, c2;
16727     static doublereal d1, d2;
16728     static integer i1, i2;
16729     static real r1, r2;
16730
16731
16732     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16733 // / //
16734     i__1 = i1 / i2;
16735     fooi_(&i__1);
16736     r__1 = r1 / i1;
16737     foor_(&r__1);
16738     d__1 = d1 / i1;
16739     food_(&d__1);
16740     d__1 = (doublereal) i1;
16741     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16742     fooc_(&q__1);
16743     r__1 = r1 / r2;
16744     foor_(&r__1);
16745     d__1 = r1 / d1;
16746     food_(&d__1);
16747     d__1 = d1 / d2;
16748     food_(&d__1);
16749     d__1 = d1 / r1;
16750     food_(&d__1);
16751     c_div(&q__1, &c1, &c2);
16752     fooc_(&q__1);
16753     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16754     fooc_(&q__1);
16755     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16756     fooz_(&z__1);
16757 // ** //
16758     i__1 = pow_ii(&i1, &i2);
16759     fooi_(&i__1);
16760     r__1 = pow_ri(&r1, &i1);
16761     foor_(&r__1);
16762     d__1 = pow_di(&d1, &i1);
16763     food_(&d__1);
16764     pow_ci(&q__1, &c1, &i1);
16765     fooc_(&q__1);
16766     d__1 = (doublereal) r1;
16767     d__2 = (doublereal) r2;
16768     r__1 = pow_dd(&d__1, &d__2);
16769     foor_(&r__1);
16770     d__2 = (doublereal) r1;
16771     d__1 = pow_dd(&d__2, &d1);
16772     food_(&d__1);
16773     d__1 = pow_dd(&d1, &d2);
16774     food_(&d__1);
16775     d__2 = (doublereal) r1;
16776     d__1 = pow_dd(&d1, &d__2);
16777     food_(&d__1);
16778     z__2.r = c1.r, z__2.i = c1.i;
16779     z__3.r = c2.r, z__3.i = c2.i;
16780     pow_zz(&z__1, &z__2, &z__3);
16781     q__1.r = z__1.r, q__1.i = z__1.i;
16782     fooc_(&q__1);
16783     z__2.r = c1.r, z__2.i = c1.i;
16784     z__3.r = r1, z__3.i = 0.;
16785     pow_zz(&z__1, &z__2, &z__3);
16786     q__1.r = z__1.r, q__1.i = z__1.i;
16787     fooc_(&q__1);
16788     z__2.r = c1.r, z__2.i = c1.i;
16789     z__3.r = d1, z__3.i = 0.;
16790     pow_zz(&z__1, &z__2, &z__3);
16791     fooz_(&z__1);
16792 // FFEINTRIN_impABS //
16793     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16794     foor_(&r__1);
16795 // FFEINTRIN_impACOS //
16796     r__1 = acos(r1);
16797     foor_(&r__1);
16798 // FFEINTRIN_impAIMAG //
16799     r__1 = r_imag(&c1);
16800     foor_(&r__1);
16801 // FFEINTRIN_impAINT //
16802     r__1 = r_int(&r1);
16803     foor_(&r__1);
16804 // FFEINTRIN_impALOG //
16805     r__1 = log(r1);
16806     foor_(&r__1);
16807 // FFEINTRIN_impALOG10 //
16808     r__1 = r_lg10(&r1);
16809     foor_(&r__1);
16810 // FFEINTRIN_impAMAX0 //
16811     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16812     foor_(&r__1);
16813 // FFEINTRIN_impAMAX1 //
16814     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16815     foor_(&r__1);
16816 // FFEINTRIN_impAMIN0 //
16817     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16818     foor_(&r__1);
16819 // FFEINTRIN_impAMIN1 //
16820     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16821     foor_(&r__1);
16822 // FFEINTRIN_impAMOD //
16823     r__1 = r_mod(&r1, &r2);
16824     foor_(&r__1);
16825 // FFEINTRIN_impANINT //
16826     r__1 = r_nint(&r1);
16827     foor_(&r__1);
16828 // FFEINTRIN_impASIN //
16829     r__1 = asin(r1);
16830     foor_(&r__1);
16831 // FFEINTRIN_impATAN //
16832     r__1 = atan(r1);
16833     foor_(&r__1);
16834 // FFEINTRIN_impATAN2 //
16835     r__1 = atan2(r1, r2);
16836     foor_(&r__1);
16837 // FFEINTRIN_impCABS //
16838     r__1 = c_abs(&c1);
16839     foor_(&r__1);
16840 // FFEINTRIN_impCCOS //
16841     c_cos(&q__1, &c1);
16842     fooc_(&q__1);
16843 // FFEINTRIN_impCEXP //
16844     c_exp(&q__1, &c1);
16845     fooc_(&q__1);
16846 // FFEINTRIN_impCHAR //
16847     *(unsigned char *)&ch__1[0] = i1;
16848     fooa_(ch__1, 1L);
16849 // FFEINTRIN_impCLOG //
16850     c_log(&q__1, &c1);
16851     fooc_(&q__1);
16852 // FFEINTRIN_impCONJG //
16853     r_cnjg(&q__1, &c1);
16854     fooc_(&q__1);
16855 // FFEINTRIN_impCOS //
16856     r__1 = cos(r1);
16857     foor_(&r__1);
16858 // FFEINTRIN_impCOSH //
16859     r__1 = cosh(r1);
16860     foor_(&r__1);
16861 // FFEINTRIN_impCSIN //
16862     c_sin(&q__1, &c1);
16863     fooc_(&q__1);
16864 // FFEINTRIN_impCSQRT //
16865     c_sqrt(&q__1, &c1);
16866     fooc_(&q__1);
16867 // FFEINTRIN_impDABS //
16868     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16869     food_(&d__1);
16870 // FFEINTRIN_impDACOS //
16871     d__1 = acos(d1);
16872     food_(&d__1);
16873 // FFEINTRIN_impDASIN //
16874     d__1 = asin(d1);
16875     food_(&d__1);
16876 // FFEINTRIN_impDATAN //
16877     d__1 = atan(d1);
16878     food_(&d__1);
16879 // FFEINTRIN_impDATAN2 //
16880     d__1 = atan2(d1, d2);
16881     food_(&d__1);
16882 // FFEINTRIN_impDCOS //
16883     d__1 = cos(d1);
16884     food_(&d__1);
16885 // FFEINTRIN_impDCOSH //
16886     d__1 = cosh(d1);
16887     food_(&d__1);
16888 // FFEINTRIN_impDDIM //
16889     d__1 = d_dim(&d1, &d2);
16890     food_(&d__1);
16891 // FFEINTRIN_impDEXP //
16892     d__1 = exp(d1);
16893     food_(&d__1);
16894 // FFEINTRIN_impDIM //
16895     r__1 = r_dim(&r1, &r2);
16896     foor_(&r__1);
16897 // FFEINTRIN_impDINT //
16898     d__1 = d_int(&d1);
16899     food_(&d__1);
16900 // FFEINTRIN_impDLOG //
16901     d__1 = log(d1);
16902     food_(&d__1);
16903 // FFEINTRIN_impDLOG10 //
16904     d__1 = d_lg10(&d1);
16905     food_(&d__1);
16906 // FFEINTRIN_impDMAX1 //
16907     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16908     food_(&d__1);
16909 // FFEINTRIN_impDMIN1 //
16910     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16911     food_(&d__1);
16912 // FFEINTRIN_impDMOD //
16913     d__1 = d_mod(&d1, &d2);
16914     food_(&d__1);
16915 // FFEINTRIN_impDNINT //
16916     d__1 = d_nint(&d1);
16917     food_(&d__1);
16918 // FFEINTRIN_impDPROD //
16919     d__1 = (doublereal) r1 * r2;
16920     food_(&d__1);
16921 // FFEINTRIN_impDSIGN //
16922     d__1 = d_sign(&d1, &d2);
16923     food_(&d__1);
16924 // FFEINTRIN_impDSIN //
16925     d__1 = sin(d1);
16926     food_(&d__1);
16927 // FFEINTRIN_impDSINH //
16928     d__1 = sinh(d1);
16929     food_(&d__1);
16930 // FFEINTRIN_impDSQRT //
16931     d__1 = sqrt(d1);
16932     food_(&d__1);
16933 // FFEINTRIN_impDTAN //
16934     d__1 = tan(d1);
16935     food_(&d__1);
16936 // FFEINTRIN_impDTANH //
16937     d__1 = tanh(d1);
16938     food_(&d__1);
16939 // FFEINTRIN_impEXP //
16940     r__1 = exp(r1);
16941     foor_(&r__1);
16942 // FFEINTRIN_impIABS //
16943     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16944     fooi_(&i__1);
16945 // FFEINTRIN_impICHAR //
16946     i__1 = *(unsigned char *)a1;
16947     fooi_(&i__1);
16948 // FFEINTRIN_impIDIM //
16949     i__1 = i_dim(&i1, &i2);
16950     fooi_(&i__1);
16951 // FFEINTRIN_impIDNINT //
16952     i__1 = i_dnnt(&d1);
16953     fooi_(&i__1);
16954 // FFEINTRIN_impINDEX //
16955     i__1 = i_indx(a1, a2, 10L, 10L);
16956     fooi_(&i__1);
16957 // FFEINTRIN_impISIGN //
16958     i__1 = i_sign(&i1, &i2);
16959     fooi_(&i__1);
16960 // FFEINTRIN_impLEN //
16961     i__1 = i_len(a1, 10L);
16962     fooi_(&i__1);
16963 // FFEINTRIN_impLGE //
16964     L__1 = l_ge(a1, a2, 10L, 10L);
16965     fool_(&L__1);
16966 // FFEINTRIN_impLGT //
16967     L__1 = l_gt(a1, a2, 10L, 10L);
16968     fool_(&L__1);
16969 // FFEINTRIN_impLLE //
16970     L__1 = l_le(a1, a2, 10L, 10L);
16971     fool_(&L__1);
16972 // FFEINTRIN_impLLT //
16973     L__1 = l_lt(a1, a2, 10L, 10L);
16974     fool_(&L__1);
16975 // FFEINTRIN_impMAX0 //
16976     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16977     fooi_(&i__1);
16978 // FFEINTRIN_impMAX1 //
16979     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16980     fooi_(&i__1);
16981 // FFEINTRIN_impMIN0 //
16982     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16983     fooi_(&i__1);
16984 // FFEINTRIN_impMIN1 //
16985     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16986     fooi_(&i__1);
16987 // FFEINTRIN_impMOD //
16988     i__1 = i1 % i2;
16989     fooi_(&i__1);
16990 // FFEINTRIN_impNINT //
16991     i__1 = i_nint(&r1);
16992     fooi_(&i__1);
16993 // FFEINTRIN_impSIGN //
16994     r__1 = r_sign(&r1, &r2);
16995     foor_(&r__1);
16996 // FFEINTRIN_impSIN //
16997     r__1 = sin(r1);
16998     foor_(&r__1);
16999 // FFEINTRIN_impSINH //
17000     r__1 = sinh(r1);
17001     foor_(&r__1);
17002 // FFEINTRIN_impSQRT //
17003     r__1 = sqrt(r1);
17004     foor_(&r__1);
17005 // FFEINTRIN_impTAN //
17006     r__1 = tan(r1);
17007     foor_(&r__1);
17008 // FFEINTRIN_impTANH //
17009     r__1 = tanh(r1);
17010     foor_(&r__1);
17011 // FFEINTRIN_imp_CMPLX_C //
17012     r__1 = c1.r;
17013     r__2 = c2.r;
17014     q__1.r = r__1, q__1.i = r__2;
17015     fooc_(&q__1);
17016 // FFEINTRIN_imp_CMPLX_D //
17017     z__1.r = d1, z__1.i = d2;
17018     fooz_(&z__1);
17019 // FFEINTRIN_imp_CMPLX_I //
17020     r__1 = (real) i1;
17021     r__2 = (real) i2;
17022     q__1.r = r__1, q__1.i = r__2;
17023     fooc_(&q__1);
17024 // FFEINTRIN_imp_CMPLX_R //
17025     q__1.r = r1, q__1.i = r2;
17026     fooc_(&q__1);
17027 // FFEINTRIN_imp_DBLE_C //
17028     d__1 = (doublereal) c1.r;
17029     food_(&d__1);
17030 // FFEINTRIN_imp_DBLE_D //
17031     d__1 = d1;
17032     food_(&d__1);
17033 // FFEINTRIN_imp_DBLE_I //
17034     d__1 = (doublereal) i1;
17035     food_(&d__1);
17036 // FFEINTRIN_imp_DBLE_R //
17037     d__1 = (doublereal) r1;
17038     food_(&d__1);
17039 // FFEINTRIN_imp_INT_C //
17040     i__1 = (integer) c1.r;
17041     fooi_(&i__1);
17042 // FFEINTRIN_imp_INT_D //
17043     i__1 = (integer) d1;
17044     fooi_(&i__1);
17045 // FFEINTRIN_imp_INT_I //
17046     i__1 = i1;
17047     fooi_(&i__1);
17048 // FFEINTRIN_imp_INT_R //
17049     i__1 = (integer) r1;
17050     fooi_(&i__1);
17051 // FFEINTRIN_imp_REAL_C //
17052     r__1 = c1.r;
17053     foor_(&r__1);
17054 // FFEINTRIN_imp_REAL_D //
17055     r__1 = (real) d1;
17056     foor_(&r__1);
17057 // FFEINTRIN_imp_REAL_I //
17058     r__1 = (real) i1;
17059     foor_(&r__1);
17060 // FFEINTRIN_imp_REAL_R //
17061     r__1 = r1;
17062     foor_(&r__1);
17063
17064 // FFEINTRIN_imp_INT_D: //
17065
17066 // FFEINTRIN_specIDINT //
17067     i__1 = (integer) d1;
17068     fooi_(&i__1);
17069
17070 // FFEINTRIN_imp_INT_R: //
17071
17072 // FFEINTRIN_specIFIX //
17073     i__1 = (integer) r1;
17074     fooi_(&i__1);
17075 // FFEINTRIN_specINT //
17076     i__1 = (integer) r1;
17077     fooi_(&i__1);
17078
17079 // FFEINTRIN_imp_REAL_D: //
17080
17081 // FFEINTRIN_specSNGL //
17082     r__1 = (real) d1;
17083     foor_(&r__1);
17084
17085 // FFEINTRIN_imp_REAL_I: //
17086
17087 // FFEINTRIN_specFLOAT //
17088     r__1 = (real) i1;
17089     foor_(&r__1);
17090 // FFEINTRIN_specREAL //
17091     r__1 = (real) i1;
17092     foor_(&r__1);
17093
17094 } // MAIN__ //
17095
17096 -------- (end output file from f2c)
17097
17098 */